X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fboot.lisp;h=e470eb41ce3b7a6d599642a54b0022af6100622f;hb=e86533e804513080f610795b9d43ca36ad842467;hp=3c9fe4fd72a10911423e7c44352fc62dc120486f;hpb=bbcefe4e494c15084211080537f3eca1b8b1f3f8;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 3c9fe4f..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) @@ -310,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 @@ -706,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 @@ -723,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))))))))))) @@ -954,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) @@ -1302,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): @@ -1345,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.) @@ -1463,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) @@ -1721,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) @@ -2109,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+) @@ -2174,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) @@ -2283,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 @@ -2570,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))