X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=6a8cc46530860db01941637dde7ebab75f994198;hb=54da325f13fb41669869aea688ae195426c0e231;hp=b49a1ab2589faf739cb93051b1b2802c2433bb8f;hpb=9ef9a441ee2d6471b4480572667d1e84e1e3e7e7;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index b49a1ab..6a8cc46 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -68,28 +68,13 @@ bootstrapping. |# -;;; FIXME: As of sbcl-0.6.9.10, PCL still uses this nonstandard type -;;; of declaration internally. It would be good to figure out how to -;;; get rid of it, or failing that, (1) document why it's needed and -;;; (2) use a private symbol with a forbidding name which suggests -;;; it's not to be messed with by the user (e.g. SB-PCL:%CLASS) -;;; instead of the too-inviting CLASS. (I tried just deleting the -;;; declarations in MAKE-METHOD-LAMBDA-INTERNAL ca. sbcl-0.6.9.10, but -;;; then things break.) -(declaim (declaration class)) - -(declaim (notinline make-a-method - add-named-method - ensure-generic-function-using-class - add-method - remove-method)) +(declaim (notinline make-a-method add-named-method + ensure-generic-function-using-class + add-method remove-method)) (defvar *!early-functions* - '((make-a-method early-make-a-method - real-make-a-method) - (add-named-method early-add-named-method - real-add-named-method) - )) + '((make-a-method early-make-a-method real-make-a-method) + (add-named-method early-add-named-method real-add-named-method))) ;;; For each of the early functions, arrange to have it point to its ;;; early definition. Do this in a way that makes sure that if we @@ -97,21 +82,24 @@ bootstrapping. ;;; effect. This makes development easier. (dolist (fns *!early-functions*) (let ((name (car fns)) - (early-name (cadr fns))) + (early-name (cadr fns))) (setf (gdefinition name) (set-fun-name (lambda (&rest args) - (apply (fdefinition early-name) args)) + (apply (fdefinition early-name) args)) name)))) ;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS ;;; to convert the few functions in the bootstrap which are supposed ;;; to be generic functions but can't be early on. +;;; +;;; each entry is a list of name and lambda-list, class names as +;;; specializers, and method body function name. (defvar *!generic-function-fixups* '((add-method - ((generic-function method) ;lambda-list - (standard-generic-function method) ;specializers - real-add-method)) ;method-function + ((generic-function method) + (standard-generic-function method) + real-add-method)) (remove-method ((generic-function method) (standard-generic-function method) @@ -122,23 +110,35 @@ bootstrapping. real-get-method)) (ensure-generic-function-using-class ((generic-function fun-name - &key generic-function-class environment - &allow-other-keys) + &key generic-function-class environment + &allow-other-keys) (generic-function t) real-ensure-gf-using-class--generic-function) ((generic-function fun-name - &key generic-function-class environment - &allow-other-keys) + &key generic-function-class environment + &allow-other-keys) (null t) real-ensure-gf-using-class--null)) (make-method-lambda ((proto-generic-function proto-method lambda-expression environment) (standard-generic-function standard-method t t) real-make-method-lambda)) + (make-method-specializers-form + ((proto-generic-function proto-method specializer-names environment) + (standard-generic-function standard-method t t) + real-make-method-specializers-form)) + (parse-specializer-using-class + ((generic-function specializer) + (standard-generic-function t) + real-parse-specializer-using-class)) + (unparse-specializer-using-class + ((generic-function specializer) + (standard-generic-function t) + real-unparse-specializer-using-class)) (make-method-initargs-form ((proto-generic-function proto-method - lambda-expression - lambda-list environment) + lambda-expression + lambda-list environment) (standard-generic-function standard-method t t t) real-make-method-initargs-form)) (compute-effective-method @@ -150,96 +150,105 @@ bootstrapping. (declare (type list lambda-list)) (unless (legal-fun-name-p fun-name) (error 'simple-program-error - :format-control "illegal generic function name ~S" - :format-arguments (list fun-name))) + :format-control "illegal generic function name ~S" + :format-arguments (list fun-name))) (check-gf-lambda-list lambda-list) (let ((initargs ()) - (methods ())) + (methods ())) (flet ((duplicate-option (name) - (error 'simple-program-error - :format-control "The option ~S appears more than once." - :format-arguments (list name))) - (expand-method-definition (qab) ; QAB = qualifiers, arglist, body - (let* ((arglist-pos (position-if #'listp qab)) - (arglist (elt qab arglist-pos)) - (qualifiers (subseq qab 0 arglist-pos)) - (body (nthcdr (1+ arglist-pos) qab))) - `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) + (error 'simple-program-error + :format-control "The option ~S appears more than once." + :format-arguments (list name))) + (expand-method-definition (qab) ; QAB = qualifiers, arglist, body + (let* ((arglist-pos (position-if #'listp qab)) + (arglist (elt qab arglist-pos)) + (qualifiers (subseq qab 0 arglist-pos)) + (body (nthcdr (1+ arglist-pos) qab))) + `(push (defmethod ,fun-name ,@qualifiers ,arglist ,@body) (generic-function-initial-methods (fdefinition ',fun-name)))))) (macrolet ((initarg (key) `(getf initargs ,key))) - (dolist (option options) - (let ((car-option (car option))) - (case car-option - (declare - (when (and - (consp (cadr option)) - (member (first (cadr option)) - ;; FIXME: this list is slightly weird. - ;; ANSI (on the DEFGENERIC page) in one - ;; place allows only OPTIMIZE; in - ;; another place gives this list of - ;; disallowed declaration specifiers. - ;; This seems to be the only place where - ;; the FUNCTION declaration is - ;; mentioned; TYPE seems to be missing. - ;; Very strange. -- CSR, 2002-10-21 - '(declaration ftype function - inline notinline special))) - (error 'simple-program-error - :format-control "The declaration specifier ~S ~ + (dolist (option options) + (let ((car-option (car option))) + (case car-option + (declare + (dolist (spec (cdr option)) + (unless (consp spec) + (error 'simple-program-error + :format-control "~@" + :format-arguments (list spec))) + (when (member (first spec) + ;; FIXME: this list is slightly weird. + ;; ANSI (on the DEFGENERIC page) in one + ;; place allows only OPTIMIZE; in + ;; another place gives this list of + ;; disallowed declaration specifiers. + ;; This seems to be the only place where + ;; the FUNCTION declaration is + ;; mentioned; TYPE seems to be missing. + ;; Very strange. -- CSR, 2002-10-21 + '(declaration ftype function + inline notinline special)) + (error 'simple-program-error + :format-control "The declaration specifier ~S ~ is not allowed inside DEFGENERIC." - :format-arguments (list (cadr option)))) - (push (cadr option) (initarg :declarations))) - (:method-combination - (when (initarg car-option) - (duplicate-option car-option)) - (unless (symbolp (cadr option)) - (error 'simple-program-error - :format-control "METHOD-COMBINATION name not a ~ + :format-arguments (list spec))) + (if (or (eq 'optimize (first spec)) + (info :declaration :recognized (first spec))) + (push spec (initarg :declarations)) + (warn "Ignoring unrecognized declaration in DEFGENERIC: ~S" + spec)))) + (:method-combination + (when (initarg car-option) + (duplicate-option car-option)) + (unless (symbolp (cadr option)) + (error 'simple-program-error + :format-control "METHOD-COMBINATION name not a ~ symbol: ~S" - :format-arguments (list (cadr option)))) - (setf (initarg car-option) - `',(cdr option))) - (:argument-precedence-order - (let* ((required (parse-lambda-list lambda-list)) - (supplied (cdr option))) - (unless (= (length required) (length supplied)) - (error 'simple-program-error - :format-control "argument count discrepancy in ~ + :format-arguments (list (cadr option)))) + (setf (initarg car-option) + `',(cdr option))) + (:argument-precedence-order + (let* ((required (parse-lambda-list lambda-list)) + (supplied (cdr option))) + (unless (= (length required) (length supplied)) + (error 'simple-program-error + :format-control "argument count discrepancy in ~ :ARGUMENT-PRECEDENCE-ORDER clause." - :format-arguments nil)) - (when (set-difference required supplied) - (error 'simple-program-error - :format-control "unequal sets for ~ + :format-arguments nil)) + (when (set-difference required supplied) + (error 'simple-program-error + :format-control "unequal sets for ~ :ARGUMENT-PRECEDENCE-ORDER clause: ~ ~S and ~S" - :format-arguments (list required supplied))) - (setf (initarg car-option) - `',(cdr option)))) - ((:documentation :generic-function-class :method-class) - (unless (proper-list-of-length-p option 2) - (error "bad list length for ~S" option)) - (if (initarg car-option) - (duplicate-option car-option) - (setf (initarg car-option) `',(cadr option)))) - (:method - (push (cdr option) methods)) - (t - ;; ANSI requires that unsupported things must get a - ;; PROGRAM-ERROR. - (error 'simple-program-error - :format-control "unsupported option ~S" - :format-arguments (list option)))))) - - (when (initarg :declarations) - (setf (initarg :declarations) - `',(initarg :declarations)))) + :format-arguments (list required supplied))) + (setf (initarg car-option) + `',(cdr option)))) + ((:documentation :generic-function-class :method-class) + (unless (proper-list-of-length-p option 2) + (error "bad list length for ~S" option)) + (if (initarg car-option) + (duplicate-option car-option) + (setf (initarg car-option) `',(cadr option)))) + (:method + (push (cdr option) methods)) + (t + ;; ANSI requires that unsupported things must get a + ;; PROGRAM-ERROR. + (error 'simple-program-error + :format-control "unsupported option ~S" + :format-arguments (list option)))))) + + (when (initarg :declarations) + (setf (initarg :declarations) + `',(initarg :declarations)))) `(progn - (eval-when (:compile-toplevel :load-toplevel :execute) - (compile-or-load-defgeneric ',fun-name)) - (load-defgeneric ',fun-name ',lambda-list ,@initargs) - ,@(mapcar #'expand-method-definition methods) - (fdefinition ',fun-name))))) + (eval-when (:compile-toplevel :load-toplevel :execute) + (compile-or-load-defgeneric ',fun-name)) + (load-defgeneric ',fun-name ',lambda-list + (sb-c:source-location) ,@initargs) + ,@(mapcar #'expand-method-definition methods) + (fdefinition ',fun-name))))) (defun compile-or-load-defgeneric (fun-name) (proclaim-as-fun-name fun-name) @@ -247,11 +256,13 @@ bootstrapping. (unless (eq (info :function :where-from fun-name) :declared) (setf (info :function :where-from fun-name) :defined) (setf (info :function :type fun-name) - (specifier-type 'function)))) + (specifier-type 'function)))) -(defun load-defgeneric (fun-name lambda-list &rest initargs) +(defun load-defgeneric (fun-name lambda-list source-location &rest initargs) (when (fboundp fun-name) - (style-warn "redefining ~S in DEFGENERIC" fun-name) + (warn 'sb-kernel:redefinition-with-defgeneric + :name fun-name + :new-location source-location) (let ((fun (fdefinition fun-name))) (when (generic-function-p fun) (loop for method in (generic-function-initial-methods fun) @@ -260,7 +271,7 @@ bootstrapping. (apply #'ensure-generic-function fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,fun-name) ,*load-pathname*) + :definition-source source-location initargs)) (define-condition generic-function-lambda-list-error @@ -271,13 +282,13 @@ bootstrapping. (defun check-gf-lambda-list (lambda-list) (flet ((ensure (arg ok) (unless ok - (error 'generic-function-lambda-list-error - :format-control - "~@" - :format-arguments (list arg lambda-list))))) + (error 'generic-function-lambda-list-error + :format-control + "~@" + :format-arguments (list arg lambda-list))))) (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux morep more-context more-count) - (parse-lambda-list lambda-list) + (parse-lambda-list lambda-list) (declare (ignore required)) ; since they're no different in a gf ll (declare (ignore restp rest)) ; since they're no different in a gf ll (declare (ignore allowp)) ; since &ALLOW-OTHER-KEYS is fine either way @@ -285,53 +296,87 @@ bootstrapping. (declare (ignore more-context more-count)) ; safely ignored unless MOREP ;; no defaults allowed for &OPTIONAL arguments (dolist (i optional) - (ensure i (or (symbolp i) - (and (consp i) (symbolp (car i)) (null (cdr i)))))) + (ensure i (or (symbolp i) + (and (consp i) (symbolp (car i)) (null (cdr i)))))) ;; no defaults allowed for &KEY arguments (when keyp - (dolist (i keys) - (ensure i (or (symbolp i) - (and (consp i) - (or (symbolp (car i)) - (and (consp (car i)) - (symbolp (caar i)) - (symbolp (cadar i)) - (null (cddar i)))) - (null (cdr i))))))) + (dolist (i keys) + (ensure i (or (symbolp i) + (and (consp i) + (or (symbolp (car i)) + (and (consp (car i)) + (symbolp (caar i)) + (symbolp (cadar i)) + (null (cddar i)))) + (null (cdr i))))))) ;; no &AUX allowed (when auxp - (error "&AUX is not allowed in a generic function lambda list: ~S" - lambda-list)) + (error "&AUX is not allowed in a generic function lambda list: ~S" + lambda-list)) ;; Oh, *puhlease*... not specifically as per section 3.4.2 of ;; the ANSI spec, but the CMU CL &MORE extension does not ;; belong here! (aver (not morep))))) -(defmacro defmethod (&rest args &environment env) - (multiple-value-bind (name qualifiers lambda-list body) +(defmacro defmethod (name &rest args) + (multiple-value-bind (qualifiers lambda-list body) (parse-defmethod args) - (multiple-value-bind (proto-gf proto-method) - (prototypes-for-make-method-lambda name) - (expand-defmethod name - proto-gf - proto-method - qualifiers - lambda-list - body - env)))) + `(progn + (eval-when (:compile-toplevel :execute) + ;; :compile-toplevel is needed for subsequent forms + ;; :execute is needed for references to itself inside the body + (compile-or-load-defgeneric ',name)) + ;; KLUDGE: this double expansion is quite a monumental + ;; workaround: it comes about because of a fantastic interaction + ;; between the processing rules of CLHS 3.2.3.1 and the + ;; bizarreness of MAKE-METHOD-LAMBDA. + ;; + ;; MAKE-METHOD-LAMBDA can be called by the user, and if the + ;; lambda itself doesn't refer to outside bindings the return + ;; value must be compileable in the null lexical environment. + ;; However, the function must also refer somehow to the + ;; associated method object, so that it can call NO-NEXT-METHOD + ;; with the appropriate arguments if there is no next method -- + ;; but when the function is generated, the method object doesn't + ;; exist yet. + ;; + ;; In order to resolve this issue, we insert a literal cons cell + ;; into the body of the method lambda, return the same cons cell + ;; as part of the second (initargs) return value of + ;; MAKE-METHOD-LAMBDA, and a method on INITIALIZE-INSTANCE fills + ;; in the cell when the method is created. However, this + ;; strategy depends on having a fresh cons cell for every method + ;; lambda, which (without the workaround below) is skewered by + ;; the processing in CLHS 3.2.3.1, which permits implementations + ;; to macroexpand the bodies of EVAL-WHEN forms with both + ;; :COMPILE-TOPLEVEL and :LOAD-TOPLEVEL only once. The + ;; expansion below forces the double expansion in those cases, + ;; while expanding only once in the common case. + (eval-when (:load-toplevel) + (%defmethod-expander ,name ,qualifiers ,lambda-list ,body)) + (eval-when (:execute) + (%defmethod-expander ,name ,qualifiers ,lambda-list ,body))))) + +(defmacro %defmethod-expander + (name qualifiers lambda-list body &environment env) + (multiple-value-bind (proto-gf proto-method) + (prototypes-for-make-method-lambda name) + (expand-defmethod name proto-gf proto-method qualifiers + lambda-list body env))) + (defun prototypes-for-make-method-lambda (name) - (if (not (eq *boot-state* 'complete)) + (if (not (eq **boot-state** 'complete)) (values nil nil) - (let ((gf? (and (gboundp name) - (gdefinition name)))) - (if (or (null gf?) - (not (generic-function-p gf?))) - (values (class-prototype (find-class 'standard-generic-function)) - (class-prototype (find-class 'standard-method))) - (values gf? - (class-prototype (or (generic-function-method-class gf?) - (find-class 'standard-method)))))))) + (let ((gf? (and (fboundp name) + (gdefinition name)))) + (if (or (null gf?) + (not (generic-function-p gf?))) + (values (class-prototype (find-class 'standard-generic-function)) + (class-prototype (find-class 'standard-method))) + (values gf? + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method)))))))) ;;; Take a name which is either a generic function name or a list specifying ;;; a SETF generic function (like: (SETF )). Return @@ -345,124 +390,142 @@ bootstrapping. ;;; ;;; Note: During bootstrapping, this function is allowed to return NIL. (defun method-prototype-for-gf (name) - (let ((gf? (and (gboundp name) - (gdefinition name)))) - (cond ((neq *boot-state* 'complete) nil) - ((or (null gf?) - (not (generic-function-p gf?))) ; Someone else MIGHT - ; error at load time. - (class-prototype (find-class 'standard-method))) - (t - (class-prototype (or (generic-function-method-class gf?) - (find-class 'standard-method))))))) + (let ((gf? (and (fboundp name) + (gdefinition name)))) + (cond ((neq **boot-state** 'complete) nil) + ((or (null gf?) + (not (generic-function-p gf?))) ; Someone else MIGHT + ; error at load time. + (class-prototype (find-class 'standard-method))) + (t + (class-prototype (or (generic-function-method-class gf?) + (find-class 'standard-method))))))) +;;; These are used to communicate the method name and lambda-list to +;;; MAKE-METHOD-LAMBDA-INTERNAL. +(defvar *method-name* nil) +(defvar *method-lambda-list* nil) + (defun expand-defmethod (name - proto-gf - proto-method - qualifiers - lambda-list - body - env) - (multiple-value-bind (method-lambda unspecialized-lambda-list specializers) - (add-method-declarations name qualifiers lambda-list body env) - (multiple-value-bind (method-function-lambda initargs) - (make-method-lambda proto-gf proto-method method-lambda env) - (let ((initargs-form (make-method-initargs-form proto-gf - proto-method - method-function-lambda - initargs - env))) - `(progn - ;; Note: We could DECLAIM the ftype of the generic function - ;; here, since ANSI specifies that we create it if it does - ;; not exist. However, I chose not to, because I think it's - ;; more useful to support a style of programming where every - ;; generic function has an explicit DEFGENERIC and any typos - ;; in DEFMETHODs are warned about. Otherwise - ;; - ;; (DEFGENERIC FOO-BAR-BLETCH ((X T))) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) - ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) - ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) - ;; - ;; compiles without raising an error and runs without - ;; raising an error (since SIMPLE-VECTOR cases fall through - ;; to VECTOR) but still doesn't do what was intended. I hate - ;; that kind of bug (code which silently gives the wrong - ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 - ,(make-defmethod-form name qualifiers specializers - unspecialized-lambda-list - (if proto-method - (class-name (class-of proto-method)) - 'standard-method) - initargs-form - (getf (getf initargs :plist) - :pv-table-symbol))))))) + proto-gf + proto-method + qualifiers + lambda-list + body + env) + (multiple-value-bind (parameters unspecialized-lambda-list specializers) + (parse-specialized-lambda-list lambda-list) + (declare (ignore parameters)) + (let ((method-lambda `(lambda ,unspecialized-lambda-list ,@body)) + (*method-name* `(,name ,@qualifiers ,specializers)) + (*method-lambda-list* lambda-list)) + (multiple-value-bind (method-function-lambda initargs) + (make-method-lambda proto-gf proto-method method-lambda env) + (let ((initargs-form (make-method-initargs-form + proto-gf proto-method method-function-lambda + initargs env)) + (specializers-form (make-method-specializers-form + proto-gf proto-method specializers env))) + `(progn + ;; Note: We could DECLAIM the ftype of the generic function + ;; here, since ANSI specifies that we create it if it does + ;; not exist. However, I chose not to, because I think it's + ;; more useful to support a style of programming where every + ;; generic function has an explicit DEFGENERIC and any typos + ;; in DEFMETHODs are warned about. Otherwise + ;; + ;; (DEFGENERIC FOO-BAR-BLETCH (X)) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X HASH-TABLE)) ..) + ;; (DEFMETHOD FOO-BRA-BLETCH ((X SIMPLE-VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X VECTOR)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X ARRAY)) ..) + ;; (DEFMETHOD FOO-BAR-BLETCH ((X LIST)) ..) + ;; + ;; compiles without raising an error and runs without + ;; raising an error (since SIMPLE-VECTOR cases fall through + ;; to VECTOR) but still doesn't do what was intended. I hate + ;; that kind of bug (code which silently gives the wrong + ;; answer), so we don't do a DECLAIM here. -- WHN 20000229 + ,(make-defmethod-form name qualifiers specializers-form + unspecialized-lambda-list + (if proto-method + (class-name (class-of proto-method)) + 'standard-method) + initargs-form))))))) (defun interned-symbol-p (x) (and (symbolp x) (symbol-package x))) -(defun make-defmethod-form (name qualifiers specializers - unspecialized-lambda-list method-class-name - initargs-form &optional pv-table-symbol) +(defun make-defmethod-form + (name qualifiers specializers unspecialized-lambda-list + method-class-name initargs-form) (let (fn - fn-lambda) + fn-lambda) (if (and (interned-symbol-p (fun-name-block-name name)) - (every #'interned-symbol-p qualifiers) - (every (lambda (s) - (if (consp s) - (and (eq (car s) 'eql) - (constantp (cadr s)) - (let ((sv (eval (cadr s)))) - (or (interned-symbol-p sv) - (integerp sv) - (and (characterp sv) - (standard-char-p sv))))) - (interned-symbol-p s))) - specializers) - (consp initargs-form) - (eq (car initargs-form) 'list*) - (memq (cadr initargs-form) '(:function :fast-function)) - (consp (setq fn (caddr initargs-form))) - (eq (car fn) 'function) - (consp (setq fn-lambda (cadr fn))) - (eq (car fn-lambda) 'lambda)) - (let* ((specls (mapcar (lambda (specl) - (if (consp specl) - `(,(car specl) ,(eval (cadr specl))) - specl)) - specializers)) - (mname `(,(if (eq (cadr initargs-form) :function) - 'slow-method 'fast-method) - ,name ,@qualifiers ,specls))) - `(progn - (defun ,mname ,(cadr fn-lambda) - ,@(cddr fn-lambda)) - ,(make-defmethod-form-internal - name qualifiers `',specls - unspecialized-lambda-list method-class-name - `(list* ,(cadr initargs-form) - #',mname - ,@(cdddr initargs-form)) - pv-table-symbol))) - (make-defmethod-form-internal - name qualifiers - `(list ,@(mapcar (lambda (specializer) - (if (consp specializer) - ``(,',(car specializer) - ,,(cadr specializer)) - `',specializer)) - specializers)) - unspecialized-lambda-list - method-class-name - initargs-form - pv-table-symbol)))) + (every #'interned-symbol-p qualifiers) + (every (lambda (s) + (if (consp s) + (and (eq (car s) 'eql) + (constantp (cadr s)) + (let ((sv (constant-form-value (cadr s)))) + (or (interned-symbol-p sv) + (integerp sv) + (and (characterp sv) + (standard-char-p sv))))) + (interned-symbol-p s))) + specializers) + (consp initargs-form) + (eq (car initargs-form) 'list*) + (memq (cadr initargs-form) '(:function)) + (consp (setq fn (caddr initargs-form))) + (eq (car fn) 'function) + (consp (setq fn-lambda (cadr fn))) + (eq (car fn-lambda) 'lambda) + (bug "Really got here")) + (let* ((specls (mapcar (lambda (specl) + (if (consp specl) + ;; CONSTANT-FORM-VALUE? What I + ;; kind of want to know, though, + ;; is what happens if we don't do + ;; this for some slow-method + ;; function because of a hairy + ;; lexenv -- is the only bad + ;; effect that the method + ;; function ends up unnamed? If + ;; so, couldn't we arrange to + ;; name it later? + `(,(car specl) ,(eval (cadr specl))) + specl)) + specializers)) + (mname `(,(if (eq (cadr initargs-form) :function) + 'slow-method 'fast-method) + ,name ,@qualifiers ,specls))) + `(progn + (defun ,mname ,(cadr fn-lambda) + ,@(cddr fn-lambda)) + ,(make-defmethod-form-internal + name qualifiers `',specls + unspecialized-lambda-list method-class-name + `(list* ,(cadr initargs-form) + #',mname + ,@(cdddr initargs-form))))) + (make-defmethod-form-internal + name qualifiers + specializers + #+nil + `(list ,@(mapcar (lambda (specializer) + (if (consp specializer) + ``(,',(car specializer) + ,,(cadr specializer)) + `',specializer)) + specializers)) + unspecialized-lambda-list + method-class-name + initargs-form)))) (defun make-defmethod-form-internal (name qualifiers specializers-form unspecialized-lambda-list - method-class-name initargs-form &optional pv-table-symbol) + method-class-name initargs-form) `(load-defmethod ',method-class-name ',name @@ -470,429 +533,559 @@ bootstrapping. ,specializers-form ',unspecialized-lambda-list ,initargs-form - ;; Paper over a bug in KCL by passing the cache-symbol here in - ;; addition to in the list. FIXME: We should no longer need to do - ;; this, since the CLOS code is now SBCL-specific, and doesn't - ;; need to be ported to every buggy compiler in existence. - ',pv-table-symbol)) + (sb-c:source-location))) (defmacro make-method-function (method-lambda &environment env) - (make-method-function-internal method-lambda env)) - -(defun make-method-function-internal (method-lambda &optional env) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda nil) (multiple-value-bind (method-function-lambda initargs) - (make-method-lambda proto-gf proto-method method-lambda env) + (make-method-lambda proto-gf proto-method method-lambda env) (make-method-initargs-form proto-gf - proto-method - method-function-lambda - initargs - env)))) - -(defun add-method-declarations (name qualifiers lambda-list body env) - (declare (ignore env)) - (multiple-value-bind (parameters unspecialized-lambda-list specializers) - (parse-specialized-lambda-list lambda-list) - (multiple-value-bind (real-body declarations documentation) - (parse-body body) - (values `(lambda ,unspecialized-lambda-list - ,@(when documentation `(,documentation)) - ;; (Old PCL code used a somewhat different style of - ;; list for %METHOD-NAME values. Our names use - ;; ,@QUALIFIERS instead of ,QUALIFIERS so that the - ;; method names look more like what you see in a - ;; DEFMETHOD form.) - ;; - ;; FIXME: As of sbcl-0.7.0.6, code elsewhere, at - ;; least the code to set up named BLOCKs around the - ;; bodies of methods, depends on the function's base - ;; name being the first element of the %METHOD-NAME - ;; list. It would be good to remove this dependency, - ;; perhaps by building the BLOCK here, or by using - ;; another declaration (e.g. %BLOCK-NAME), so that - ;; our method debug names are free to have any format, - ;; e.g. (:METHOD PRINT-OBJECT :AROUND (CLOWN T)). - ;; - ;; Further, as of sbcl-0.7.9.10, the code to - ;; implement NO-NEXT-METHOD is coupled to the form of - ;; this declaration; see the definition of - ;; CALL-NO-NEXT-METHOD (and the passing of - ;; METHOD-NAME-DECLARATION arguments around the - ;; various CALL-NEXT-METHOD logic). - (declare (%method-name (,name - ,@qualifiers - ,specializers))) - (declare (%method-lambda-list ,@lambda-list)) - ,@declarations - ,@real-body) - unspecialized-lambda-list specializers)))) + proto-method + method-function-lambda + initargs + env)))) (defun real-make-method-initargs-form (proto-gf proto-method - method-lambda initargs env) + method-lambda initargs env) (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) - (eq (car method-lambda) 'lambda)) + (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-FUNCTION, ~S, ~ - is not a lambda form." - method-lambda)) + is not a lambda form." + method-lambda)) (make-method-initargs-form-internal method-lambda initargs env)) (unless (fboundp 'make-method-initargs-form) (setf (gdefinition 'make-method-initargs-form) - (symbol-function 'real-make-method-initargs-form))) - + (symbol-function 'real-make-method-initargs-form))) + +;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular +;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of +;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the +;;; REAL-MAKE-METHOD lambda is used as the body of the default method. +;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function +;;; so that changing it in a live image is easy, and changes actually +;;; take effect. (defun real-make-method-lambda (proto-gf proto-method method-lambda env) - (declare (ignore proto-gf proto-method)) - (make-method-lambda-internal method-lambda env)) + (make-method-lambda-internal proto-gf proto-method method-lambda env)) -;;; a helper function for creating Python-friendly type declarations -;;; in DEFMETHOD forms -(defun parameter-specializer-declaration-in-defmethod (parameter specializer) - (cond ((and (consp specializer) - (eq (car specializer) 'eql)) - ;; KLUDGE: ANSI, in its wisdom, says that - ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at - ;; DEFMETHOD expansion time. Thus, although one might think - ;; that in - ;; (DEFMETHOD FOO ((X PACKAGE) - ;; (Y (EQL 12)) - ;; ..)) - ;; the PACKAGE and (EQL 12) forms are both parallel type - ;; names, they're not, as is made clear when you do - ;; (DEFMETHOD FOO ((X PACKAGE) - ;; (Y (EQL 'BAR))) - ;; ..) - ;; where Y needs to be a symbol named "BAR", not some cons - ;; made by (CONS 'QUOTE 'BAR). I.e. when the - ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument - ;; to be of type (EQL X). It'd be easy to transform one to - ;; the other, but it'd be somewhat messier to do so while - ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd - ;; once. (The new code wouldn't be messy, but it'd require a - ;; big transformation of the old code.) So instead we punt. - ;; -- WHN 20000610 - '(ignorable)) - ((member specializer - ;; KLUDGE: For some low-level implementation - ;; classes, perhaps because of some problems related - ;; to the incomplete integration of PCL into SBCL's - ;; type system, some specializer classes can't be - ;; declared as argument types. E.g. - ;; (DEFMETHOD FOO ((X SLOT-OBJECT)) - ;; (DECLARE (TYPE SLOT-OBJECT X)) - ;; ..) - ;; loses when - ;; (DEFSTRUCT BAR A B) - ;; (FOO (MAKE-BAR)) - ;; perhaps because of the way that STRUCTURE-OBJECT - ;; inherits both from SLOT-OBJECT and from - ;; SB-KERNEL:INSTANCE. In an effort to sweep such - ;; problems under the rug, we exclude these problem - ;; cases by blacklisting them here. -- WHN 2001-01-19 - '(slot-object)) - '(ignorable)) - ((not (eq *boot-state* 'complete)) - ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with - ;; types which don't match their specializers. (Specifically, - ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL - ;; second argument.) Hopefully it only does this kind of - ;; weirdness when bootstrapping.. -- WHN 20000610 - '(ignorable)) - ((var-globally-special-p parameter) - ;; KLUDGE: Don't declare types for global special variables - ;; -- our rebinding magic for SETQ cases don't work right - ;; there. - ;; - ;; FIXME: It would be better to detect the SETQ earlier and - ;; skip declarations for specials only when needed, not - ;; always. - ;; - ;; --NS 2004-10-14 - '(ignorable)) - (t - ;; Otherwise, we can usually make Python very happy. - (let ((kind (info :type :kind specializer))) - (ecase kind - ((:primitive) `(type ,specializer ,parameter)) - ((:defined) - ;; some BUILT-IN-CLASSes (e.g. REAL) are also :DEFINED - ;; types. Nothing else should be. - (let ((class (find-class specializer nil))) - (aver class) - (aver (typep class 'built-in-class))) - `(type ,specializer ,parameter)) - ((:instance nil) - (let ((class (find-class specializer nil))) - (cond - (class - (if (typep class '(or built-in-class structure-class)) - `(type ,specializer ,parameter) - ;; don't declare CLOS classes as parameters; - ;; it's too expensive. - '(ignorable))) - (t - ;; we can get here, and still not have a failure - ;; case, by doing MOP programming like (PROGN - ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) - ;; ...)). Best to let the user know we haven't - ;; been able to extract enough information: - (style-warn - "~@" - specializer - 'parameter-specializer-declaration-in-defmethod) - '(ignorable))))) - ((:forthcoming-defclass-type) '(ignorable))))))) - -(defun make-method-lambda-internal (method-lambda &optional env) +(unless (fboundp 'make-method-lambda) + (setf (gdefinition 'make-method-lambda) + (symbol-function 'real-make-method-lambda))) + +(defun declared-specials (declarations) + (loop for (declare . specifiers) in declarations + append (loop for specifier in specifiers + when (eq 'special (car specifier)) + append (cdr specifier)))) + +(defun make-method-lambda-internal (proto-gf proto-method method-lambda env) + (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ - is not a lambda form." - method-lambda)) + is not a lambda form." + method-lambda)) (multiple-value-bind (real-body declarations documentation) (parse-body (cddr method-lambda)) - (let* ((name-decl (get-declaration '%method-name declarations)) - (sll-decl (get-declaration '%method-lambda-list declarations)) - (method-name (when (consp name-decl) (car name-decl))) - (generic-function-name (when method-name (car method-name))) - (specialized-lambda-list (or sll-decl (cadr method-lambda)))) + ;; We have the %METHOD-NAME declaration in the place where we expect it only + ;; if there is are no non-standard prior MAKE-METHOD-LAMBDA methods -- or + ;; unless they're fantastically unintrusive. + (let* ((method-name *method-name*) + (method-lambda-list *method-lambda-list*) + ;; Macroexpansion caused by code-walking may call make-method-lambda and + ;; end up with wrong values + (*method-name* nil) + (*method-lambda-list* nil) + (generic-function-name (when method-name (car method-name))) + (specialized-lambda-list (or method-lambda-list + (ecase (car method-lambda) + (lambda (second method-lambda)) + (named-lambda (third method-lambda))))) + ;; the method-cell is a way of communicating what method a + ;; method-function implements, for the purpose of + ;; NO-NEXT-METHOD. We need something that can be shared + ;; between function and initargs, but not something that + ;; will be coalesced as a constant (because we are naughty, + ;; oh yes) with the expansion of any other methods in the + ;; same file. -- CSR, 2007-05-30 + (method-cell (list (make-symbol "METHOD-CELL")))) (multiple-value-bind (parameters lambda-list specializers) - (parse-specialized-lambda-list specialized-lambda-list) - (let* ((required-parameters - (mapcar (lambda (r s) (declare (ignore s)) r) - parameters - specializers)) - (slots (mapcar #'list required-parameters)) - (calls (list nil)) - (class-declarations - `(declare - ;; These declarations seem to be used by PCL to pass - ;; information to itself; when I tried to delete 'em - ;; ca. 0.6.10 it didn't work. I'm not sure how - ;; they work, but note the (VAR-DECLARATION '%CLASS ..) - ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 - ,@(remove nil - (mapcar (lambda (a s) (and (symbolp s) - (neq s t) - `(%class ,a ,s))) - parameters - specializers)) - ;; These TYPE declarations weren't in the original - ;; PCL code, but the Python compiler likes them a - ;; lot. (We're telling the compiler about our - ;; knowledge of specialized argument types so that - ;; it can avoid run-time type dispatch overhead, - ;; which can be a huge win for Python.) - ;; - ;; KLUDGE: when I tried moving these to - ;; ADD-METHOD-DECLARATIONS, things broke. No idea - ;; why. -- CSR, 2004-06-16 - ,@(mapcar #'parameter-specializer-declaration-in-defmethod - parameters - specializers))) - (method-lambda - ;; Remove the documentation string and insert the - ;; appropriate class declarations. The documentation - ;; string is removed to make it easy for us to insert - ;; new declarations later, they will just go after the - ;; CADR of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's - ;; arguments to the code walk. - `(lambda ,lambda-list - ;; The default ignorability of method parameters - ;; doesn't seem to be specified by ANSI. PCL had - ;; them basically ignorable but was a little - ;; inconsistent. E.g. even though the two - ;; method definitions - ;; (DEFMETHOD FOO ((X T) (Y T)) "Z") - ;; (DEFMETHOD FOO ((X T) Y) "Z") - ;; are otherwise equivalent, PCL treated Y as - ;; ignorable in the first definition but not in the - ;; second definition. We make all required - ;; parameters ignorable as a way of systematizing - ;; the old PCL behavior. -- WHN 2000-11-24 - (declare (ignorable ,@required-parameters)) - ,class-declarations - ,@declarations - (block ,(fun-name-block-name generic-function-name) - ,@real-body))) - (constant-value-p (and (null (cdr real-body)) - (constantp (car real-body)))) - (constant-value (and constant-value-p - (eval (car real-body)))) - (plist (and constant-value-p + (parse-specialized-lambda-list specialized-lambda-list) + (let* ((required-parameters + (mapcar (lambda (r s) (declare (ignore s)) r) + parameters + specializers)) + (slots (mapcar #'list required-parameters)) + (class-declarations + `(declare + ;; These declarations seem to be used by PCL to pass + ;; information to itself; when I tried to delete 'em + ;; ca. 0.6.10 it didn't work. I'm not sure how + ;; they work, but note the (VAR-DECLARATION '%CLASS ..) + ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 + ,@(remove nil + (mapcar (lambda (a s) (and (symbolp s) + (neq s t) + `(%class ,a ,s))) + parameters + specializers)) + ;; These TYPE declarations weren't in the original + ;; PCL code, but the Python compiler likes them a + ;; lot. (We're telling the compiler about our + ;; knowledge of specialized argument types so that + ;; it can avoid run-time type dispatch overhead, + ;; which can be a huge win for Python.) + ;; + ;; KLUDGE: when I tried moving these to + ;; ADD-METHOD-DECLARATIONS, things broke. No idea + ;; why. -- CSR, 2004-06-16 + ,@(let ((specials (declared-specials declarations))) + (mapcar (lambda (par spec) + (parameter-specializer-declaration-in-defmethod + par spec specials env)) + parameters + specializers)))) + (method-lambda + ;; Remove the documentation string and insert the + ;; appropriate class declarations. The documentation + ;; string is removed to make it easy for us to insert + ;; new declarations later, they will just go after the + ;; CADR of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's + ;; arguments to the code walk. + `(lambda ,lambda-list + ;; The default ignorability of method parameters + ;; doesn't seem to be specified by ANSI. PCL had + ;; them basically ignorable but was a little + ;; inconsistent. E.g. even though the two + ;; method definitions + ;; (DEFMETHOD FOO ((X T) (Y T)) "Z") + ;; (DEFMETHOD FOO ((X T) Y) "Z") + ;; are otherwise equivalent, PCL treated Y as + ;; ignorable in the first definition but not in the + ;; second definition. We make all required + ;; parameters ignorable as a way of systematizing + ;; the old PCL behavior. -- WHN 2000-11-24 + (declare (ignorable ,@required-parameters)) + ,class-declarations + ,@declarations + (block ,(fun-name-block-name generic-function-name) + ,@real-body))) + (constant-value-p (and (null (cdr real-body)) + (constantp (car real-body)))) + (constant-value (and constant-value-p + (constant-form-value (car real-body)))) + (plist (and constant-value-p (or (typep constant-value '(or number character)) (and (symbolp constant-value) (symbol-package constant-value))) (list :constant-value constant-value))) - (applyp (dolist (p lambda-list nil) - (cond ((memq p '(&optional &rest &key)) - (return t)) - ((eq p '&aux) - (return nil)))))) - (multiple-value-bind - (walked-lambda call-next-method-p closurep - next-method-p-p setq-p) - (walk-method-lambda method-lambda - required-parameters - env - slots - calls) - (multiple-value-bind (walked-lambda-body - walked-declarations - walked-documentation) - (parse-body (cddr walked-lambda)) - (declare (ignore walked-documentation)) - (when (or next-method-p-p call-next-method-p) - (setq plist (list* :needs-next-methods-p t plist))) - (when (some #'cdr slots) - (multiple-value-bind (slot-name-lists call-list) - (slot-name-lists-from-slots slots calls) - (let ((pv-table-symbol (make-symbol "pv-table"))) - (setq plist - `(,@(when slot-name-lists - `(:slot-name-lists ,slot-name-lists)) - ,@(when call-list - `(:call-list ,call-list)) - :pv-table-symbol ,pv-table-symbol - ,@plist)) - (setq walked-lambda-body - `((pv-binding (,required-parameters - ,slot-name-lists - ,pv-table-symbol) - ,@walked-lambda-body)))))) - (when (and (memq '&key lambda-list) - (not (memq '&allow-other-keys lambda-list))) - (let ((aux (memq '&aux lambda-list))) - (setq lambda-list (nconc (ldiff lambda-list aux) - (list '&allow-other-keys) - aux)))) - (values `(lambda (.method-args. .next-methods.) - (simple-lexical-method-functions - (,lambda-list .method-args. .next-methods. - :call-next-method-p - ,call-next-method-p - :next-method-p-p ,next-method-p-p - :setq-p ,setq-p - ;; we need to pass this along - ;; so that NO-NEXT-METHOD can - ;; be given a suitable METHOD - ;; argument; we need the - ;; QUALIFIERS and SPECIALIZERS - ;; inside the declaration to - ;; give to FIND-METHOD. - :method-name-declaration ,name-decl - :closurep ,closurep - :applyp ,applyp) - ,@walked-declarations - ,@walked-lambda-body)) - `(,@(when plist - `(:plist ,plist)) - ,@(when documentation - `(:documentation ,documentation))))))))))) + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind + (walked-lambda call-next-method-p closurep + next-method-p-p setq-p + parameters-setqd) + (walk-method-lambda method-lambda + required-parameters + env + slots) + (multiple-value-bind (walked-lambda-body + walked-declarations + walked-documentation) + (parse-body (cddr walked-lambda)) + (declare (ignore walked-documentation)) + (when (some #'cdr slots) + (let ((slot-name-lists (slot-name-lists-from-slots slots))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters + ,slot-name-lists + (load-time-value + (intern-pv-table + :slot-name-lists ',slot-name-lists))) + ,@walked-lambda-body))))) + (when (and (memq '&key lambda-list) + (not (memq '&allow-other-keys lambda-list))) + (let ((aux (memq '&aux lambda-list))) + (setq lambda-list (nconc (ldiff lambda-list aux) + (list '&allow-other-keys) + aux)))) + (values `(lambda (.method-args. .next-methods.) + (simple-lexical-method-functions + (,lambda-list .method-args. .next-methods. + :call-next-method-p + ,(when call-next-method-p t) + :next-method-p-p ,next-method-p-p + :setq-p ,setq-p + :parameters-setqd ,parameters-setqd + :method-cell ,method-cell + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + (locally + (declare (disable-package-locks + %parameter-binding-modified)) + (symbol-macrolet ((%parameter-binding-modified + ',@parameters-setqd)) + (declare (enable-package-locks + %parameter-binding-modified)) + ,@walked-lambda-body)))) + `(,@(when call-next-method-p `(method-cell ,method-cell)) + ,@(when (member call-next-method-p '(:simple nil)) + '(simple-next-method-call t)) + ,@(when plist `(plist ,plist)) + ,@(when documentation `(:documentation ,documentation))))))))))) + +(defun real-make-method-specializers-form + (proto-gf proto-method specializer-names env) + (declare (ignore env proto-gf proto-method)) + (flet ((parse (name) + (cond + ((and (eq **boot-state** 'complete) + (specializerp name)) + name) + ((symbolp name) `(find-class ',name)) + ((consp name) (ecase (car name) + ((eql) `(intern-eql-specializer ,(cadr name))) + ((class-eq) `(class-eq-specializer (find-class ',(cadr name)))))) + (t + ;; FIXME: Document CLASS-EQ specializers. + (error 'simple-reference-error + :format-control + "~@<~S is not a valid parameter specializer name.~@:>" + :format-arguments (list name) + :references (list '(:ansi-cl :macro defmethod) + '(:ansi-cl :glossary "parameter specializer name"))))))) + `(list ,@(mapcar #'parse specializer-names)))) + +(unless (fboundp 'make-method-specializers-form) + (setf (gdefinition 'make-method-specializers-form) + (symbol-function 'real-make-method-specializers-form))) + +(defun real-parse-specializer-using-class (generic-function specializer) + (let ((result (specializer-from-type specializer))) + (if (specializerp result) + result + (error "~@<~S cannot be parsed as a specializer for ~S.~@:>" + specializer generic-function)))) + +(unless (fboundp 'parse-specializer-using-class) + (setf (gdefinition 'parse-specializer-using-class) + (symbol-function 'real-parse-specializer-using-class))) + +(defun real-unparse-specializer-using-class (generic-function specializer) + (if (specializerp specializer) + ;; FIXME: this HANDLER-CASE is a bit of a hammer to crack a nut: + ;; the idea is that we want to unparse permissively, so that the + ;; lazy (or rather the "portable") specializer extender (who + ;; does not define methods on these new SBCL-specific MOP + ;; functions) can still subclass specializer and define methods + ;; without everything going wrong. Making it cleaner and + ;; clearer that that is what we are defending against would be + ;; nice. -- CSR, 2007-06-01 + (handler-case + (let ((type (specializer-type specializer))) + (if (and (consp type) (eq (car type) 'class)) + (let* ((class (cadr type)) + (class-name (class-name class))) + (if (eq class (find-class class-name nil)) + class-name + type)) + type)) + (error () specializer)) + (error "~@<~S is not a legal specializer for ~S.~@:>" + specializer generic-function))) + +(unless (fboundp 'unparse-specializer-using-class) + (setf (gdefinition 'unparse-specializer-using-class) + (symbol-function 'real-unparse-specializer-using-class))) -(unless (fboundp 'make-method-lambda) - (setf (gdefinition 'make-method-lambda) - (symbol-function 'real-make-method-lambda))) +;;; a helper function for creating Python-friendly type declarations +;;; in DEFMETHOD forms. +;;; +;;; We're too lazy to cons up a new environment for this, so we just pass in +;;; the list of locally declared specials in addition to the old environment. +(defun parameter-specializer-declaration-in-defmethod + (parameter specializer specials env) + (cond ((and (consp specializer) + (eq (car specializer) 'eql)) + ;; KLUDGE: ANSI, in its wisdom, says that + ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at + ;; DEFMETHOD expansion time. Thus, although one might think + ;; that in + ;; (DEFMETHOD FOO ((X PACKAGE) + ;; (Y (EQL 12)) + ;; ..)) + ;; the PACKAGE and (EQL 12) forms are both parallel type + ;; names, they're not, as is made clear when you do + ;; (DEFMETHOD FOO ((X PACKAGE) + ;; (Y (EQL 'BAR))) + ;; ..) + ;; where Y needs to be a symbol named "BAR", not some cons + ;; made by (CONS 'QUOTE 'BAR). I.e. when the + ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument + ;; to be of type (EQL X). It'd be easy to transform one to + ;; the other, but it'd be somewhat messier to do so while + ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd + ;; once. (The new code wouldn't be messy, but it'd require a + ;; big transformation of the old code.) So instead we punt. + ;; -- WHN 20000610 + '(ignorable)) + ((member specializer + ;; KLUDGE: For some low-level implementation + ;; classes, perhaps because of some problems related + ;; to the incomplete integration of PCL into SBCL's + ;; type system, some specializer classes can't be + ;; declared as argument types. E.g. + ;; (DEFMETHOD FOO ((X SLOT-OBJECT)) + ;; (DECLARE (TYPE SLOT-OBJECT X)) + ;; ..) + ;; loses when + ;; (DEFSTRUCT BAR A B) + ;; (FOO (MAKE-BAR)) + ;; perhaps because of the way that STRUCTURE-OBJECT + ;; inherits both from SLOT-OBJECT and from + ;; SB-KERNEL:INSTANCE. In an effort to sweep such + ;; problems under the rug, we exclude these problem + ;; cases by blacklisting them here. -- WHN 2001-01-19 + (list 'slot-object #+nil (find-class 'slot-object))) + '(ignorable)) + ((not (eq **boot-state** 'complete)) + ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with + ;; types which don't match their specializers. (Specifically, + ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL + ;; second argument.) Hopefully it only does this kind of + ;; weirdness when bootstrapping.. -- WHN 20000610 + '(ignorable)) + ((typep specializer 'eql-specializer) + `(type (eql ,(eql-specializer-object specializer)) ,parameter)) + ((or (var-special-p parameter env) (member parameter specials)) + ;; Don't declare types for special variables -- our rebinding magic + ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE), + ;; etc. make things undecidable. + '(ignorable)) + (t + ;; Otherwise, we can usually make Python very happy. + ;; + ;; KLUDGE: Since INFO doesn't work right for class objects here, + ;; and they are valid specializers, see if the specializer is + ;; a named class, and use the name in that case -- otherwise + ;; the class instance is ok, since info will just return NIL, NIL. + ;; + ;; We still need to deal with the class case too, but at + ;; least #.(find-class 'integer) and integer as equivalent + ;; specializers with this. + (let* ((specializer-nameoid + (if (and (typep specializer 'class) + (let ((name (class-name specializer))) + (and name (symbolp name) + (eq specializer (find-class name nil))))) + (class-name specializer) + specializer)) + (kind (info :type :kind specializer-nameoid))) + + (flet ((specializer-nameoid-class () + (typecase specializer-nameoid + (symbol (find-class specializer-nameoid nil)) + (class specializer-nameoid) + (class-eq-specializer + (specializer-class specializer-nameoid)) + (t nil)))) + (ecase kind + ((:primitive) `(type ,specializer-nameoid ,parameter)) + ((:defined) + (let ((class (specializer-nameoid-class))) + ;; CLASS can be null here if the user has + ;; erroneously tried to use a defined type as a + ;; specializer; it can be a non-BUILT-IN-CLASS if + ;; the user defines a type and calls (SETF + ;; FIND-CLASS) in a consistent way. + (when (and class (typep class 'built-in-class)) + `(type ,(class-name class) ,parameter)))) + ((:instance nil) + (let ((class (specializer-nameoid-class))) + (cond + (class + (if (typep class '(or built-in-class structure-class)) + `(type ,class ,parameter) + ;; don't declare CLOS classes as parameters; + ;; it's too expensive. + '(ignorable))) + (t + ;; we can get here, and still not have a failure + ;; case, by doing MOP programming like (PROGN + ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) + ;; ...)). Best to let the user know we haven't + ;; been able to extract enough information: + (style-warn + "~@" + specializer-nameoid + 'parameter-specializer-declaration-in-defmethod) + '(ignorable))))) + ((:forthcoming-defclass-type) + '(ignorable)))))))) + +;;; For passing a list (groveled by the walker) of the required +;;; parameters whose bindings are modified in the method body to the +;;; optimized-slot-value* macros. +(define-symbol-macro %parameter-binding-modified ()) (defmacro simple-lexical-method-functions ((lambda-list - method-args - next-methods - &rest lmf-options) - &body body) + method-args + next-methods + &rest lmf-options) + &body body) `(progn ,method-args ,next-methods - (bind-simple-lexical-method-macros (,method-args ,next-methods) - (bind-lexical-method-functions (,@lmf-options) - (bind-args (,lambda-list ,method-args) - ,@body))))) + (bind-simple-lexical-method-functions (,method-args ,next-methods + ,lmf-options) + (bind-args (,lambda-list ,method-args) + ,@body)))) (defmacro fast-lexical-method-functions ((lambda-list - next-method-call - args - rest-arg - &rest lmf-options) - &body body) - `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) - (bind-lexical-method-functions (,@lmf-options) - (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) - ,@body)))) - -(defmacro bind-simple-lexical-method-macros ((method-args next-methods) - &body body) - `(macrolet ((call-next-method-bind (&body body) - `(let ((.next-method. (car ,',next-methods)) - (,',next-methods (cdr ,',next-methods))) - .next-method. ,',next-methods - ,@body)) - (call-next-method-body (method-name-declaration cnm-args) - `(if .next-method. - (funcall (if (std-instance-p .next-method.) - (method-function .next-method.) - .next-method.) ; for early methods - (or ,cnm-args ,',method-args) - ,',next-methods) - (apply #'call-no-next-method ',method-name-declaration - (or ,cnm-args ,',method-args)))) - (next-method-p-body () - `(not (null .next-method.))) - (with-rebound-original-args ((call-next-method-p setq-p) - &body body) - (declare (ignore call-next-method-p setq-p)) - `(let () ,@body))) - ,@body)) - -(defun call-no-next-method (method-name-declaration &rest args) - (destructuring-bind (name) method-name-declaration - (destructuring-bind (name &rest qualifiers-and-specializers) name - ;; KLUDGE: inefficient traversal, but hey. This should only - ;; happen on the slow error path anyway. - (let* ((qualifiers (butlast qualifiers-and-specializers)) - (specializers (car (last qualifiers-and-specializers))) - (method (find-method (gdefinition name) qualifiers specializers))) - (apply #'no-next-method - (method-generic-function method) - method - args))))) + next-method-call + args + rest-arg + &rest lmf-options) + &body body) + `(bind-fast-lexical-method-functions (,args ,rest-arg ,next-method-call ,lmf-options) + (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) + ,@body))) + +(defmacro bind-simple-lexical-method-functions + ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p + parameters-setqd closurep applyp method-cell)) + &body body + &environment env) + (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp)) + `(locally + ,@body) + `(let ((.next-method. (car ,next-methods)) + (,next-methods (cdr ,next-methods))) + (declare (ignorable .next-method. ,next-methods)) + (flet (,@(and call-next-method-p + `((call-next-method (&rest cnm-args) + (declare (dynamic-extent cnm-args)) + ,@(if (safe-code-p env) + `((%check-cnm-args cnm-args + ,method-args + ',method-cell)) + nil) + (if .next-method. + (funcall (if (std-instance-p .next-method.) + (method-function .next-method.) + .next-method.) ; for early methods + (or cnm-args ,method-args) + ,next-methods) + (apply #'call-no-next-method + ',method-cell + (or cnm-args ,method-args)))))) + ,@(and next-method-p-p + '((next-method-p () + (not (null .next-method.)))))) + ,@body)))) + +(defun call-no-next-method (method-cell &rest args) + (let ((method (car method-cell))) + (aver method) + ;; Can't easily provide a RETRY restart here, as the return value here is + ;; for the method, not the generic function. + (apply #'no-next-method (method-generic-function method) + method args))) + +(defun call-no-applicable-method (gf args) + (restart-case + (apply #'no-applicable-method gf args) + (retry () + :report "Retry calling the generic function." + (apply gf args)))) + +(defun call-no-primary-method (gf args) + (restart-case + (apply #'no-primary-method gf args) + (retry () + :report "Retry calling the generic function." + (apply gf args)))) (defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) +(defstruct (constant-method-call (:copier nil) (:include method-call)) + value) #-sb-fluid (declaim (sb-ext:freeze-type method-call)) (defmacro invoke-method-call1 (function args cm-args) `(let ((.function. ,function) - (.args. ,args) - (.cm-args. ,cm-args)) + (.args. ,args) + (.cm-args. ,cm-args)) (if (and .cm-args. (null (cdr .cm-args.))) - (funcall .function. .args. (car .cm-args.)) - (apply .function. .args. .cm-args.)))) + (funcall .function. .args. (car .cm-args.)) + (apply .function. .args. .cm-args.)))) (defmacro invoke-method-call (method-call restp &rest required-args+rest-arg) `(invoke-method-call1 (method-call-function ,method-call) - ,(if restp - `(list* ,@required-args+rest-arg) - `(list ,@required-args+rest-arg)) - (method-call-call-method-args ,method-call))) + ,(if restp + `(list* ,@required-args+rest-arg) + `(list ,@required-args+rest-arg)) + (method-call-call-method-args ,method-call))) (defstruct (fast-method-call (:copier nil)) (function #'identity :type function) - pv-cell + pv next-method-call arg-info) +(defstruct (constant-fast-method-call + (:copier nil) (:include fast-method-call)) + value) #-sb-fluid (declaim (sb-ext:freeze-type fast-method-call)) -(defmacro fmc-funcall (fn pv-cell next-method-call &rest args) - `(funcall ,fn ,pv-cell ,next-method-call ,@args)) - -(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg) - `(fmc-funcall (fast-method-call-function ,method-call) - (fast-method-call-pv-cell ,method-call) - (fast-method-call-next-method-call ,method-call) - ,@required-args+rest-arg)) +;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs +;; are handled. The first one will get REST-ARG as a single list (as +;; the last argument), and will thus need to use APPLY. The second one +;; will get them as a &MORE argument, so we can pass the arguments +;; directly with MULTIPLE-VALUE-CALL and %MORE-ARG-VALUES. + +(defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg) + `(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call) + (fast-method-call-pv ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args+rest-arg)) + +(defmacro invoke-fast-method-call/more (method-call + more-context + more-count + &rest required-args) + (macrolet ((generate-call (n) + ``(funcall (fast-method-call-function ,method-call) + (fast-method-call-pv ,method-call) + (fast-method-call-next-method-call ,method-call) + ,@required-args + ,@(loop for x below ,n + collect `(sb-c::%more-arg ,more-context ,x))))) + ;; The cases with only small amounts of required arguments passed + ;; are probably very common, and special-casing speeds them up by + ;; a factor of 2 with very little effect on the other + ;; cases. Though it'd be nice to have the generic case be equally + ;; fast. + `(case ,more-count + (0 ,(generate-call 0)) + (1 ,(generate-call 1)) + (t (multiple-value-call (fast-method-call-function ,method-call) + (values (fast-method-call-pv ,method-call)) + (values (fast-method-call-next-method-call ,method-call)) + ,@required-args + (sb-c::%more-arg-values ,more-context 0 ,more-count)))))) (defstruct (fast-instance-boundp (:copier nil)) (index 0 :type fixnum)) @@ -918,20 +1111,20 @@ bootstrapping. (defun show-emf-call-trace () (when *emf-call-trace* (let ((j *emf-call-trace-index*) - (*enable-emf-call-tracing-p* nil)) + (*enable-emf-call-tracing-p* nil)) (format t "~&(The oldest entries are printed first)~%") (dotimes-fixnum (i *emf-call-trace-size*) - (let ((ct (aref *emf-call-trace* j))) - (when ct (print ct))) - (incf j) - (when (= j *emf-call-trace-size*) - (setq j 0)))))) + (let ((ct (aref *emf-call-trace* j))) + (when ct (print ct))) + (incf j) + (when (= j *emf-call-trace-size*) + (setq j 0)))))) (defun trace-emf-call-internal (emf format args) (unless *emf-call-trace* (setq *emf-call-trace* (make-array *emf-call-trace-size*))) (setf (aref *emf-call-trace* *emf-call-trace-index*) - (list* emf format args)) + (list* emf format args)) (incf *emf-call-trace-index*) (when (= *emf-call-trace-index* *emf-call-trace-size*) (setq *emf-call-trace-index* 0))) @@ -942,680 +1135,679 @@ bootstrapping. (trace-emf-call-internal ,emf ,format ,args)))) (defmacro invoke-effective-method-function-fast - (emf restp &rest required-args+rest-arg) + (emf restp &key required-args rest-arg more-arg) `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (invoke-fast-method-call ,emf ,@required-args+rest-arg))) - -(defmacro invoke-effective-method-function (emf restp - &rest required-args+rest-arg) - (unless (constantp restp) - (error "The RESTP argument is not constant.")) - ;; FIXME: The RESTP handling here is confusing and maybe slightly - ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if - ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...) - ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error. - (setq restp (eval restp)) - `(progn - (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) - (cond ((typep ,emf 'fast-method-call) - (invoke-fast-method-call ,emf ,@required-args+rest-arg)) - ;; "What," you may wonder, "do these next two clauses do?" - ;; In that case, you are not a PCL implementor, for they - ;; considered this to be self-documenting.:-| Or CSR, for - ;; that matter, since he can also figure it out by looking - ;; at it without breaking stride. For the rest of us, - ;; though: From what the code is doing with .SLOTS. and - ;; whatnot, evidently it's implementing SLOT-VALUEish and - ;; GET-SLOT-VALUEish things. Then we can reason backwards - ;; and conclude that setting EMF to a FIXNUM is an - ;; optimized way to represent these slot access operations. - ,@(when (and (null restp) (= 1 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let* ((.slots. (get-slots-or-nil - ,(car required-args+rest-arg))) - (value (when .slots. (clos-slots-ref .slots. ,emf)))) - (if (eq value +slot-unbound+) - (slot-unbound-internal ,(car required-args+rest-arg) - ,emf) - value))))) - ,@(when (and (null restp) (= 2 (length required-args+rest-arg))) - `(((typep ,emf 'fixnum) - (let ((.new-value. ,(car required-args+rest-arg)) - (.slots. (get-slots-or-nil - ,(cadr required-args+rest-arg)))) - (when .slots. - (setf (clos-slots-ref .slots. ,emf) .new-value.)))))) - ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN - ;; ...) clause here to handle SLOT-BOUNDish stuff. Since - ;; there was no explanation and presumably the code is 10+ - ;; years stale, I simply deleted it. -- WHN) - (t - (etypecase ,emf - (method-call - (invoke-method-call ,emf ,restp ,@required-args+rest-arg)) - (function - ,(if restp - `(apply (the function ,emf) ,@required-args+rest-arg) - `(funcall (the function ,emf) - ,@required-args+rest-arg)))))))) + (trace-emf-call ,emf ,restp (list ,@required-args rest-arg)) + ,(if more-arg + `(invoke-fast-method-call/more ,emf + ,@more-arg + ,@required-args) + `(invoke-fast-method-call ,emf + ,restp + ,@required-args + ,@rest-arg)))) + +(defun effective-method-optimized-slot-access-clause + (emf restp required-args) + ;; "What," you may wonder, "do these next two clauses do?" In that + ;; case, you are not a PCL implementor, for they considered this to + ;; be self-documenting.:-| Or CSR, for that matter, since he can + ;; also figure it out by looking at it without breaking stride. For + ;; the rest of us, though: From what the code is doing with .SLOTS. + ;; and whatnot, evidently it's implementing SLOT-VALUEish and + ;; GET-SLOT-VALUEish things. Then we can reason backwards and + ;; conclude that setting EMF to a FIXNUM is an optimized way to + ;; represent these slot access operations. + (when (not restp) + (let ((length (length required-args))) + (cond ((= 1 length) + `((fixnum + (let* ((.slots. (get-slots-or-nil + ,(car required-args))) + (value (when .slots. (clos-slots-ref .slots. ,emf)))) + (if (eq value +slot-unbound+) + (slot-unbound-internal ,(car required-args) + ,emf) + value))))) + ((= 2 length) + `((fixnum + (let ((.new-value. ,(car required-args)) + (.slots. (get-slots-or-nil + ,(cadr required-args)))) + (when .slots. + (setf (clos-slots-ref .slots. ,emf) .new-value.))))))) + ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN + ;; ...) clause here to handle SLOT-BOUNDish stuff. Since + ;; there was no explanation and presumably the code is 10+ + ;; years stale, I simply deleted it. -- WHN) + ))) + +;;; Before SBCL 0.9.16.7 instead of +;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR +;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now, +;;; to make less work for the compiler we take a path that doesn't +;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all. +(macrolet ((def (name &optional narrow) + `(defmacro ,name (emf restp &key required-args rest-arg more-arg) + (unless (constantp restp) + (error "The RESTP argument is not constant.")) + (setq restp (constant-form-value restp)) + (with-unique-names (emf-n) + `(locally + (declare (optimize (sb-c:insert-step-conditions 0))) + (let ((,emf-n ,emf)) + (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg)) + (etypecase ,emf-n + (fast-method-call + ,(if more-arg + `(invoke-fast-method-call/more ,emf-n + ,@more-arg + ,@required-args) + `(invoke-fast-method-call ,emf-n + ,restp + ,@required-args + ,@rest-arg))) + ,@,(unless narrow + `(effective-method-optimized-slot-access-clause + emf-n restp required-args)) + (method-call + (invoke-method-call ,emf-n ,restp ,@required-args + ,@rest-arg)) + (function + ,(if restp + `(apply ,emf-n ,@required-args ,@rest-arg) + `(funcall ,emf-n ,@required-args + ,@rest-arg)))))))))) + (def invoke-effective-method-function nil) + (def invoke-narrow-effective-method-function t)) (defun invoke-emf (emf args) (trace-emf-call emf t args) (etypecase emf (fast-method-call (let* ((arg-info (fast-method-call-arg-info emf)) - (restp (cdr arg-info)) - (nreq (car arg-info))) + (restp (cdr arg-info)) + (nreq (car arg-info))) (if restp - (let* ((rest-args (nthcdr nreq args)) - (req-args (ldiff args rest-args))) - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - (nconc req-args (list rest-args)))) - (cond ((null args) - (if (eql nreq 0) - (invoke-fast-method-call emf) - (error "wrong number of args"))) - ((null (cdr args)) - (if (eql nreq 1) - (invoke-fast-method-call emf (car args)) - (error "wrong number of args"))) - ((null (cddr args)) - (if (eql nreq 2) - (invoke-fast-method-call emf (car args) (cadr args)) - (error "wrong number of args"))) - (t - (apply (fast-method-call-function emf) - (fast-method-call-pv-cell emf) - (fast-method-call-next-method-call emf) - args)))))) + (apply (fast-method-call-function emf) + (fast-method-call-pv emf) + (fast-method-call-next-method-call emf) + args) + (cond ((null args) + (if (eql nreq 0) + (invoke-fast-method-call emf nil) + (error 'simple-program-error + :format-control "invalid number of arguments: 0" + :format-arguments nil))) + ((null (cdr args)) + (if (eql nreq 1) + (invoke-fast-method-call emf nil (car args)) + (error 'simple-program-error + :format-control "invalid number of arguments: 1" + :format-arguments nil))) + ((null (cddr args)) + (if (eql nreq 2) + (invoke-fast-method-call emf nil (car args) (cadr args)) + (error 'simple-program-error + :format-control "invalid number of arguments: 2" + :format-arguments nil))) + (t + (apply (fast-method-call-function emf) + (fast-method-call-pv emf) + (fast-method-call-next-method-call emf) + args)))))) (method-call (apply (method-call-function emf) - args - (method-call-call-method-args emf))) + args + (method-call-call-method-args emf))) (fixnum - (cond ((null args) (error "1 or 2 args were expected.")) - ((null (cdr args)) - (let* ((slots (get-slots (car args))) + (cond ((null args) + (error 'simple-program-error + :format-control "invalid number of arguments: 0" + :format-arguments nil)) + ((null (cdr args)) + (let* ((slots (get-slots (car args))) (value (clos-slots-ref slots emf))) - (if (eq value +slot-unbound+) - (slot-unbound-internal (car args) emf) - value))) - ((null (cddr args)) - (setf (clos-slots-ref (get-slots (cadr args)) emf) - (car args))) - (t (error "1 or 2 args were expected.")))) + (if (eq value +slot-unbound+) + (slot-unbound-internal (car args) emf) + value))) + ((null (cddr args)) + (setf (clos-slots-ref (get-slots (cadr args)) emf) + (car args))) + (t (error 'simple-program-error + :format-control "invalid number of arguments" + :format-arguments nil)))) (fast-instance-boundp (if (or (null args) (cdr args)) - (error "1 arg was expected.") - (let ((slots (get-slots (car args)))) - (not (eq (clos-slots-ref slots - (fast-instance-boundp-index emf)) - +slot-unbound+))))) + (error 'simple-program-error + :format-control "invalid number of arguments" + :format-arguments nil) + (let ((slots (get-slots (car args)))) + (not (eq (clos-slots-ref slots (fast-instance-boundp-index emf)) + +slot-unbound+))))) (function (apply emf args)))) -(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) - &body body) - (let* ((all-params (append args (when rest-arg (list rest-arg)))) - (rebindings (mapcar (lambda (x) (list x x)) all-params))) - `(macrolet ((narrowed-emf (emf) - ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to - ;; dispatch on the possibility that EMF might be of - ;; type FIXNUM (as an optimized representation of a - ;; slot accessor). But as far as I (WHN 2002-06-11) - ;; can tell, it's impossible for such a representation - ;; to end up as .NEXT-METHOD-CALL. By reassuring - ;; INVOKE-E-M-F that when called from this context - ;; it needn't worry about the FIXNUM case, we can - ;; keep those cases from being compiled, which is - ;; good both because it saves bytes and because it - ;; avoids annoying type mismatch compiler warnings. - ;; - ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type - ;; system isn't smart enough about NOT and - ;; intersection types to benefit from a (NOT FIXNUM) - ;; declaration here. -- WHN 2002-06-12 (FIXME: maybe - ;; it is now... -- CSR, 2003-06-07) - ;; - ;; FIXME: Might the FUNCTION type be omittable here, - ;; leaving only METHOD-CALLs? Failing that, could this - ;; be documented somehow? (It'd be nice if the types - ;; involved could be understood without solving the - ;; halting problem.) - `(the (or function method-call fast-method-call) - ,emf)) - (call-next-method-bind (&body body) - `(let () ,@body)) - (call-next-method-body (method-name-declaration cnm-args) - `(if ,',next-method-call - ,(locally - ;; This declaration suppresses a "deleting - ;; unreachable code" note for the following IF - ;; when REST-ARG is NIL. It is not nice for - ;; debugging SBCL itself, but at least it - ;; keeps us from annoying users. - (declare (optimize (inhibit-warnings 3))) - (if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(invoke-effective-method-function - (narrowed-emf ,',next-method-call) - nil - ,@(cdr cnm-args)) - (let ((call `(invoke-effective-method-function - (narrowed-emf ,',next-method-call) - ,',(not (null rest-arg)) - ,@',args - ,@',(when rest-arg `(,rest-arg))))) - `(if ,cnm-args - (bind-args ((,@',args - ,@',(when rest-arg - `(&rest ,rest-arg))) - ,cnm-args) - ,call) - ,call)))) - ,(locally - ;; As above, this declaration suppresses code - ;; deletion notes. - (declare (optimize (inhibit-warnings 3))) - (if (and (null ',rest-arg) - (consp cnm-args) - (eq (car cnm-args) 'list)) - `(call-no-next-method ',method-name-declaration - ,@(cdr cnm-args)) - `(call-no-next-method ',method-name-declaration - ,@',args - ,@',(when rest-arg - `(,rest-arg))))))) - (next-method-p-body () - `(not (null ,',next-method-call))) - (with-rebound-original-args ((cnm-p setq-p) &body body) - (if (or cnm-p setq-p) - `(let ,',rebindings - (declare (ignorable ,@',all-params)) - ,@body) - `(let () ,@body)))) - ,@body))) - -(defmacro bind-lexical-method-functions - ((&key call-next-method-p next-method-p-p setq-p - closurep applyp method-name-declaration) - &body body) - (cond ((and (null call-next-method-p) (null next-method-p-p) - (null closurep) (null applyp) (null setq-p)) - `(let () ,@body)) - (t - `(call-next-method-bind - (flet (,@(and call-next-method-p - `((call-next-method (&rest cnm-args) - (call-next-method-body - ,method-name-declaration - cnm-args)))) - ,@(and next-method-p-p - '((next-method-p () - (next-method-p-body))))) - (with-rebound-original-args (,call-next-method-p ,setq-p) - ,@body)))))) + +(defmacro fast-call-next-method-body ((args next-method-call rest-arg) + method-cell + cnm-args) + `(if ,next-method-call + ,(let ((call `(invoke-narrow-effective-method-function + ,next-method-call + ,(not (null rest-arg)) + :required-args ,args + :rest-arg ,(when rest-arg (list rest-arg))))) + `(if ,cnm-args + (bind-args ((,@args + ,@(when rest-arg + `(&rest ,rest-arg))) + ,cnm-args) + ,call) + ,call)) + (call-no-next-method ',method-cell + ,@args + ,@(when rest-arg + `(,rest-arg))))) + +(defmacro bind-fast-lexical-method-functions + ((args rest-arg next-method-call (&key + call-next-method-p + setq-p + parameters-setqd + method-cell + next-method-p-p + closurep + applyp)) + &body body + &environment env) + (let* ((rebindings (when (or setq-p call-next-method-p) + (mapcar (lambda (x) (list x x)) parameters-setqd)))) + (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp)) + `(locally + ,@body) + `(flet (,@(when call-next-method-p + `((call-next-method (&rest cnm-args) + (declare (dynamic-extent cnm-args) + (muffle-conditions code-deletion-note) + (optimize (sb-c:insert-step-conditions 0))) + ,@(if (safe-code-p env) + `((%check-cnm-args cnm-args (list ,@args) + ',method-cell)) + nil) + (fast-call-next-method-body (,args + ,next-method-call + ,rest-arg) + ,method-cell + cnm-args)))) + ,@(when next-method-p-p + `((next-method-p () + (declare (optimize (sb-c:insert-step-conditions 0))) + (not (null ,next-method-call)))))) + (let ,rebindings + ,@body))))) + +;;; CMUCL comment (Gerd Moellmann): +;;; +;;; The standard says it's an error if CALL-NEXT-METHOD is called with +;;; arguments, and the set of methods applicable to those arguments is +;;; different from the set of methods applicable to the original +;;; method arguments. (According to Barry Margolin, this rule was +;;; probably added to ensure that before and around methods are always +;;; run before primary methods.) +;;; +;;; This could be optimized for the case that the generic function +;;; doesn't have hairy methods, does have standard method combination, +;;; is a standard generic function, there are no methods defined on it +;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such +;;; preconditions. That looks hairy and is probably not worth it, +;;; because this check will never be fast. +(defun %check-cnm-args (cnm-args orig-args method-cell) + ;; 1. Check for no arguments. + (when cnm-args + (let* ((gf (method-generic-function (car method-cell))) + (nreq (generic-function-nreq gf))) + (declare (fixnum nreq)) + ;; 2. Requirement arguments pairwise: if all are EQL, the applicable + ;; methods must be the same. This takes care of the relatively common + ;; case of twiddling with &KEY arguments without being horribly + ;; expensive. + (unless (do ((orig orig-args (cdr orig)) + (args cnm-args (cdr args)) + (n nreq (1- nreq))) + ((zerop n) t) + (unless (and orig args (eql (car orig) (car args))) + (return nil))) + ;; 3. Only then do the full check. + (let ((omethods (compute-applicable-methods gf orig-args)) + (nmethods (compute-applicable-methods gf cnm-args))) + (unless (equal omethods nmethods) + (error "~@" + nmethods (length cnm-args) cnm-args omethods + (length orig-args) orig-args))))))) (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) - (key '.key.) - (state 'required)) + (key '.key.) + (state 'required)) (flet ((process-var (var) - (if (memq var lambda-list-keywords) - (progn - (case var - (&optional (setq state 'optional)) - (&key (setq state 'key)) - (&allow-other-keys) - (&rest (setq state 'rest)) - (&aux (setq state 'aux)) - (otherwise - (error - "encountered the non-standard lambda list keyword ~S" - var))) - nil) - (case state - (required `((,var (pop ,args-tail)))) - (optional (cond ((not (consp var)) - `((,var (when ,args-tail - (pop ,args-tail))))) - ((null (cddr var)) - `((,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))) - (t - `((,(caddr var) ,args-tail) - (,(car var) (if ,args-tail - (pop ,args-tail) - ,(cadr var))))))) - (rest `((,var ,args-tail))) - (key (cond ((not (consp var)) - `((,var (car - (get-key-arg-tail ,(keywordicate var) - ,args-tail))))) - ((null (cddr var)) - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) - (cadar var)) - (values (keywordicate (car var)) - (car var))) - `((,key (get-key-arg-tail ',keyword - ,args-tail)) - (,variable (if ,key - (car ,key) - ,(cadr var)))))) - (t - (multiple-value-bind (keyword variable) - (if (consp (car var)) - (values (caar var) - (cadar var)) - (values (keywordicate (car var)) - (car var))) - `((,key (get-key-arg-tail ',keyword - ,args-tail)) - (,(caddr var) ,key) - (,variable (if ,key - (car ,key) - ,(cadr var)))))))) - (aux `(,var)))))) + (if (memq var lambda-list-keywords) + (progn + (case var + (&optional (setq state 'optional)) + (&key (setq state 'key)) + (&allow-other-keys) + (&rest (setq state 'rest)) + (&aux (setq state 'aux)) + (otherwise + (error + "encountered the non-standard lambda list keyword ~S" + var))) + nil) + (case state + (required `((,var (pop ,args-tail)))) + (optional (cond ((not (consp var)) + `((,var (when ,args-tail + (pop ,args-tail))))) + ((null (cddr var)) + `((,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))) + (t + `((,(caddr var) (not (null ,args-tail))) + (,(car var) (if ,args-tail + (pop ,args-tail) + ,(cadr var))))))) + (rest `((,var ,args-tail))) + (key (cond ((not (consp var)) + `((,var (car + (get-key-arg-tail ,(keywordicate var) + ,args-tail))))) + ((null (cddr var)) + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) + (cadar var)) + (values (keywordicate (car var)) + (car var))) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) + (,variable (if ,key + (car ,key) + ,(cadr var)))))) + (t + (multiple-value-bind (keyword variable) + (if (consp (car var)) + (values (caar var) + (cadar var)) + (values (keywordicate (car var)) + (car var))) + `((,key (get-key-arg-tail ',keyword + ,args-tail)) + (,(caddr var) (not (null,key))) + (,variable (if ,key + (car ,key) + ,(cadr var)))))))) + (aux `(,var)))))) (let ((bindings (mapcan #'process-var lambda-list))) - `(let* ((,args-tail ,args) - ,@bindings - (.dummy0. - ,@(when (eq state 'optional) - `((unless (null ,args-tail) - (error 'simple-program-error - :format-control "surplus arguments: ~S" - :format-arguments (list ,args-tail))))))) - (declare (ignorable ,args-tail .dummy0.)) - ,@body))))) + `(let* ((,args-tail ,args) + ,@bindings + (.dummy0. + ,@(when (eq state 'optional) + `((unless (null ,args-tail) + (error 'simple-program-error + :format-control "surplus arguments: ~S" + :format-arguments (list ,args-tail))))))) + (declare (ignorable ,args-tail .dummy0.)) + ,@body))))) (defun get-key-arg-tail (keyword list) (loop for (key . tail) on list by #'cddr - when (null tail) do - ;; FIXME: Do we want to export this symbol? Or maybe use an - ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form? - (sb-c::%odd-key-args-error) - when (eq key keyword) - return tail)) - -(defun walk-method-lambda (method-lambda required-parameters env slots calls) - (let ((call-next-method-p nil) ; flag indicating that CALL-NEXT-METHOD - ; should be in the method definition - (closurep nil) ; flag indicating that #'CALL-NEXT-METHOD - ; was seen in the body of a method - (next-method-p-p nil) ; flag indicating that NEXT-METHOD-P - ; should be in the method definition - (setq-p nil)) + when (null tail) do + ;; FIXME: Do we want to export this symbol? Or maybe use an + ;; (ERROR 'SIMPLE-PROGRAM-ERROR) form? + (sb-c::%odd-key-args-error) + when (eq key keyword) + return tail)) + +(defun walk-method-lambda (method-lambda required-parameters env slots) + (let (;; flag indicating that CALL-NEXT-METHOD should be in the + ;; method definition + (call-next-method-p nil) + ;; flag indicating that #'CALL-NEXT-METHOD was seen in the + ;; body of a method + (closurep nil) + ;; flag indicating that NEXT-METHOD-P should be in the method + ;; definition + (next-method-p-p nil) + ;; a list of all required parameters whose bindings might be + ;; modified in the method body. + (parameters-setqd nil)) (flet ((walk-function (form context env) - (cond ((not (eq context :eval)) form) - ;; FIXME: Jumping to a conclusion from the way it's used - ;; above, perhaps CONTEXT should be called SITUATION - ;; (after the term used in the ANSI specification of - ;; EVAL-WHEN) and given modern ANSI keyword values - ;; like :LOAD-TOPLEVEL. - ((not (listp form)) form) - ((eq (car form) 'call-next-method) - (setq call-next-method-p t) - form) - ((eq (car form) 'next-method-p) - (setq next-method-p-p t) - form) - ((eq (car form) 'setq) - ;; FIXME: this is possibly a little strong as - ;; conditions go. Ideally we would want to detect - ;; which, if any, of the method parameters are - ;; being set, and communicate that information to - ;; e.g. SPLIT-DECLARATIONS. However, the brute - ;; force method doesn't really cost much; a little - ;; loss of discrimination over IGNORED variables - ;; should be all. -- CSR, 2004-07-01 - (setq setq-p t) - form) - ((and (eq (car form) 'function) - (cond ((eq (cadr form) 'call-next-method) - (setq call-next-method-p t) - (setq closurep t) - form) - ((eq (cadr form) 'next-method-p) - (setq next-method-p-p t) - (setq closurep t) - form) - (t nil)))) - ((and (memq (car form) + (cond ((not (eq context :eval)) form) + ;; FIXME: Jumping to a conclusion from the way it's used + ;; above, perhaps CONTEXT should be called SITUATION + ;; (after the term used in the ANSI specification of + ;; EVAL-WHEN) and given modern ANSI keyword values + ;; like :LOAD-TOPLEVEL. + ((not (listp form)) form) + ((eq (car form) 'call-next-method) + (setq call-next-method-p (if (cdr form) + t + :simple)) + form) + ((eq (car form) 'next-method-p) + (setq next-method-p-p t) + form) + ((memq (car form) '(setq multiple-value-setq)) + ;; The walker will split (SETQ A 1 B 2) to + ;; separate (SETQ A 1) and (SETQ B 2) forms, so we + ;; only need to handle the simple case of SETQ + ;; here. + (let ((vars (if (eq (car form) 'setq) + (list (second form)) + (second form)))) + (dolist (var vars) + ;; Note that we don't need to check for + ;; %VARIABLE-REBINDING declarations like is + ;; done in CAN-OPTIMIZE-ACCESS1, since the + ;; bindings that will have that declation will + ;; never be SETQd. + (when (var-declaration '%class var env) + ;; If a parameter binding is shadowed by + ;; another binding it won't have a %CLASS + ;; declaration anymore, and this won't get + ;; executed. + (pushnew var parameters-setqd :test #'eq)))) + form) + ((and (eq (car form) 'function) + (cond ((eq (cadr form) 'call-next-method) + (setq call-next-method-p t) + (setq closurep t) + form) + ((eq (cadr form) 'next-method-p) + (setq next-method-p-p t) + (setq closurep t) + form) + (t nil)))) + ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) - (constantp (caddr form))) - (let ((parameter (can-optimize-access form - required-parameters - env))) - (let ((fun (ecase (car form) - (slot-value #'optimize-slot-value) - (set-slot-value #'optimize-set-slot-value) - (slot-boundp #'optimize-slot-boundp)))) - (funcall fun slots parameter form)))) - ((and (eq (car form) 'apply) - (consp (cadr form)) - (eq (car (cadr form)) 'function) - (generic-function-name-p (cadr (cadr form)))) - (optimize-generic-function-call - form required-parameters env slots calls)) - ((generic-function-name-p (car form)) - (optimize-generic-function-call - form required-parameters env slots calls)) - (t form)))) + (constantp (caddr form) env)) + (let ((fun (ecase (car form) + (slot-value #'optimize-slot-value) + (set-slot-value #'optimize-set-slot-value) + (slot-boundp #'optimize-slot-boundp)))) + (funcall fun form slots required-parameters env))) + (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) - (values walked-lambda - call-next-method-p - closurep - next-method-p-p - setq-p))))) + ;;; FIXME: the walker's rewriting of the source code causes + ;;; trouble when doing code coverage. The rewrites should be + ;;; removed, and the same operations done using + ;;; compiler-macros or tranforms. + (values (if (sb-c:policy env (= sb-c:store-coverage-data 0)) + walked-lambda + method-lambda) + call-next-method-p + closurep + next-method-p-p + (not (null parameters-setqd)) + parameters-setqd))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) - (gboundp name) - (if (eq *boot-state* 'complete) - (standard-generic-function-p (gdefinition name)) - (funcallable-instance-p (gdefinition name))))) + (fboundp name) + (if (eq **boot-state** 'complete) + (standard-generic-function-p (gdefinition name)) + (funcallable-instance-p (gdefinition name))))) -(defvar *method-function-plist* (make-hash-table :test 'eq)) -(defvar *mf1* nil) -(defvar *mf1p* nil) -(defvar *mf1cp* nil) -(defvar *mf2* nil) -(defvar *mf2p* nil) -(defvar *mf2cp* nil) - -(defun method-function-plist (method-function) - (unless (eq method-function *mf1*) - (rotatef *mf1* *mf2*) - (rotatef *mf1p* *mf2p*) - (rotatef *mf1cp* *mf2cp*)) - (unless (or (eq method-function *mf1*) (null *mf1cp*)) - (setf (gethash *mf1* *method-function-plist*) *mf1p*)) - (unless (eq method-function *mf1*) - (setf *mf1* method-function - *mf1cp* nil - *mf1p* (gethash method-function *method-function-plist*))) - *mf1p*) - -(defun (setf method-function-plist) - (val method-function) - (unless (eq method-function *mf1*) - (rotatef *mf1* *mf2*) - (rotatef *mf1cp* *mf2cp*) - (rotatef *mf1p* *mf2p*)) - (unless (or (eq method-function *mf1*) (null *mf1cp*)) - (setf (gethash *mf1* *method-function-plist*) *mf1p*)) - (setf *mf1* method-function - *mf1cp* t - *mf1p* val)) - -(defun method-function-get (method-function key &optional default) - (getf (method-function-plist method-function) key default)) - -(defun (setf method-function-get) - (val method-function key) - (setf (getf (method-function-plist method-function) key) val)) - -(defun method-function-pv-table (method-function) - (method-function-get method-function :pv-table)) - -(defun method-function-method (method-function) - (method-function-get method-function :method)) - -(defun method-function-needs-next-methods-p (method-function) - (method-function-get method-function :needs-next-methods-p t)) +(defun method-plist-value (method key &optional default) + (let ((plist (if (consp method) + (getf (early-method-initargs method) 'plist) + (object-plist method)))) + (getf plist key default))) + +(defun (setf method-plist-value) (new-value method key &optional default) + (if (consp method) + (setf (getf (getf (early-method-initargs method) 'plist) key default) + new-value) + (setf (getf (object-plist method) key default) new-value))) -(defmacro method-function-closure-generator (method-function) - `(method-function-get ,method-function 'closure-generator)) - -(defun load-defmethod - (class name quals specls ll initargs &optional pv-table-symbol) - (setq initargs (copy-tree initargs)) - (let ((method-spec (or (getf initargs :method-spec) - (make-method-spec name quals specls)))) - (setf (getf initargs :method-spec) method-spec) +(defun load-defmethod (class name quals specls ll initargs source-location) + (let ((method-cell (getf initargs 'method-cell))) + (setq initargs (copy-tree initargs)) + (when method-cell + (setf (getf initargs 'method-cell) method-cell)) + #+nil + (setf (getf (getf initargs 'plist) :name) + (make-method-spec name quals specls)) (load-defmethod-internal class name quals specls - ll initargs pv-table-symbol))) + ll initargs source-location))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list - initargs pv-table-symbol) - (when pv-table-symbol - (setf (getf (getf initargs :plist) :pv-table-symbol) - pv-table-symbol)) - (when (and (eq *boot-state* 'complete) - (fboundp gf-spec)) + initargs source-location) + (when (and (eq **boot-state** 'complete) + (fboundp gf-spec)) (let* ((gf (fdefinition gf-spec)) - (method (and (generic-function-p gf) + (method (and (generic-function-p gf) (generic-function-methods gf) - (find-method gf - qualifiers - (parse-specializers specializers) - nil)))) + (find-method gf qualifiers specializers nil)))) (when method - (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" - gf-spec qualifiers specializers)))) + (warn 'sb-kernel:redefinition-with-defmethod + :name gf-spec + :new-location source-location + :old-method method + :qualifiers qualifiers :specializers specializers)))) (let ((method (apply #'add-named-method - gf-spec qualifiers specializers lambda-list - :definition-source `((defmethod ,gf-spec - ,@qualifiers - ,specializers) - ,*load-pathname*) - initargs))) + gf-spec qualifiers specializers lambda-list + :definition-source source-location + initargs))) (unless (or (eq method-class 'standard-method) - (eq (find-class method-class nil) (class-of method))) + (eq (find-class method-class nil) (class-of method))) ;; FIXME: should be STYLE-WARNING? (format *error-output* - "~&At the time the method with qualifiers ~:S and~%~ - specializers ~:S on the generic function ~S~%~ - was compiled, the method-class for that generic function was~%~ - ~S. But, the method class is now ~S, this~%~ - may mean that this method was compiled improperly.~%" - qualifiers specializers gf-spec - method-class (class-name (class-of method)))) + "~&At the time the method with qualifiers ~:S and~%~ + specializers ~:S on the generic function ~S~%~ + was compiled, the method-class for that generic function was~%~ + ~S. But, the method class is now ~S, this~%~ + may mean that this method was compiled improperly.~%" + qualifiers specializers gf-spec + method-class (class-name (class-of method)))) method)) -(defun make-method-spec (gf-spec qualifiers unparsed-specializers) - `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers)) +(defun make-method-spec (gf qualifiers specializers) + (let ((name (generic-function-name gf)) + (unparsed-specializers (unparse-specializers gf specializers))) + `(slow-method ,name ,@qualifiers ,unparsed-specializers))) -(defun initialize-method-function (initargs &optional return-function-p method) +(defun initialize-method-function (initargs method) (let* ((mf (getf initargs :function)) - (method-spec (getf initargs :method-spec)) - (plist (getf initargs :plist)) - (pv-table-symbol (getf plist :pv-table-symbol)) - (pv-table nil) - (mff (getf initargs :fast-function))) - (flet ((set-mf-property (p v) - (when mf - (setf (method-function-get mf p) v)) - (when mff - (setf (method-function-get mff p) v)))) - (when method-spec - (when mf - (setq mf (set-fun-name mf method-spec))) - (when mff - (let ((name `(fast-method ,@(cdr method-spec)))) - (set-fun-name mff name) - (unless mf - (set-mf-property :name name))))) - (when plist - (let ((snl (getf plist :slot-name-lists)) - (cl (getf plist :call-list))) - (when (or snl cl) - (setq pv-table (intern-pv-table :slot-name-lists snl - :call-list cl)) - (when pv-table (set pv-table-symbol pv-table)) - (set-mf-property :pv-table pv-table))) - (loop (when (null plist) (return nil)) - (set-mf-property (pop plist) (pop plist))) - (when method - (set-mf-property :method method)) - (when return-function-p - (or mf (method-function-from-fast-function mff))))))) + (mff (and (typep mf '%method-function) + (%method-function-fast-function mf))) + (plist (getf initargs 'plist)) + (name (getf plist :name)) + (method-cell (getf initargs 'method-cell))) + (when method-cell + (setf (car method-cell) method)) + (when name + (when mf + (setq mf (set-fun-name mf name))) + (when (and mff (consp name) (eq (car name) 'slow-method)) + (let ((fast-name `(fast-method ,@(cdr name)))) + (set-fun-name mff fast-name)))) + (when plist + (let ((plist plist)) + (let ((snl (getf plist :slot-name-lists))) + (when snl + (setf (method-plist-value method :pv-table) + (intern-pv-table :slot-name-lists snl)))))))) (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? - (parse-key-arg (arg) - (if (listp arg) - (if (listp (car arg)) - (caar arg) - (keywordicate (car arg))) - (keywordicate arg)))) + (parse-key-arg (arg) + (if (listp arg) + (if (listp (car arg)) + (caar arg) + (keywordicate (car arg))) + (keywordicate arg)))) (let ((nrequired 0) - (noptional 0) - (keysp nil) - (restp nil) + (noptional 0) + (keysp nil) + (restp nil) (nrest 0) - (allow-other-keys-p nil) - (keywords ()) - (keyword-parameters ()) - (state 'required)) + (allow-other-keys-p nil) + (keywords ()) + (keyword-parameters ()) + (state 'required)) (dolist (x lambda-list) - (if (memq x lambda-list-keywords) - (case x - (&optional (setq state 'optional)) - (&key (setq keysp t - state 'key)) - (&allow-other-keys (setq allow-other-keys-p t)) - (&rest (setq restp t - state 'rest)) - (&aux (return t)) - (otherwise - (error "encountered the non-standard lambda list keyword ~S" - x))) - (ecase state - (required (incf nrequired)) - (optional (incf noptional)) - (key (push (parse-key-arg x) keywords) - (push x keyword-parameters)) - (rest (incf nrest))))) + (if (memq x lambda-list-keywords) + (case x + (&optional (setq state 'optional)) + (&key (setq keysp t + state 'key)) + (&allow-other-keys (setq allow-other-keys-p t)) + (&rest (setq restp t + state 'rest)) + (&aux (return t)) + (otherwise + (error "encountered the non-standard lambda list keyword ~S" + x))) + (ecase state + (required (incf nrequired)) + (optional (incf noptional)) + (key (push (parse-key-arg x) keywords) + (push x keyword-parameters)) + (rest (incf nrest))))) (when (and restp (zerop nrest)) (error "Error in lambda-list:~%~ After &REST, a DEFGENERIC lambda-list ~ must be followed by at least one variable.")) (values nrequired noptional keysp restp allow-other-keys-p - (reverse keywords) - (reverse keyword-parameters))))) + (reverse keywords) + (reverse keyword-parameters))))) (defun keyword-spec-name (x) (let ((key (if (atom x) x (car x)))) (if (atom key) - (keywordicate key) - (car key)))) + (keywordicate key) + (car key)))) (defun ftype-declaration-from-lambda-list (lambda-list name) (multiple-value-bind (nrequired noptional keysp restp allow-other-keys-p - keywords keyword-parameters) + keywords keyword-parameters) (analyze-lambda-list lambda-list) (declare (ignore keyword-parameters)) (let* ((old (info :function :type name)) ;FIXME:FDOCUMENTATION instead? - (old-ftype (if (fun-type-p old) old nil)) - (old-restp (and old-ftype (fun-type-rest old-ftype))) - (old-keys (and old-ftype - (mapcar #'key-info-name - (fun-type-keywords - old-ftype)))) - (old-keysp (and old-ftype (fun-type-keyp old-ftype))) - (old-allowp (and old-ftype - (fun-type-allowp old-ftype))) - (keywords (union old-keys (mapcar #'keyword-spec-name keywords)))) + (old-ftype (if (fun-type-p old) old nil)) + (old-restp (and old-ftype (fun-type-rest old-ftype))) + (old-keys (and old-ftype + (mapcar #'key-info-name + (fun-type-keywords + old-ftype)))) + (old-keysp (and old-ftype (fun-type-keyp old-ftype))) + (old-allowp (and old-ftype + (fun-type-allowp old-ftype))) + (keywords (union old-keys (mapcar #'keyword-spec-name keywords)))) `(function ,(append (make-list nrequired :initial-element t) - (when (plusp noptional) - (append '(&optional) - (make-list noptional :initial-element t))) - (when (or restp old-restp) - '(&rest t)) - (when (or keysp old-keysp) - (append '(&key) - (mapcar (lambda (key) - `(,key t)) - keywords) - (when (or allow-other-keys-p old-allowp) - '(&allow-other-keys))))) - *)))) - -(defun defgeneric-declaration (spec lambda-list) - `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec)) + (when (plusp noptional) + (append '(&optional) + (make-list noptional :initial-element t))) + (when (or restp old-restp) + '(&rest t)) + (when (or keysp old-keysp) + (append '(&key) + (mapcar (lambda (key) + `(,key t)) + keywords) + (when (or allow-other-keys-p old-allowp) + '(&allow-other-keys))))) + *)))) ;;;; early generic function support (defvar *!early-generic-functions* ()) (defun ensure-generic-function (fun-name - &rest all-keys - &key environment - &allow-other-keys) + &rest all-keys + &key environment definition-source + &allow-other-keys) (declare (ignore environment)) - (let ((existing (and (gboundp fun-name) - (gdefinition fun-name)))) - (if (and existing - (eq *boot-state* 'complete) - (null (generic-function-p existing))) - (generic-clobbers-function fun-name) - (apply #'ensure-generic-function-using-class - existing fun-name all-keys)))) + (let ((existing (and (fboundp fun-name) + (gdefinition fun-name)))) + (cond ((and existing + (eq **boot-state** 'complete) + (null (generic-function-p existing))) + (generic-clobbers-function fun-name) + (fmakunbound fun-name) + (apply #'ensure-generic-function fun-name all-keys)) + (t + (apply #'ensure-generic-function-using-class + existing fun-name all-keys))))) (defun generic-clobbers-function (fun-name) - (error 'simple-program-error - :format-control "~S already names an ordinary function or a macro." - :format-arguments (list fun-name))) + (cerror "Replace the function binding" + 'simple-program-error + :format-control "~S already names an ordinary function or a macro." + :format-arguments (list fun-name))) (defvar *sgf-wrapper* - (boot-make-wrapper (early-class-size 'standard-generic-function) - 'standard-generic-function)) + (!boot-make-wrapper (early-class-size 'standard-generic-function) + 'standard-generic-function)) (defvar *sgf-slots-init* (mapcar (lambda (canonical-slot) - (if (memq (getf canonical-slot :name) '(arg-info source)) - +slot-unbound+ - (let ((initfunction (getf canonical-slot :initfunction))) - (if initfunction - (funcall initfunction) - +slot-unbound+)))) - (early-collect-inheritance 'standard-generic-function))) - -(defvar *sgf-method-class-index* + (if (memq (getf canonical-slot :name) '(arg-info source)) + +slot-unbound+ + (let ((initfunction (getf canonical-slot :initfunction))) + (if initfunction + (funcall initfunction) + +slot-unbound+)))) + (early-collect-inheritance 'standard-generic-function))) + +(defconstant +sgf-method-class-index+ (!bootstrap-slot-index 'standard-generic-function 'method-class)) (defun early-gf-p (x) (and (fsc-instance-p x) - (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*) - +slot-unbound+))) + (eq (clos-slots-ref (get-slots x) +sgf-method-class-index+) + +slot-unbound+))) -(defvar *sgf-methods-index* +(defconstant +sgf-methods-index+ (!bootstrap-slot-index 'standard-generic-function 'methods)) (defmacro early-gf-methods (gf) - `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*)) + `(clos-slots-ref (get-slots ,gf) +sgf-methods-index+)) + +(defun safe-generic-function-methods (generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (clos-slots-ref (get-slots generic-function) +sgf-methods-index+) + (generic-function-methods generic-function))) -(defvar *sgf-arg-info-index* +(defconstant +sgf-arg-info-index+ (!bootstrap-slot-index 'standard-generic-function 'arg-info)) (defmacro early-gf-arg-info (gf) - `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*)) + `(clos-slots-ref (get-slots ,gf) +sgf-arg-info-index+)) -(defvar *sgf-dfun-state-index* +(defconstant +sgf-dfun-state-index+ (!bootstrap-slot-index 'standard-generic-function 'dfun-state)) (defstruct (arg-info - (:conc-name nil) - (:constructor make-arg-info ()) - (:copier nil)) + (:conc-name nil) + (:constructor make-arg-info ()) + (:copier nil)) (arg-info-lambda-list :no-lambda-list) arg-info-precedence arg-info-metatypes arg-info-number-optional arg-info-key/rest-p arg-info-keys ;nil no &KEY or &REST allowed - ;(k1 k2 ..) Each method must accept these &KEY arguments. - ;T must have &KEY or &REST + ;(k1 k2 ..) Each method must accept these &KEY arguments. + ;T must have &KEY or &REST gf-info-simple-accessor-type ; nil, reader, writer, boundp (gf-precompute-dfun-and-emf-p nil) ; set by set-arg-info @@ -1639,13 +1831,6 @@ bootstrapping. (defun arg-info-nkeys (arg-info) (count-if (lambda (x) (neq x t)) (arg-info-metatypes arg-info))) -;;; Keep pages clean by not setting if the value is already the same. -(defmacro esetf (pos val) - (with-unique-names (valsym) - `(let ((,valsym ,val)) - (unless (equal ,pos ,valsym) - (setf ,pos ,valsym))))) - (defun create-gf-lambda-list (lambda-list) ;;; Create a gf lambda list from a method lambda list (loop for x in lambda-list @@ -1653,48 +1838,47 @@ bootstrapping. if (eq x '&key) do (loop-finish))) (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) - argument-precedence-order) - (let* ((arg-info (if (eq *boot-state* 'complete) - (gf-arg-info gf) - (early-gf-arg-info gf))) - (methods (if (eq *boot-state* 'complete) - (generic-function-methods gf) - (early-gf-methods gf))) - (was-valid-p (integerp (arg-info-number-optional arg-info))) - (first-p (and new-method (null (cdr methods))))) + argument-precedence-order) + (let* ((arg-info (if (eq **boot-state** 'complete) + (gf-arg-info gf) + (early-gf-arg-info gf))) + (methods (if (eq **boot-state** 'complete) + (generic-function-methods gf) + (early-gf-methods gf))) + (was-valid-p (integerp (arg-info-number-optional arg-info))) + (first-p (and new-method (null (cdr methods))))) (when (and (not lambda-list-p) methods) (setq lambda-list (gf-lambda-list gf))) (when (or lambda-list-p - (and first-p - (eq (arg-info-lambda-list arg-info) :no-lambda-list))) + (and first-p + (eq (arg-info-lambda-list arg-info) :no-lambda-list))) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) - (analyze-lambda-list lambda-list) - (when (and methods (not first-p)) - (let ((gf-nreq (arg-info-number-required arg-info)) - (gf-nopt (arg-info-number-optional arg-info)) - (gf-key/rest-p (arg-info-key/rest-p arg-info))) - (unless (and (= nreq gf-nreq) - (= nopt gf-nopt) - (eq (or keysp restp) gf-key/rest-p)) - (error "The lambda-list ~S is incompatible with ~ - existing methods of ~S." - lambda-list gf)))) - (esetf (arg-info-lambda-list arg-info) - (if lambda-list-p - lambda-list + (analyze-lambda-list lambda-list) + (when (and methods (not first-p)) + (let ((gf-nreq (arg-info-number-required arg-info)) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info))) + (unless (and (= nreq gf-nreq) + (= nopt gf-nopt) + (eq (or keysp restp) gf-key/rest-p)) + (error "The lambda-list ~S is incompatible with ~ + existing methods of ~S." + lambda-list gf)))) + (setf (arg-info-lambda-list arg-info) + (if lambda-list-p + lambda-list (create-gf-lambda-list lambda-list))) - (when (or lambda-list-p argument-precedence-order - (null (arg-info-precedence arg-info))) - (esetf (arg-info-precedence arg-info) - (compute-precedence lambda-list nreq - argument-precedence-order))) - (esetf (arg-info-metatypes arg-info) (make-list nreq)) - (esetf (arg-info-number-optional arg-info) nopt) - (esetf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) - (esetf (arg-info-keys arg-info) - (if lambda-list-p - (if allow-other-keys-p t keywords) - (arg-info-key/rest-p arg-info))))) + (when (or lambda-list-p argument-precedence-order + (null (arg-info-precedence arg-info))) + (setf (arg-info-precedence arg-info) + (compute-precedence lambda-list nreq argument-precedence-order))) + (setf (arg-info-metatypes arg-info) (make-list nreq)) + (setf (arg-info-number-optional arg-info) nopt) + (setf (arg-info-key/rest-p arg-info) (not (null (or keysp restp)))) + (setf (arg-info-keys arg-info) + (if lambda-list-p + (if allow-other-keys-p t keywords) + (arg-info-key/rest-p arg-info))))) (when new-method (check-method-arg-info gf arg-info new-method)) (set-arg-info1 gf arg-info new-method methods was-valid-p first-p) @@ -1703,118 +1887,169 @@ bootstrapping. (defun check-method-arg-info (gf arg-info method) (multiple-value-bind (nreq nopt keysp restp allow-other-keys-p keywords) (analyze-lambda-list (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method))) + (early-method-lambda-list method) + (method-lambda-list method))) (flet ((lose (string &rest args) - (error 'simple-program-error - :format-control "~@" - :format-arguments (list method gf string args))) - (comparison-description (x y) - (if (> x y) "more" "fewer"))) + :format-arguments (list method gf string args))) + (comparison-description (x y) + (if (> x y) "more" "fewer"))) (let ((gf-nreq (arg-info-number-required arg-info)) - (gf-nopt (arg-info-number-optional arg-info)) - (gf-key/rest-p (arg-info-key/rest-p arg-info)) - (gf-keywords (arg-info-keys arg-info))) - (unless (= nreq gf-nreq) - (lose - "the method has ~A required arguments than the generic function." - (comparison-description nreq gf-nreq))) - (unless (= nopt gf-nopt) - (lose - "the method has ~A optional arguments than the generic function." - (comparison-description nopt gf-nopt))) - (unless (eq (or keysp restp) gf-key/rest-p) - (lose - "the method and generic function differ in whether they accept~_~ - &REST or &KEY arguments.")) - (when (consp gf-keywords) - (unless (or (and restp (not keysp)) - allow-other-keys-p - (every (lambda (k) (memq k keywords)) gf-keywords)) - (lose "the method does not accept each of the &KEY arguments~2I~_~ - ~S." - gf-keywords))))))) + (gf-nopt (arg-info-number-optional arg-info)) + (gf-key/rest-p (arg-info-key/rest-p arg-info)) + (gf-keywords (arg-info-keys arg-info))) + (unless (= nreq gf-nreq) + (lose + "the method has ~A required arguments than the generic function." + (comparison-description nreq gf-nreq))) + (unless (= nopt gf-nopt) + (lose + "the method has ~A optional arguments than the generic function." + (comparison-description nopt gf-nopt))) + (unless (eq (or keysp restp) gf-key/rest-p) + (lose + "the method and generic function differ in whether they accept~_~ + &REST or &KEY arguments.")) + (when (consp gf-keywords) + (unless (or (and restp (not keysp)) + allow-other-keys-p + (every (lambda (k) (memq k keywords)) gf-keywords)) + (lose "the method does not accept each of the &KEY arguments~2I~_~ + ~S." + gf-keywords))))))) + +(defconstant +sm-specializers-index+ + (!bootstrap-slot-index 'standard-method 'specializers)) +(defconstant +sm-%function-index+ + (!bootstrap-slot-index 'standard-method '%function)) +(defconstant +sm-qualifiers-index+ + (!bootstrap-slot-index 'standard-method 'qualifiers)) + +;;; FIXME: we don't actually need this; we could test for the exact +;;; class and deal with it as appropriate. In fact we probably don't +;;; need it anyway because we only use this for METHOD-SPECIALIZERS on +;;; the standard reader method for METHOD-SPECIALIZERS. Probably. +(dolist (s '(specializers %function)) + (aver (= (symbol-value (intern (format nil "+SM-~A-INDEX+" s))) + (!bootstrap-slot-index 'standard-reader-method s) + (!bootstrap-slot-index 'standard-writer-method s) + (!bootstrap-slot-index 'standard-boundp-method s) + (!bootstrap-slot-index 'global-reader-method s) + (!bootstrap-slot-index 'global-writer-method s) + (!bootstrap-slot-index 'global-boundp-method s)))) + +(defvar *standard-method-class-names* + '(standard-method standard-reader-method + standard-writer-method standard-boundp-method + global-reader-method global-writer-method + global-boundp-method)) + +(declaim (list **standard-method-classes**)) +(defglobal **standard-method-classes** nil) + +(defun safe-method-specializers (method) + (if (member (class-of method) **standard-method-classes** :test #'eq) + (clos-slots-ref (std-instance-slots method) +sm-specializers-index+) + (method-specializers method))) +(defun safe-method-fast-function (method) + (let ((mf (safe-method-function method))) + (and (typep mf '%method-function) + (%method-function-fast-function mf)))) +(defun safe-method-function (method) + (if (member (class-of method) **standard-method-classes** :test #'eq) + (clos-slots-ref (std-instance-slots method) +sm-%function-index+) + (method-function method))) +(defun safe-method-qualifiers (method) + (if (member (class-of method) **standard-method-classes** :test #'eq) + (clos-slots-ref (std-instance-slots method) +sm-qualifiers-index+) + (method-qualifiers method))) (defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p) (let* ((existing-p (and methods (cdr methods) new-method)) - (nreq (length (arg-info-metatypes arg-info))) - (metatypes (if existing-p - (arg-info-metatypes arg-info) - (make-list nreq))) - (type (if existing-p - (gf-info-simple-accessor-type arg-info) - nil))) + (nreq (length (arg-info-metatypes arg-info))) + (metatypes (if existing-p + (arg-info-metatypes arg-info) + (make-list nreq))) + (type (if existing-p + (gf-info-simple-accessor-type arg-info) + nil))) (when (arg-info-valid-p arg-info) (dolist (method (if new-method (list new-method) methods)) - (let* ((specializers (if (or (eq *boot-state* 'complete) - (not (consp method))) - (method-specializers method) - (early-method-specializers method t))) - (class (if (or (eq *boot-state* 'complete) (not (consp method))) - (class-of method) - (early-method-class method))) - (new-type (when (and class - (or (not (eq *boot-state* 'complete)) - (eq (generic-function-method-combination gf) - *standard-method-combination*))) - (cond ((eq class *the-class-standard-reader-method*) - 'reader) - ((eq class *the-class-standard-writer-method*) - 'writer) - ((eq class *the-class-standard-boundp-method*) - 'boundp))))) - (setq metatypes (mapcar #'raise-metatype metatypes specializers)) - (setq type (cond ((null type) new-type) - ((eq type new-type) type) - (t nil))))) - (esetf (arg-info-metatypes arg-info) metatypes) - (esetf (gf-info-simple-accessor-type arg-info) type))) + (let* ((specializers (if (or (eq **boot-state** 'complete) + (not (consp method))) + (safe-method-specializers method) + (early-method-specializers method t))) + (class (if (or (eq **boot-state** 'complete) (not (consp method))) + (class-of method) + (early-method-class method))) + (new-type + (when (and class + (or (not (eq **boot-state** 'complete)) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + (cond ((or (eq class *the-class-standard-reader-method*) + (eq class *the-class-global-reader-method*)) + 'reader) + ((or (eq class *the-class-standard-writer-method*) + (eq class *the-class-global-writer-method*)) + 'writer) + ((or (eq class *the-class-standard-boundp-method*) + (eq class *the-class-global-boundp-method*)) + 'boundp))))) + (setq metatypes (mapcar #'raise-metatype metatypes specializers)) + (setq type (cond ((null type) new-type) + ((eq type new-type) type) + (t nil))))) + (setf (arg-info-metatypes arg-info) metatypes) + (setf (gf-info-simple-accessor-type arg-info) type))) (when (or (not was-valid-p) first-p) (multiple-value-bind (c-a-m-emf std-p) - (if (early-gf-p gf) - (values t t) - (compute-applicable-methods-emf gf)) - (esetf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) - (esetf (gf-info-c-a-m-emf-std-p arg-info) std-p) + (if (early-gf-p gf) + (values t t) + (compute-applicable-methods-emf gf)) + (setf (gf-info-static-c-a-m-emf arg-info) c-a-m-emf) + (setf (gf-info-c-a-m-emf-std-p arg-info) std-p) (unless (gf-info-c-a-m-emf-std-p arg-info) - (esetf (gf-info-simple-accessor-type arg-info) t)))) + (setf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p - (let ((name (if (eq *boot-state* 'complete) - (generic-function-name gf) - (!early-gf-name gf)))) - (esetf (gf-precompute-dfun-and-emf-p arg-info) - (cond - ((and (consp name) - (member (car name) - *internal-pcl-generalized-fun-name-symbols*)) - nil) - (t (let* ((symbol (fun-name-block-name name)) - (package (symbol-package symbol))) - (and (or (eq package *pcl-package*) - (memq package (package-use-list *pcl-package*))) - ;; FIXME: this test will eventually be - ;; superseded by the *internal-pcl...* test, - ;; above. While we are in a process of - ;; transition, however, it should probably - ;; remain. - (not (find #\Space (symbol-name symbol)))))))))) - (esetf (gf-info-fast-mf-p arg-info) - (or (not (eq *boot-state* 'complete)) - (let* ((method-class (generic-function-method-class gf)) - (methods (compute-applicable-methods - #'make-method-lambda - (list gf (class-prototype method-class) - '(lambda) nil)))) - (and methods (null (cdr methods)) - (let ((specls (method-specializers (car methods)))) - (and (classp (car specls)) - (eq 'standard-generic-function - (class-name (car specls))) - (classp (cadr specls)) - (eq 'standard-method - (class-name (cadr specls))))))))) + (let ((name (if (eq **boot-state** 'complete) + (generic-function-name gf) + (!early-gf-name gf)))) + (setf (gf-precompute-dfun-and-emf-p arg-info) + (cond + ((and (consp name) + (member (car name) + *internal-pcl-generalized-fun-name-symbols*)) + nil) + (t (let* ((symbol (fun-name-block-name name)) + (package (symbol-package symbol))) + (and (or (eq package *pcl-package*) + (memq package (package-use-list *pcl-package*))) + (not (eq package #.(find-package "CL"))) + ;; FIXME: this test will eventually be + ;; superseded by the *internal-pcl...* test, + ;; above. While we are in a process of + ;; transition, however, it should probably + ;; remain. + (not (find #\Space (symbol-name symbol)))))))))) + (setf (gf-info-fast-mf-p arg-info) + (or (not (eq **boot-state** 'complete)) + (let* ((method-class (generic-function-method-class gf)) + (methods (compute-applicable-methods + #'make-method-lambda + (list gf (class-prototype method-class) + '(lambda) nil)))) + (and methods (null (cdr methods)) + (let ((specls (method-specializers (car methods)))) + (and (classp (car specls)) + (eq 'standard-generic-function + (class-name (car specls))) + (classp (cadr specls)) + (eq 'standard-method + (class-name (cadr specls))))))))) arg-info) ;;; This is the early definition of ENSURE-GENERIC-FUNCTION-USING-CLASS. @@ -1826,187 +2061,288 @@ bootstrapping. ;;; CAR - a list of the early methods on this early gf ;;; CADR - the early discriminator code for this method (defun ensure-generic-function-using-class (existing spec &rest keys - &key (lambda-list nil - lambda-list-p) - argument-precedence-order - &allow-other-keys) + &key (lambda-list nil + lambda-list-p) + argument-precedence-order + definition-source + documentation + &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) - (when lambda-list-p - (set-arg-info existing :lambda-list lambda-list)) - existing) - ((assoc spec *!generic-function-fixups* :test #'equal) - (if existing - (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order) - (error "The function ~S is not already defined." spec))) - (existing - (error "~S should be on the list ~S." - spec - '*!generic-function-fixups*)) - (t - (pushnew spec *!early-generic-functions* :test #'equal) - (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order)))) + (when lambda-list-p + (set-arg-info existing :lambda-list lambda-list)) + existing) + ((assoc spec *!generic-function-fixups* :test #'equal) + (if existing + (make-early-gf spec lambda-list lambda-list-p existing + argument-precedence-order definition-source + documentation) + (bug "The function ~S is not already defined." spec))) + (existing + (bug "~S should be on the list ~S." + spec '*!generic-function-fixups*)) + (t + (pushnew spec *!early-generic-functions* :test #'equal) + (make-early-gf spec lambda-list lambda-list-p nil + argument-precedence-order definition-source + documentation)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p - function argument-precedence-order) - (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) + function argument-precedence-order source-location + documentation) + (let ((fin (allocate-standard-funcallable-instance + *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin (or function - (if (eq spec 'print-object) - #'(instance-lambda (instance stream) - (print-unreadable-object (instance stream :identity t) - (format stream "std-instance"))) - #'(instance-lambda (&rest args) - (declare (ignore args)) - (error "The function of the funcallable-instance ~S~ - has not been set." fin))))) + (if (eq spec 'print-object) + #'(lambda (instance stream) + (print-unreadable-object (instance stream :identity t) + (format stream "std-instance"))) + #'(lambda (&rest args) + (declare (ignore args)) + (error "The function of the funcallable-instance ~S~ + has not been set." fin))))) (setf (gdefinition spec) fin) (!bootstrap-set-slot 'standard-generic-function fin 'name spec) - (!bootstrap-set-slot 'standard-generic-function - fin - 'source - *load-pathname*) + (!bootstrap-set-slot 'standard-generic-function fin + 'source source-location) + (!bootstrap-set-slot 'standard-generic-function fin + '%documentation documentation) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p - (proclaim (defgeneric-declaration spec lambda-list)) - (if argument-precedence-order - (set-arg-info fin - :lambda-list lambda-list - :argument-precedence-order argument-precedence-order) - (set-arg-info fin :lambda-list lambda-list)))) + (setf (info :function :type spec) + (specifier-type + (ftype-declaration-from-lambda-list lambda-list spec)) + (info :function :where-from spec) :defined-method) + (if argument-precedence-order + (set-arg-info fin + :lambda-list lambda-list + :argument-precedence-order argument-precedence-order) + (set-arg-info fin :lambda-list lambda-list)))) fin)) +(defun safe-gf-dfun-state (generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (clos-slots-ref (fsc-instance-slots generic-function) +sgf-dfun-state-index+) + (gf-dfun-state generic-function))) +(defun (setf safe-gf-dfun-state) (new-value generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (setf (clos-slots-ref (fsc-instance-slots generic-function) + +sgf-dfun-state-index+) + new-value) + (setf (gf-dfun-state generic-function) new-value))) + (defun set-dfun (gf &optional dfun cache info) - (when cache - (setf (cache-owner cache) gf)) (let ((new-state (if (and dfun (or cache info)) - (list* dfun cache info) - dfun))) - (if (eq *boot-state* 'complete) - (setf (gf-dfun-state gf) new-state) - (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) - new-state))) + (list* dfun cache info) + dfun))) + (cond + ((eq **boot-state** 'complete) + ;; Check that we are under the lock. + #+sb-thread + (aver (eq sb-thread:*current-thread* (sb-thread:mutex-owner (gf-lock gf)))) + (setf (safe-gf-dfun-state gf) new-state)) + (t + (setf (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+) + new-state)))) dfun) (defun gf-dfun-cache (gf) - (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (let ((state (if (eq **boot-state** 'complete) + (safe-gf-dfun-state gf) + (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)))) (typecase state (function nil) (cons (cadr state))))) (defun gf-dfun-info (gf) - (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (let ((state (if (eq **boot-state** 'complete) + (safe-gf-dfun-state gf) + (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)))) (typecase state (function nil) (cons (cddr state))))) -(defvar *sgf-name-index* +(defconstant +sgf-name-index+ (!bootstrap-slot-index 'standard-generic-function 'name)) (defun !early-gf-name (gf) - (clos-slots-ref (get-slots gf) *sgf-name-index*)) + (clos-slots-ref (get-slots gf) +sgf-name-index+)) (defun gf-lambda-list (gf) - (let ((arg-info (if (eq *boot-state* 'complete) - (gf-arg-info gf) - (early-gf-arg-info gf)))) + (let ((arg-info (if (eq **boot-state** 'complete) + (gf-arg-info gf) + (early-gf-arg-info gf)))) (if (eq :no-lambda-list (arg-info-lambda-list arg-info)) - (let ((methods (if (eq *boot-state* 'complete) - (generic-function-methods gf) - (early-gf-methods gf)))) - (if (null methods) - (progn - (warn "no way to determine the lambda list for ~S" gf) - nil) - (let* ((method (car (last methods))) - (ll (if (consp method) - (early-method-lambda-list method) - (method-lambda-list method)))) + (let ((methods (if (eq **boot-state** 'complete) + (generic-function-methods gf) + (early-gf-methods gf)))) + (if (null methods) + (progn + (warn "no way to determine the lambda list for ~S" gf) + nil) + (let* ((method (car (last methods))) + (ll (if (consp method) + (early-method-lambda-list method) + (method-lambda-list method)))) (create-gf-lambda-list ll)))) - (arg-info-lambda-list arg-info)))) + (arg-info-lambda-list arg-info)))) (defmacro real-ensure-gf-internal (gf-class all-keys env) `(progn (cond ((symbolp ,gf-class) - (setq ,gf-class (find-class ,gf-class t ,env))) - ((classp ,gf-class)) - (t - (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ - class nor a symbol that names a class." - ,gf-class))) + (setq ,gf-class (find-class ,gf-class t ,env))) + ((classp ,gf-class)) + (t + (error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~ + class nor a symbol that names a class." + ,gf-class))) + (unless (class-finalized-p ,gf-class) + (if (class-has-a-forward-referenced-superclass-p ,gf-class) + ;; FIXME: reference MOP documentation -- this is an + ;; additional requirement on our users + (error "The generic function class ~S is not finalizeable" ,gf-class) + (finalize-inheritance ,gf-class))) (remf ,all-keys :generic-function-class) (remf ,all-keys :environment) - (let ((combin (getf ,all-keys :method-combination '.shes-not-there.))) - (unless (eq combin '.shes-not-there.) - (setf (getf ,all-keys :method-combination) - (find-method-combination (class-prototype ,gf-class) - (car combin) - (cdr combin))))) + (let ((combin (getf ,all-keys :method-combination))) + (etypecase combin + (cons + (setf (getf ,all-keys :method-combination) + (find-method-combination (class-prototype ,gf-class) + (car combin) + (cdr combin)))) + ((or null method-combination)))) (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) - (find-class method-class t ,env)))))) + (cond ((classp method-class) + method-class) + (t (find-class method-class t ,env)))))))) + +(defun note-gf-signature (fun-name lambda-list-p lambda-list) + (unless lambda-list-p + ;; Use the existing lambda-list, if any. It is reasonable to do eg. + ;; + ;; (if (fboundp name) + ;; (ensure-generic-function name) + ;; (ensure-generic-function name :lambda-list '(foo))) + ;; + ;; in which case we end up here with no lambda-list in the first leg. + (setf (values lambda-list lambda-list-p) + (handler-case + (values (generic-function-lambda-list (fdefinition fun-name)) + t) + ((or warning error) () + (values nil nil))))) + (let ((gf-type + (specifier-type + (if lambda-list-p + (ftype-declaration-from-lambda-list lambda-list fun-name) + 'function))) + (old-type nil)) + ;; FIXME: Ideally we would like to not clobber it, but because generic + ;; functions assert their FTYPEs callers believing the FTYPE are left with + ;; unsafe assumptions. Hence the clobbering. Be quiet when the new type + ;; is a subtype of the old one, though -- even though the type is not + ;; trusted anymore, the warning is still not quite as interesting. + (when (and (eq :declared (info :function :where-from fun-name)) + (not (csubtypep gf-type (setf old-type (info :function :type fun-name))))) + (style-warn "~@" + fun-name 'ftype + (type-specifier old-type) + (type-specifier gf-type))) + (setf (info :function :type fun-name) gf-type + (info :function :where-from fun-name) :defined-method) + fun-name)) (defun real-ensure-gf-using-class--generic-function (existing - fun-name - &rest all-keys - &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function gf-class-p) - &allow-other-keys) + fun-name + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function) + &allow-other-keys) (real-ensure-gf-internal generic-function-class all-keys environment) - (unless (or (null gf-class-p) - (eq (class-of existing) generic-function-class)) + ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS, + ;; which is what makes the next line work + (unless (eq (class-of existing) generic-function-class) (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) - (when lambda-list-p - (proclaim (defgeneric-declaration fun-name lambda-list))))) + (note-gf-signature fun-name lambda-list-p lambda-list))) (defun real-ensure-gf-using-class--null (existing - fun-name - &rest all-keys - &key environment (lambda-list nil lambda-list-p) - (generic-function-class 'standard-generic-function) - &allow-other-keys) + fun-name + &rest all-keys + &key environment (lambda-list nil lambda-list-p) + (generic-function-class 'standard-generic-function) + &allow-other-keys) (declare (ignore existing)) (real-ensure-gf-internal generic-function-class all-keys environment) (prog1 (setf (gdefinition fun-name) - (apply #'make-instance generic-function-class - :name fun-name all-keys)) - (when lambda-list-p - (proclaim (defgeneric-declaration fun-name lambda-list))))) + (apply #'make-instance generic-function-class + :name fun-name all-keys)) + (note-gf-signature fun-name lambda-list-p lambda-list))) +(defun safe-gf-arg-info (generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (clos-slots-ref (fsc-instance-slots generic-function) + +sgf-arg-info-index+) + (gf-arg-info generic-function))) + +;;; FIXME: this function took on a slightly greater role than it +;;; previously had around 2005-11-02, when CSR fixed the bug whereby +;;; having more than one subclass of standard-generic-function caused +;;; the whole system to die horribly through a metacircle in +;;; GF-ARG-INFO. The fix is to be slightly more disciplined about +;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when +;;; computing discriminating functions, so we need to be careful about +;;; having a base case for the recursion, and we provide that with the +;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet) +;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to +;;; that stage, where all potentially dangerous cases are enumerated +;;; and stopped. -- CSR, 2005-11-02. (defun get-generic-fun-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (metatypes (arg-info-metatypes arg-info))) - (values (arg-info-applyp arg-info) - metatypes - arg-info)) - (values (length metatypes) applyp metatypes - (count-if (lambda (x) (neq x t)) metatypes) - arg-info))) + (early-gf-arg-info gf) + (safe-gf-arg-info gf))) + (metatypes (arg-info-metatypes arg-info))) + (values (arg-info-applyp arg-info) + metatypes + arg-info)) + (let ((nreq 0) + (nkeys 0)) + (declare (fixnum nreq nkeys)) + (dolist (x metatypes) + (incf nreq) + (unless (eq x t) + (incf nkeys))) + (values nreq applyp metatypes + nkeys + arg-info)))) + +(defun generic-function-nreq (gf) + (let* ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (safe-gf-arg-info gf))) + (metatypes (arg-info-metatypes arg-info))) + (declare (list metatypes)) + (length metatypes))) (defun early-make-a-method (class qualifiers arglist specializers initargs doc - &optional slot-name) - (initialize-method-function initargs) + &key slot-name object-class method-class-function + definition-source) (let ((parsed ()) - (unparsed ())) + (unparsed ())) ;; Figure out whether we got class objects or class names as the ;; specializers and set parsed and unparsed appropriately. If we ;; got class objects, then we can compute unparsed, but if we got @@ -2016,43 +2352,64 @@ bootstrapping. ;; read as 'classp' we can't use classp itself because it doesn't ;; exist yet. (if (every (lambda (s) (not (symbolp s))) specializers) - (setq parsed specializers - unparsed (mapcar (lambda (s) - (if (eq s t) t (class-name s))) - specializers)) - (setq unparsed specializers - parsed ())) - (list :early-method ;This is an early method dammit! - - (getf initargs :function) - (getf initargs :fast-function) - - parsed ;The parsed specializers. This is used - ;by early-method-specializers to cache - ;the parse. Note that this only comes - ;into play when there is more than one - ;early method on an early gf. - - (list class ;A list to which real-make-a-method - qualifiers ;can be applied to make a real method - arglist ;corresponding to this early one. - unparsed - initargs - doc - slot-name)))) + (setq parsed specializers + unparsed (mapcar (lambda (s) + (if (eq s t) t (class-name s))) + specializers)) + (setq unparsed specializers + parsed ())) + (let ((result + (list :early-method + + (getf initargs :function) + (let ((mf (getf initargs :function))) + (aver mf) + (and (typep mf '%method-function) + (%method-function-fast-function mf))) + + ;; the parsed specializers. This is used by + ;; EARLY-METHOD-SPECIALIZERS to cache the parse. + ;; Note that this only comes into play when there is + ;; more than one early method on an early gf. + parsed + + ;; A list to which REAL-MAKE-A-METHOD can be applied + ;; to make a real method corresponding to this early + ;; one. + (append + (list class qualifiers arglist unparsed + initargs doc) + (when slot-name + (list :slot-name slot-name :object-class object-class + :method-class-function method-class-function)) + (list :definition-source definition-source))))) + (initialize-method-function initargs result) + result))) (defun real-make-a-method (class qualifiers lambda-list specializers initargs doc - &optional slot-name) - (setq specializers (parse-specializers specializers)) - (apply #'make-instance class - :qualifiers qualifiers - :lambda-list lambda-list - :specializers specializers - :documentation doc - :slot-name slot-name - :allow-other-keys t - initargs)) + &rest args &key slot-name object-class method-class-function + definition-source) + (if method-class-function + (let* ((object-class (if (classp object-class) object-class + (find-class object-class))) + (slots (class-direct-slots object-class)) + (slot-definition (find slot-name slots + :key #'slot-definition-name))) + (aver slot-name) + (aver slot-definition) + (let ((initargs (list* :qualifiers qualifiers :lambda-list lambda-list + :specializers specializers :documentation doc + :slot-definition slot-definition + :slot-name slot-name initargs))) + (apply #'make-instance + (apply method-class-function object-class slot-definition + initargs) + :definition-source definition-source + initargs))) + (apply #'make-instance class :qualifiers qualifiers + :lambda-list lambda-list :specializers specializers + :documentation doc (append args initargs)))) (defun early-method-function (early-method) (values (cadr early-method) (caddr early-method))) @@ -2063,11 +2420,11 @@ bootstrapping. (defun early-method-standard-accessor-p (early-method) (let ((class (first (fifth early-method)))) (or (eq class 'standard-reader-method) - (eq class 'standard-writer-method) - (eq class 'standard-boundp-method)))) + (eq class 'standard-writer-method) + (eq class 'standard-boundp-method)))) (defun early-method-standard-accessor-slot-name (early-method) - (seventh (fifth early-method))) + (eighth (fifth early-method))) ;;; Fetch the specializers of an early method. This is basically just ;;; a simple accessor except that when the second argument is t, this @@ -2085,40 +2442,48 @@ bootstrapping. ;;; method on any generic function up until the time classes exist. (defun early-method-specializers (early-method &optional objectsp) (if (and (listp early-method) - (eq (car early-method) :early-method)) + (eq (car early-method) :early-method)) (cond ((eq objectsp t) - (or (fourth early-method) - (setf (fourth early-method) - (mapcar #'find-class (cadddr (fifth early-method)))))) - (t - (cadddr (fifth early-method)))) + (or (fourth early-method) + (setf (fourth early-method) + (mapcar #'find-class (cadddr (fifth early-method)))))) + (t + (fourth (fifth early-method)))) (error "~S is not an early-method." early-method))) (defun early-method-qualifiers (early-method) - (cadr (fifth early-method))) + (second (fifth early-method))) (defun early-method-lambda-list (early-method) - (caddr (fifth early-method))) - -(defun early-add-named-method (generic-function-name - qualifiers - specializers - arglist - &rest initargs) - (let* ((gf (ensure-generic-function generic-function-name)) - (existing - (dolist (m (early-gf-methods gf)) - (when (and (equal (early-method-specializers m) specializers) - (equal (early-method-qualifiers m) qualifiers)) - (return m)))) - (new (make-a-method 'standard-method - qualifiers - arglist - specializers - initargs - ()))) - (when existing (remove-method gf existing)) - (add-method gf new))) + (third (fifth early-method))) + +(defun early-method-initargs (early-method) + (fifth (fifth early-method))) + +(defun (setf early-method-initargs) (new-value early-method) + (setf (fifth (fifth early-method)) new-value)) + +(defun early-add-named-method (generic-function-name qualifiers + specializers arglist &rest initargs + &key documentation definition-source + &allow-other-keys) + (let* (;; we don't need to deal with the :generic-function-class + ;; argument here because the default, + ;; STANDARD-GENERIC-FUNCTION, is right for all early generic + ;; functions. (See REAL-ADD-NAMED-METHOD) + (gf (ensure-generic-function generic-function-name)) + (existing + (dolist (m (early-gf-methods gf)) + (when (and (equal (early-method-specializers m) specializers) + (equal (early-method-qualifiers m) qualifiers)) + (return m))))) + (setf (getf (getf initargs 'plist) :name) + (make-method-spec gf qualifiers specializers)) + (let ((new (make-a-method 'standard-method qualifiers arglist + specializers initargs documentation + :definition-source definition-source))) + (when existing (remove-method gf existing)) + (add-method gf new)))) ;;; This is the early version of ADD-METHOD. Later this will become a ;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has @@ -2131,8 +2496,8 @@ bootstrapping. (push method (early-gf-methods generic-function)) (set-arg-info generic-function :new-method method) (unless (assoc (!early-gf-name generic-function) - *!generic-function-fixups* - :test #'equal) + *!generic-function-fixups* + :test #'equal) (update-dfun generic-function))) ;;; This is the early version of REMOVE-METHOD. See comments on @@ -2143,28 +2508,28 @@ bootstrapping. (when (not (and (listp method) (eq (car method) :early-method))) (error "An early remove-method didn't get an early method.")) (setf (early-gf-methods generic-function) - (remove method (early-gf-methods generic-function))) + (remove method (early-gf-methods generic-function))) (set-arg-info generic-function) (unless (assoc (!early-gf-name generic-function) - *!generic-function-fixups* - :test #'equal) + *!generic-function-fixups* + :test #'equal) (update-dfun generic-function))) ;;; This is the early version of GET-METHOD. See comments on the early ;;; version of ADD-METHOD. (defun get-method (generic-function qualifiers specializers - &optional (errorp t)) + &optional (errorp t)) (if (early-gf-p generic-function) (or (dolist (m (early-gf-methods generic-function)) - (when (and (or (equal (early-method-specializers m nil) - specializers) - (equal (early-method-specializers m t) - specializers)) - (equal (early-method-qualifiers m) qualifiers)) - (return m))) - (if errorp - (error "can't get early method") - nil)) + (when (and (or (equal (early-method-specializers m nil) + specializers) + (equal (early-method-specializers m t) + specializers)) + (equal (early-method-qualifiers m) qualifiers)) + (return m))) + (if errorp + (error "can't get early method") + nil)) (real-get-method generic-function qualifiers specializers errorp))) (defun !fix-early-generic-functions () @@ -2173,47 +2538,47 @@ bootstrapping. ;; FIX-EARLY-GENERIC-FUNCTIONS. (dolist (early-gf-spec *!early-generic-functions*) (when (every #'early-method-standard-accessor-p - (early-gf-methods (gdefinition early-gf-spec))) - (push early-gf-spec accessors))) + (early-gf-methods (gdefinition early-gf-spec))) + (push early-gf-spec accessors))) (dolist (spec (nconc accessors - '(accessor-method-slot-name - generic-function-methods - method-specializers - specializerp - specializer-type - specializer-class - slot-definition-location - slot-definition-name - class-slots - gf-arg-info - class-precedence-list - slot-boundp-using-class - (setf slot-value-using-class) - slot-value-using-class - structure-class-p - standard-class-p - funcallable-standard-class-p - specializerp))) + '(accessor-method-slot-name + generic-function-methods + method-specializers + specializerp + specializer-type + specializer-class + slot-definition-location + slot-definition-name + class-slots + gf-arg-info + class-precedence-list + slot-boundp-using-class + (setf slot-value-using-class) + slot-value-using-class + structure-class-p + standard-class-p + funcallable-standard-class-p + specializerp))) (/show spec) (setq *!early-generic-functions* - (cons spec - (delete spec *!early-generic-functions* :test #'equal)))) + (cons spec + (delete spec *!early-generic-functions* :test #'equal)))) (dolist (early-gf-spec *!early-generic-functions*) (/show early-gf-spec) (let* ((gf (gdefinition early-gf-spec)) - (methods (mapcar (lambda (early-method) - (let ((args (copy-list (fifth - early-method)))) - (setf (fourth args) - (early-method-specializers - early-method t)) - (apply #'real-make-a-method args))) - (early-gf-methods gf)))) - (setf (generic-function-method-class gf) *the-class-standard-method*) - (setf (generic-function-method-combination gf) - *standard-method-combination*) - (set-methods gf methods))) + (methods (mapcar (lambda (early-method) + (let ((args (copy-list (fifth + early-method)))) + (setf (fourth args) + (early-method-specializers + early-method t)) + (apply #'real-make-a-method args))) + (early-gf-methods gf)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) + *standard-method-combination*) + (set-methods gf methods))) (dolist (fn *!early-functions*) (/show fn) @@ -2222,33 +2587,33 @@ bootstrapping. (dolist (fixup *!generic-function-fixups*) (/show fixup) (let* ((fspec (car fixup)) - (gf (gdefinition fspec)) - (methods (mapcar (lambda (method) - (let* ((lambda-list (first method)) - (specializers (second method)) - (method-fn-name (third method)) - (fn-name (or method-fn-name fspec)) - (fn (fdefinition fn-name)) - (initargs - (list :function - (set-fun-name - (lambda (args next-methods) - (declare (ignore - next-methods)) - (apply fn args)) - `(call ,fn-name))))) - (declare (type function fn)) - (make-a-method 'standard-method - () - lambda-list - specializers - initargs - nil))) - (cdr fixup)))) - (setf (generic-function-method-class gf) *the-class-standard-method*) - (setf (generic-function-method-combination gf) - *standard-method-combination*) - (set-methods gf methods)))) + (gf (gdefinition fspec)) + (methods (mapcar (lambda (method) + (let* ((lambda-list (first method)) + (specializers (mapcar #'find-class (second method))) + (method-fn-name (third method)) + (fn-name (or method-fn-name fspec)) + (fn (fdefinition fn-name)) + (initargs + (list :function + (set-fun-name + (lambda (args next-methods) + (declare (ignore + next-methods)) + (apply fn args)) + `(call ,fn-name))))) + (declare (type function fn)) + (make-a-method 'standard-method + () + lambda-list + specializers + initargs + nil))) + (cdr fixup)))) + (setf (generic-function-method-class gf) *the-class-standard-method*) + (setf (generic-function-method-combination gf) + *standard-method-combination*) + (set-methods gf methods)))) (/show "leaving !FIX-EARLY-GENERIC-FUNCTIONS")) ;;; PARSE-DEFMETHOD is used by DEFMETHOD to parse the &REST argument @@ -2256,72 +2621,25 @@ bootstrapping. ;;; is really implemented. (defun parse-defmethod (cdr-of-form) (declare (list cdr-of-form)) - (let ((name (pop cdr-of-form)) - (qualifiers ()) - (spec-ll ())) + (let ((qualifiers ()) + (spec-ll ())) (loop (if (and (car cdr-of-form) (atom (car cdr-of-form))) - (push (pop cdr-of-form) qualifiers) - (return (setq qualifiers (nreverse qualifiers))))) + (push (pop cdr-of-form) qualifiers) + (return (setq qualifiers (nreverse qualifiers))))) (setq spec-ll (pop cdr-of-form)) - (values name qualifiers spec-ll cdr-of-form))) + (values qualifiers spec-ll cdr-of-form))) -(defun parse-specializers (specializers) +(defun parse-specializers (generic-function specializers) (declare (list specializers)) (flet ((parse (spec) - (let ((result (specializer-from-type spec))) - (if (specializerp result) - result - (if (symbolp spec) - (error "~S was used as a specializer,~%~ - but is not the name of a class." - spec) - (error "~S is not a legal specializer." spec)))))) + (parse-specializer-using-class generic-function spec))) (mapcar #'parse specializers))) -(defun unparse-specializers (specializers-or-method) - (if (listp specializers-or-method) - (flet ((unparse (spec) - (if (specializerp spec) - (let ((type (specializer-type spec))) - (if (and (consp type) - (eq (car type) 'class)) - (let* ((class (cadr type)) - (class-name (class-name class))) - (if (eq class (find-class class-name nil)) - class-name - type)) - type)) - (error "~S is not a legal specializer." spec)))) - (mapcar #'unparse specializers-or-method)) - (unparse-specializers (method-specializers specializers-or-method)))) - -(defun parse-method-or-spec (spec &optional (errorp t)) - (let (gf method name temp) - (if (method-p spec) - (setq method spec - gf (method-generic-function method) - temp (and gf (generic-function-name gf)) - name (if temp - (make-method-spec temp - (method-qualifiers method) - (unparse-specializers - (method-specializers method))) - (make-symbol (format nil "~S" method)))) - (multiple-value-bind (gf-spec quals specls) - (parse-defmethod spec) - (and (setq gf (and (or errorp (gboundp gf-spec)) - (gdefinition gf-spec))) - (let ((nreq (compute-discriminating-function-arglist-info gf))) - (setq specls (append (parse-specializers specls) - (make-list (- nreq (length specls)) - :initial-element - *the-class-t*))) - (and - (setq method (get-method gf quals specls errorp)) - (setq name - (make-method-spec - gf-spec quals (unparse-specializers specls)))))))) - (values gf method name))) +(defun unparse-specializers (generic-function specializers) + (declare (list specializers)) + (flet ((unparse (spec) + (unparse-specializer-using-class generic-function spec))) + (mapcar #'unparse specializers))) (defun extract-parameters (specialized-lambda-list) (multiple-value-bind (parameters ignore1 ignore2) @@ -2356,120 +2674,131 @@ bootstrapping. (arglist &optional supplied-keywords (allowed-keywords '(&optional &rest &key &aux)) &aux (specialized-lambda-list-keywords - '(&optional &rest &key &allow-other-keys &aux))) + '(&optional &rest &key &allow-other-keys &aux))) (let ((arg (car arglist))) (cond ((null arglist) (values nil nil nil nil)) - ((eq arg '&aux) - (values nil arglist nil nil)) - ((memq arg lambda-list-keywords) - ;; non-standard lambda-list-keywords are errors. - (unless (memq arg specialized-lambda-list-keywords) - (error 'specialized-lambda-list-error - :format-control "unknown specialized-lambda-list ~ + ((eq arg '&aux) + (values nil arglist nil nil)) + ((memq arg lambda-list-keywords) + ;; non-standard lambda-list-keywords are errors. + (unless (memq arg specialized-lambda-list-keywords) + (error 'specialized-lambda-list-error + :format-control "unknown specialized-lambda-list ~ keyword ~S~%" - :format-arguments (list arg))) - ;; no multiple &rest x &rest bla specifying - (when (memq arg supplied-keywords) - (error 'specialized-lambda-list-error - :format-control "multiple occurrence of ~ + :format-arguments (list arg))) + ;; no multiple &rest x &rest bla specifying + (when (memq arg supplied-keywords) + (error 'specialized-lambda-list-error + :format-control "multiple occurrence of ~ specialized-lambda-list keyword ~S~%" - :format-arguments (list arg))) - ;; And no placing &key in front of &optional, either. - (unless (memq arg allowed-keywords) - (error 'specialized-lambda-list-error - :format-control "misplaced specialized-lambda-list ~ + :format-arguments (list arg))) + ;; And no placing &key in front of &optional, either. + (unless (memq arg allowed-keywords) + (error 'specialized-lambda-list-error + :format-control "misplaced specialized-lambda-list ~ keyword ~S~%" - :format-arguments (list arg))) - ;; When we are at a lambda-list keyword, the parameters - ;; don't include the lambda-list keyword; the lambda-list - ;; does include the lambda-list keyword; and no - ;; specializers are allowed to follow the lambda-list - ;; keywords (at least for now). - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) - (cons arg supplied-keywords) - (if (eq arg '&key) - (cons '&allow-other-keys - (cdr (member arg allowed-keywords))) - (cdr (member arg allowed-keywords)))) - (when (and (eq arg '&rest) - (or (null lambda-list) - (memq (car lambda-list) - specialized-lambda-list-keywords) - (not (or (null (cadr lambda-list)) - (memq (cadr lambda-list) - specialized-lambda-list-keywords))))) - (error 'specialized-lambda-list-error - :format-control - "in a specialized-lambda-list, excactly one ~ + :format-arguments (list arg))) + ;; When we are at a lambda-list keyword, the parameters + ;; don't include the lambda-list keyword; the lambda-list + ;; does include the lambda-list keyword; and no + ;; specializers are allowed to follow the lambda-list + ;; keywords (at least for now). + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) + (cons arg supplied-keywords) + (if (eq arg '&key) + (cons '&allow-other-keys + (cdr (member arg allowed-keywords))) + (cdr (member arg allowed-keywords)))) + (when (and (eq arg '&rest) + (or (null lambda-list) + (memq (car lambda-list) + specialized-lambda-list-keywords) + (not (or (null (cadr lambda-list)) + (memq (cadr lambda-list) + specialized-lambda-list-keywords))))) + (error 'specialized-lambda-list-error + :format-control + "in a specialized-lambda-list, excactly one ~ variable must follow &REST.~%" - :format-arguments nil)) - (values parameters - (cons arg lambda-list) - () - ()))) - (supplied-keywords - ;; After a lambda-list keyword there can be no specializers. - (multiple-value-bind (parameters lambda-list) - (parse-specialized-lambda-list (cdr arglist) - supplied-keywords - allowed-keywords) - (values (cons (if (listp arg) (car arg) arg) parameters) - (cons arg lambda-list) - () - ()))) - (t - (multiple-value-bind (parameters lambda-list specializers required) - (parse-specialized-lambda-list (cdr arglist)) - (values (cons (if (listp arg) (car arg) arg) parameters) - (cons (if (listp arg) (car arg) arg) lambda-list) - (cons (if (listp arg) (cadr arg) t) specializers) - (cons (if (listp arg) (car arg) arg) required))))))) + :format-arguments nil)) + (values parameters + (cons arg lambda-list) + () + ()))) + (supplied-keywords + ;; After a lambda-list keyword there can be no specializers. + (multiple-value-bind (parameters lambda-list) + (parse-specialized-lambda-list (cdr arglist) + supplied-keywords + allowed-keywords) + (values (cons (if (listp arg) (car arg) arg) parameters) + (cons arg lambda-list) + () + ()))) + (t + (multiple-value-bind (parameters lambda-list specializers required) + (parse-specialized-lambda-list (cdr arglist)) + ;; Check for valid arguments. + (unless (or (and (symbolp arg) (not (null arg))) + (and (consp arg) + (consp (cdr arg)) + (null (cddr arg)))) + (error 'specialized-lambda-list-error + :format-control "arg is not a non-NIL symbol or a list of two elements: ~A" + :format-arguments (list arg))) + (values (cons (if (listp arg) (car arg) arg) parameters) + (cons (if (listp arg) (car arg) arg) lambda-list) + (cons (if (listp arg) (cadr arg) t) specializers) + (cons (if (listp arg) (car arg) arg) required))))))) -(setq *boot-state* 'early) +(setq **boot-state** 'early) ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET ;;; which used %WALKER stuff. That suggests to me that maybe the code ;;; walker stuff was only used for implementing stuff like that; maybe ;;; it's not needed any more? Hunt down what it was used for and see. +(defun extract-the (form) + (cond ((and (consp form) (eq (car form) 'the)) + (aver (proper-list-of-length-p form 3)) + (third form)) + (t + form))) + (defmacro with-slots (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) - (and (symbolp instance) - `((declare (%variable-rebinding ,in ,instance))))) + ,@(let ((instance (extract-the instance))) + (and (symbolp instance) + `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) - (let ((var-name - (if (symbolp slot-entry) - slot-entry - (car slot-entry))) - (slot-name - (if (symbolp slot-entry) - slot-entry - (cadr slot-entry)))) - `(,var-name - (slot-value ,in ',slot-name)))) - slots) - ,@body)))) + (let ((var-name + (if (symbolp slot-entry) + slot-entry + (car slot-entry))) + (slot-name + (if (symbolp slot-entry) + slot-entry + (cadr slot-entry)))) + `(,var-name + (slot-value ,in ',slot-name)))) + slots) + ,@body)))) (defmacro with-accessors (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) - (and (symbolp instance) - `((declare (%variable-rebinding ,in ,instance))))) + ,@(let ((instance (extract-the instance))) + (and (symbolp instance) + `((declare (%variable-rebinding ,in ,instance))))) ,in (symbol-macrolet ,(mapcar (lambda (slot-entry) - (let ((var-name (car slot-entry)) - (accessor-name (cadr slot-entry))) - `(,var-name (,accessor-name ,in)))) - slots) - ,@body)))) + (let ((var-name (car slot-entry)) + (accessor-name (cadr slot-entry))) + `(,var-name (,accessor-name ,in)))) + slots) + ,@body))))