X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fboot.lisp;h=6a8cc46530860db01941637dde7ebab75f994198;hb=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;hp=11dfa03e57624e84a98f4717041ab23399a1b834;hpb=386781eeedff86ae01bb53fae7e253a03e2cb19c;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 11dfa03..6a8cc46 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -171,25 +171,33 @@ bootstrapping. (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 (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))) + :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)) @@ -239,8 +247,8 @@ bootstrapping. (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))))) + ,@(mapcar #'expand-method-definition methods) + (fdefinition ',fun-name))))) (defun compile-or-load-defgeneric (fun-name) (proclaim-as-fun-name fun-name) @@ -252,9 +260,10 @@ bootstrapping. (defun load-defgeneric (fun-name lambda-list source-location &rest initargs) (when (fboundp fun-name) + (warn 'sb-kernel:redefinition-with-defgeneric + :name fun-name + :new-location source-location) (let ((fun (fdefinition fun-name))) - (warn 'sb-kernel:redefinition-with-defgeneric :name fun-name - :old fun :new-location source-location) (when (generic-function-p fun) (loop for method in (generic-function-initial-methods fun) do (remove-method fun method)) @@ -309,40 +318,44 @@ bootstrapping. ;; belong here! (aver (not morep))))) -(defmacro defmethod (&rest args) - (multiple-value-bind (name qualifiers lambda-list body) +(defmacro defmethod (name &rest args) + (multiple-value-bind (qualifiers lambda-list body) (parse-defmethod args) `(progn - ;; 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))))) + (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) @@ -353,7 +366,7 @@ bootstrapping. (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 (fboundp name) (gdefinition name)))) @@ -379,7 +392,7 @@ bootstrapping. (defun method-prototype-for-gf (name) (let ((gf? (and (fboundp name) (gdefinition name)))) - (cond ((neq *boot-state* 'complete) nil) + (cond ((neq **boot-state** 'complete) nil) ((or (null gf?) (not (generic-function-p gf?))) ; Someone else MIGHT ; error at load time. @@ -388,6 +401,11 @@ bootstrapping. (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 @@ -395,41 +413,45 @@ bootstrapping. 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)) - (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)))))) + (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))) @@ -524,44 +546,6 @@ bootstrapping. 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)))) - (defun real-make-method-initargs-form (proto-gf proto-method method-lambda initargs env) (declare (ignore proto-gf proto-method)) @@ -604,11 +588,20 @@ bootstrapping. 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))) + ;; 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 sll-decl (cadr method-lambda))) + (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 @@ -730,9 +723,10 @@ bootstrapping. (simple-lexical-method-functions (,lambda-list .method-args. .next-methods. :call-next-method-p - ,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) @@ -746,6 +740,8 @@ bootstrapping. %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))))))))))) @@ -754,7 +750,7 @@ bootstrapping. (declare (ignore env proto-gf proto-method)) (flet ((parse (name) (cond - ((and (eq *boot-state* 'complete) + ((and (eq **boot-state** 'complete) (specializerp name)) name) ((symbolp name) `(find-class ',name)) @@ -863,7 +859,7 @@ bootstrapping. ;; cases by blacklisting them here. -- WHN 2001-01-19 (list 'slot-object #+nil (find-class 'slot-object))) '(ignorable)) - ((not (eq *boot-state* 'complete)) + ((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 @@ -914,7 +910,7 @@ bootstrapping. ;; the user defines a type and calls (SETF ;; FIND-CLASS) in a consistent way. (when (and class (typep class 'built-in-class)) - `(type ,specializer-nameoid ,parameter)))) + `(type ,(class-name class) ,parameter)))) ((:instance nil) (let ((class (specializer-nameoid-class))) (cond @@ -967,7 +963,7 @@ bootstrapping. (defmacro bind-simple-lexical-method-functions ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p - closurep applyp method-cell)) + 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)) @@ -977,33 +973,49 @@ bootstrapping. (,next-methods (cdr ,next-methods))) (declare (ignorable .next-method. ,next-methods)) (flet (,@(and call-next-method-p - `((call-next-method - (&rest 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)))))) + `((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.)))))) + '((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) @@ -1302,37 +1314,37 @@ bootstrapping. ((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* ((all-params (append args (when rest-arg (list rest-arg)))) - (rebindings (when (or setq-p call-next-method-p) - (mapcar (lambda (x) (list x x)) all-params)))) + (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 (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) + `((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)))))) + ,@(when next-method-p-p + `((next-method-p () + (declare (optimize (sb-c:insert-step-conditions 0))) + (not (null ,next-method-call)))))) (let ,rebindings - ,@(when rebindings `((declare (ignorable ,@all-params)))) ,@body))))) ;;; CMUCL comment (Gerd Moellmann): @@ -1351,17 +1363,31 @@ bootstrapping. ;;; 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))) - (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))))) + (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.) @@ -1469,29 +1495,14 @@ bootstrapping. ;; like :LOAD-TOPLEVEL. ((not (listp form)) form) ((eq (car form) 'call-next-method) - (setq call-next-method-p t) + (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)) - ;; 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 - ;; - ;; As of 2006-09-18 modified parameter bindings - ;; are now tracked with more granularity than just - ;; one SETQ-P flag, in order to disable SLOT-VALUE - ;; optimizations for parameters that are SETQd. - ;; The old binary SETQ-P flag is still used for - ;; all other purposes, since as noted above, the - ;; extra cost is minimal. -- JES, 2006-09-18 - ;; ;; 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 @@ -1549,7 +1560,7 @@ bootstrapping. (defun generic-function-name-p (name) (and (legal-fun-name-p name) (fboundp name) - (if (eq *boot-state* 'complete) + (if (eq **boot-state** 'complete) (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) @@ -1579,17 +1590,18 @@ bootstrapping. (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list initargs source-location) - (when (and (eq *boot-state* 'complete) + (when (and (eq **boot-state** 'complete) (fboundp gf-spec)) (let* ((gf (fdefinition gf-spec)) (method (and (generic-function-p gf) (generic-function-methods gf) (find-method gf qualifiers specializers nil)))) (when method - (style-warn 'sb-kernel:redefinition-with-defmethod - :generic-function gf-spec :old-method method - :qualifiers qualifiers :specializers specializers - :new-location source-location)))) + (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 source-location @@ -1721,13 +1733,13 @@ bootstrapping. (defun ensure-generic-function (fun-name &rest all-keys - &key environment source-location + &key environment definition-source &allow-other-keys) (declare (ignore environment)) (let ((existing (and (fboundp fun-name) (gdefinition fun-name)))) (cond ((and existing - (eq *boot-state* 'complete) + (eq **boot-state** 'complete) (null (generic-function-p existing))) (generic-clobbers-function fun-name) (fmakunbound fun-name) @@ -1743,8 +1755,8 @@ bootstrapping. :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) @@ -1756,32 +1768,32 @@ bootstrapping. +slot-unbound+)))) (early-collect-inheritance 'standard-generic-function))) -(defvar *sgf-method-class-index* +(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*) + (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*) + (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 @@ -1827,10 +1839,10 @@ bootstrapping. (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) + (let* ((arg-info (if (eq **boot-state** 'complete) (gf-arg-info gf) (early-gf-arg-info gf))) - (methods (if (eq *boot-state* 'complete) + (methods (if (eq **boot-state** 'complete) (generic-function-methods gf) (early-gf-methods gf))) (was-valid-p (integerp (arg-info-number-optional arg-info))) @@ -1909,21 +1921,19 @@ bootstrapping. ~S." gf-keywords))))))) -(defvar *sm-specializers-index* +(defconstant +sm-specializers-index+ (!bootstrap-slot-index 'standard-method 'specializers)) -(defvar *sm-%function-index* +(defconstant +sm-%function-index+ (!bootstrap-slot-index 'standard-method '%function)) -(defvar *sm-qualifiers-index* +(defconstant +sm-qualifiers-index+ (!bootstrap-slot-index 'standard-method 'qualifiers)) -(defvar *sm-plist-index* - (!bootstrap-slot-index 'standard-method 'plist)) ;;; 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 plist)) - (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s))) +(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) @@ -1931,34 +1941,31 @@ bootstrapping. (!bootstrap-slot-index 'global-writer-method s) (!bootstrap-slot-index 'global-boundp-method s)))) -(define-symbol-macro *standard-method-classes* - (list *the-class-standard-method* *the-class-standard-reader-method* - *the-class-standard-writer-method* *the-class-standard-boundp-method* - *the-class-global-reader-method* *the-class-global-writer-method* - *the-class-global-boundp-method*)) +(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) - (let ((standard-method-classes *standard-method-classes*) - (class (class-of method))) - (if (member class standard-method-classes) - (clos-slots-ref (get-slots method) *sm-specializers-index*) - (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) - (let ((standard-method-classes *standard-method-classes*) - (class (class-of method))) - (if (member class standard-method-classes) - (clos-slots-ref (get-slots method) *sm-%function-index*) - (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) - (let ((standard-method-classes *standard-method-classes*) - (class (class-of method))) - (if (member class standard-method-classes) - (clos-slots-ref (get-slots method) *sm-qualifiers-index*) - (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)) @@ -1971,16 +1978,16 @@ bootstrapping. 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) + (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 (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)) + (or (not (eq **boot-state** 'complete)) (eq (generic-function-method-combination gf) *standard-method-combination*))) (cond ((or (eq class *the-class-standard-reader-method*) @@ -2008,7 +2015,7 @@ bootstrapping. (unless (gf-info-c-a-m-emf-std-p arg-info) (setf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p - (let ((name (if (eq *boot-state* 'complete) + (let ((name (if (eq **boot-state** 'complete) (generic-function-name gf) (!early-gf-name gf)))) (setf (gf-precompute-dfun-and-emf-p arg-info) @@ -2029,7 +2036,7 @@ bootstrapping. ;; remain. (not (find #\Space (symbol-name symbol)))))))))) (setf (gf-info-fast-mf-p arg-info) - (or (not (eq *boot-state* 'complete)) + (or (not (eq **boot-state** 'complete)) (let* ((method-class (generic-function-method-class gf)) (methods (compute-applicable-methods #'make-method-lambda @@ -2057,7 +2064,7 @@ bootstrapping. &key (lambda-list nil lambda-list-p) argument-precedence-order - source-location + definition-source documentation &allow-other-keys) (declare (ignore keys)) @@ -2068,7 +2075,7 @@ bootstrapping. ((assoc spec *!generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order source-location + argument-precedence-order definition-source documentation) (bug "The function ~S is not already defined." spec))) (existing @@ -2077,7 +2084,7 @@ bootstrapping. (t (pushnew spec *!early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order source-location + argument-precedence-order definition-source documentation)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p @@ -2119,12 +2126,12 @@ bootstrapping. (defun safe-gf-dfun-state (generic-function) (if (eq (class-of generic-function) *the-class-standard-generic-function*) - (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*) + (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 (get-slots generic-function) - *sgf-dfun-state-index*) + (setf (clos-slots-ref (fsc-instance-slots generic-function) + +sgf-dfun-state-index+) new-value) (setf (gf-dfun-state generic-function) new-value))) @@ -2133,44 +2140,44 @@ bootstrapping. (list* dfun cache info) dfun))) (cond - ((eq *boot-state* 'complete) + ((eq **boot-state** 'complete) ;; Check that we are under the lock. #+sb-thread - (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf)))) + (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*) + (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) + (let ((state (if (eq **boot-state** 'complete) (safe-gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (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) + (let ((state (if (eq **boot-state** 'complete) (safe-gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (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) + (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) + (let ((methods (if (eq **boot-state** 'complete) (generic-function-methods gf) (early-gf-methods gf)))) (if (null methods) @@ -2201,12 +2208,14 @@ bootstrapping. (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) @@ -2285,7 +2294,7 @@ bootstrapping. (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*) + +sgf-arg-info-index+) (gf-arg-info generic-function))) ;;; FIXME: this function took on a slightly greater role than it @@ -2310,9 +2319,24 @@ bootstrapping. (values (arg-info-applyp arg-info) metatypes arg-info)) - (values (length metatypes) applyp metatypes - (count-if (lambda (x) (neq x t)) 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 &key slot-name object-class method-class-function @@ -2597,14 +2621,13 @@ bootstrapping. ;;; is really implemented. (defun parse-defmethod (cdr-of-form) (declare (list cdr-of-form)) - (let ((name (pop cdr-of-form)) - (qualifiers ()) + (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))))) (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 (generic-function specializers) (declare (list specializers)) @@ -2716,12 +2739,20 @@ bootstrapping. (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