X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=e470eb41ce3b7a6d599642a54b0022af6100622f;hb=d7cbe5c40e93796d326937f3fb962fa4d7b1fa85;hp=d77709b1e901c7792bcfa7d116d691c271353e94;hpb=8f2883a6a64e8116ecddba619de2250e0e236efd;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index d77709b..e470eb4 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,8 +318,8 @@ 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 @@ -705,7 +714,7 @@ 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 @@ -722,6 +731,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))))))))))) @@ -953,25 +964,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) @@ -1301,31 +1312,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): @@ -1344,17 +1354,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.) @@ -1462,7 +1486,9 @@ 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) @@ -1562,10 +1588,11 @@ bootstrapping. (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 @@ -1719,8 +1746,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) @@ -2107,7 +2134,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+) @@ -2172,12 +2199,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) @@ -2281,9 +2310,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 @@ -2568,14 +2612,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))