X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=6a8cc46530860db01941637dde7ebab75f994198;hb=0e3c4b4db102bd204a30402d7e5a0de44aea57ce;hp=17de4a435af1067578a32d6906e4538551abff40;hpb=503ad9d8685b335a69dc667dec4ce48f1a03af98;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 17de4a4..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) @@ -310,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) @@ -580,8 +592,13 @@ bootstrapping. ;; 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* + (specialized-lambda-list (or method-lambda-list (ecase (car method-lambda) (lambda (second method-lambda)) (named-lambda (third method-lambda))))) @@ -956,25 +973,25 @@ 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) @@ -1304,31 +1321,30 @@ bootstrapping. 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): @@ -1347,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.) @@ -1725,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) @@ -2113,7 +2143,7 @@ bootstrapping. ((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+) @@ -2178,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) @@ -2287,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 @@ -2574,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))