;; -*- Mode:LISP; Package:SYSTEM-INTERNALS; Lowercase:T; Base:8; Readtable:ZL -*- ; ** (c) Copyright 1980 Massachusetts Institute of Technology ** ;;; This package provides for the definition and use of SELECTQ type ;;; objects that use the DTP-SELECT-METHOD microcode feature to allow ;;; destructuring of args on a per-operation basis #| (DEFSELECT

)> ( ... )> . . )>) (DEFSELECT FILE-CHAOSNET-COMMAND (:FOO (BAZ &REST BAR) (DO-SOME-WORK)) (:SPAZZ (&OPTIONAL (BAR 1)) (SPZZA))) |# ;;; The :SELECT-METHOD function spec. (defun (:property :select-method function-spec-handler) (function function-spec &optional arg1 arg2) (let ((select-method-function-spec (second function-spec)) (message (third function-spec)) select-method-alist elem fn new-p) (if (not (and (= (length function-spec) 3) (validate-function-spec select-method-function-spec))) (if (eq function 'validate-function-spec) nil (ferror 'sys:invalid-function-spec "The function spec ~S is invalid." function-spec)) (selectq function (validate-function-spec t) (function-parent (values (cadr function-spec) 'defun)) (t (unless (or (not (memq function '(fdefine fdefinition fdefinition-location fundefine fdefinedp))) (and (fdefinedp select-method-function-spec) (typep (setq fn (fdefinition select-method-function-spec)) 'select-method))) (ferror 'sys:invalid-function-spec "The function spec ~S is invalid;~%~S is not a DEFSELECT." function-spec select-method-function-spec)) (if fn (setq elem (assq-careful message (setq select-method-alist (%make-pointer dtp-list fn))))) (when (and (null elem) (memq function '(fdefine fdefinition-location))) ;; cons up a select-method (setq elem (cons message nil) new-p t) (fdefine select-method-function-spec (%make-pointer dtp-select-method (cons elem select-method-alist))) (let ((closure (cdr (assq-careful ':which-operations select-method-alist)))) (when (closurep closure) (pushnew message (symeval-in-closure closure '.defselect.which.operations.)) ':test 'eq))) (selectq function (fdefine (setf (cdr elem) arg1)) (fdefinition (cdr elem)) (fdefinition-location elem) (fdefinedp (cdr elem)) (fundefine (fdefine select-method-function-spec (%make-pointer dtp-select-method (remq elem select-method-alist))) (let* ((closure (cdr (assq-careful ':which-operations select-method-alist))) loc) (when (closurep closure) (setq loc (locate-in-closure closure '.defselect.which.operations.)) (setf (contents loc) (remq message (contents loc)))))) (t (function-spec-default-handler function function-spec arg1 arg2)))))))) (defmacro defselect (fspec &body methods &aux no-which-operations tail-pointer methods-list) "Define a function named FSPEC which dispatches on its first argument to find a method. Each element of METHODS is a method for one or several possible first arguments. Each method's car is a keyword, or a list of keywords. Its cdr is a lambda list for that method. The rest of the method is a body. When the function is called, the first argument should be a keyword. The first method which matches that keyword is run. Its lambda-list is bound to the remaining arguments (the keyword is not included). Its body is run and the value is the value of the function FSPEC itself. FSPEC is either a symbol, or a list of a function spec and another function to be called if no method matches the keyword. This other function must be a symbol; #'(lambda ...) and even #'foo will not work. /(DEFSELECT

)> / ( ... )> / . . )>)" ;; Decode FSPEC (and (consp fspec) (setq tail-pointer (cadr fspec) no-which-operations (caddr fspec) fspec (car fspec))) ;; Turn (FOO BAR) into (:PROPERTY FOO BAR) (setq fspec (standardize-function-spec fspec)) (setq methods-list (loop for method in methods when (consp (car method)) append (car method) else collect (car method))) (or no-which-operations (setq methods-list `(,@methods-list :which-operations :operation-handled-p :send-if-handles :get-handler-for))) `(def ,fspec (defselect-internal ',fspec ',tail-pointer ',methods-list ,(not no-which-operations)) ,@(loop for method in methods when (consp (car method)) append `(,(select-method-definition fspec (caar method) (cdr method)) . ,(loop for m in (cdar method) collect `(deff (:select-method ,fspec ,m) #'(:select-method ,fspec ,(caar method))))) else collect (select-method-definition fspec (car method) (cdr method))) ',fspec)) (defun select-method-definition (fspec method definition) (if (atom definition) `(deff (:select-method ,fspec ,method) ',definition) `(defun (:select-method ,fspec ,method) (ignore . ,(car definition)) . ,(cdr definition)))) ; This function ALWAYS returns nil, since **defselect-op** is not ever used anywhere else. ; What was this used for? mly ;(defun select-needed-op (body) ; (IF (atom body) ; (if (eq body '**DEFSELECT-OP**) '**DEFSELECT-OP** 'IGNORE) ; (LOOP FOR sub-body IN body ; AS result = (select-needed-op sub-body) ; UNTIL (eq result '**DEFSELECT-OP**) ; FINALLY (return result)))) (defun defselect-internal (fspec tail-pointer method-list auto-which-operations &aux tem old-alist new-alist) (and (fdefinedp fspec) (typep (setq tem (fdefinition fspec)) 'select-method) (setq old-alist (%make-pointer dtp-list tem))) ;; Go through extra pains to make the select method cdr-coded. (setq tem (length method-list)) (setq new-alist (make-list (if tail-pointer (1+ tem) tem))) (when tail-pointer (setq tem (last new-alist)) (rplaca tem tail-pointer) (without-interrupts (%p-dpb-offset cdr-error %%q-cdr-code tem 0) (%p-dpb-offset cdr-normal %%q-cdr-code tem -1))) (do ((method method-list (cdr method)) (sublist new-alist (cdr sublist))) ((null method)) (setf (car sublist) (cons (car method) 'select-method-undefined-message)) (if (setq tem (assq-careful (car method) old-alist)) (setf (cdr (car sublist)) (cdr tem)))) (setq tem (%make-pointer dtp-select-method new-alist)) (fdefine fspec tem t) (when auto-which-operations (setq tem (let-closed ((.defselect.which.operations. nil) (.defselect.self. tem)) 'defselect-which-operations)) (fdefine `(:select-method ,fspec :operation-handled-p) tem t) (fdefine `(:select-method ,fspec :send-if-handles) tem t) (fdefine `(:select-method ,fspec :get-handler-for) tem t) (fdefine `(:select-method ,fspec :which-operations) tem t)) t) (defun defselect-which-operations (op &rest rest &aux nsi) (declare (special .defselect.which.operations. .defselect.self.)) ;; gak. ;; if this select-method is used as a NAMED-STRUCTURE-INVOKation, ;; then the first arg passed is "self" ;; more vile kludgery used below for :send-if-handles (unless (symbolp (car rest)) ;let's fail to win... (setq nsi (pop rest))) (or .defselect.which.operations. (setq .defselect.which.operations. (defselect-make-which-operations .defselect.self.))) (selectq op (:which-operations .defselect.which.operations.) (:operation-handled-p (memq (car rest) .defselect.which.operations.)) (:send-if-handles (and (memq (car rest) .defselect.which.operations.) (if nsi (apply .defselect.self. (car rest) nsi (cdr rest)) (apply .defselect.self. rest)))) (:get-handler-for (cdr (assq-careful (car rest) (%make-pointer dtp-list .defselect.self.)))))) (defun defselect-make-which-operations (fctn &aux ops subr) ;; Ignore tracing, decode full hair, (:property foo bar), etc (or (typep fctn 'select-method) (setq fctn (fdefinition (unencapsulate-function-spec fctn)))) (do () ((or (null fctn) (and (symbolp fctn) (not (fboundp fctn)))) ;; This cdr-codes the list, and conses it safely away from temporary areas. (copy-list (nreverse ops) permanent-storage-area)) (typecase fctn (symbol (setq fctn (fsymeval fctn))) (cons (cond ((symbolp (car fctn)) (cond (subr (setq fctn subr) ;Already one deep, return (setq subr nil)) (t (setq subr (cdr fctn) ;explore subroutine fctn (car fctn))))) ; ((MEMQ (CAAR FCTN) ;Don't add these ; '(:WHICH-OPERATIONS :OPERATION-HANDLED-P ; :SEND-IF-HANDLES :GET-HANDLER-FOR)) ; (SETQ FCTN (CDR FCTN))) (t (setq ops (cons (caar fctn) ops)) (setq fctn (cdr fctn))))) ((and array (satisfies hash-array-funcallable-p)) (setq fctn (let ((alist nil)) (maphash #'(lambda (op meth-locative &rest ignore) (push (cons op (car meth-locative)) alist)) fctn) alist))) (select-method (setq fctn (%make-pointer dtp-list fctn))) ((or closure entity) (setq fctn (car (%make-pointer dtp-list fctn)))) (instance (setq fctn (flavor-method-hash-array (get (type-of fctn) 'flavor)))) (t (setq fctn nil))))) ;(defun select-method-undefined-message (message &rest arguments) ; (declare (dbg:error-reporter)) ; (error 'unclaimed-message ; :object "some select-method" ; :message message :arguments arguments)) (defmacro defselect-incremental (function-spec &optional default) "Define a select-method function to exist; let its methods be defined separately. Defines FUNCTION-SPEC as a select-method function, but does not create any methods for it (except for :WHICH-OPERATIONS, etc). You define the methods with individual DEFUNs, such as /(DEFUN (:SELECT-METHOD FUNCTION-SPEC OPERATION) (IGNORE ARG1 ARG2) ...) Note that the lambda list must include a variable, possibly ignored, to receive the operation name itself, since that is the first argument in the call. DEFAULT is a symbol which is a function to be called to handle operations that there are no methods for. Both arguments are unevaluated." `(defselect-incremental-internal ',function-spec ',default)) (defun defselect-incremental-internal (fspec tail-pointer &aux tem fn self) (if (and (fdefinedp fspec) (typep (setq tem (fdefinition fspec)) 'select-method)) (setf (cdr (last (setq fn (%make-pointer dtp-list tem)))) tail-pointer) (setq tem (let-closed ((.defselect.which.operations. nil) (.defselect.self. tem)) 'defselect-which-operations)) (setq self (%make-pointer dtp-select-method `((:which-operations . ,tem) (:operation-handled-p . ,tem) (:send-if-handles . ,tem) (:get-handler-for . ,tem) . ,tail-pointer))) (set-in-closure tem '.defselect.self. self) (fdefine fspec self t)) fspec) ;;; Differs from DEFSELECT-WHICH-OPERATIONS in not making a permanent list ;;; of the operations (since more could be added). ; no longer used, now that updating of which-operations is designed to win ;(DEFUN DEFSELECT-WHICH-OPERATIONS-DONT-CACHE (OP &REST REST) ; (DECLARE (SPECIAL .DEFSELECT-LOCATION.)) ; (SELECTQ OP ; (:WHICH-OPERATIONS (DEFSELECT-MAKE-WHICH-OPERATIONS (CONTENTS .DEFSELECT-LOCATION.))) ; (:OPERATION-HANDLED-P (ASSQ-CAREFUL (CAR REST) ; (%MAKE-POINTER DTP-LIST ; (CONTENTS .DEFSELECT-LOCATION.)))) ; (:SEND-IF-HANDLES (AND (ASSQ-CAREFUL (CAR REST) ; (%MAKE-POINTER DTP-LIST ; (CONTENTS .DEFSELECT-LOCATION.))) ; (APPLY (CONTENTS .DEFSELECT-LOCATION.) REST)))))