X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=66d26ef965ec4e45f1e4710f559eec23f41ae393;hb=4f8f4b25cb564509437d8fc26038143150077f14;hp=8cc6e51f7d850c070a6ec2b51fb52af5dfc9f2c0;hpb=3a2e34d8ed1293f2cecb5c2c6ea359b622e3f4f8;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 8cc6e51..66d26ef 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -227,7 +227,8 @@ bootstrapping. `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (compile-or-load-defgeneric ',fun-name)) - (load-defgeneric ',fun-name ',lambda-list ,@initargs) + (load-defgeneric ',fun-name ',lambda-list + (sb-c:source-location) ,@initargs) ,@(mapcar #'expand-method-definition methods) (fdefinition ',fun-name))))) @@ -239,7 +240,7 @@ bootstrapping. (setf (info :function :type fun-name) (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) (let ((fun (fdefinition fun-name))) @@ -250,7 +251,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 @@ -313,7 +314,7 @@ bootstrapping. (defun prototypes-for-make-method-lambda (name) (if (not (eq *boot-state* 'complete)) (values nil nil) - (let ((gf? (and (gboundp name) + (let ((gf? (and (fboundp name) (gdefinition name)))) (if (or (null gf?) (not (generic-function-p gf?))) @@ -335,7 +336,7 @@ bootstrapping. ;;; ;;; Note: During bootstrapping, this function is allowed to return NIL. (defun method-prototype-for-gf (name) - (let ((gf? (and (gboundp name) + (let ((gf? (and (fboundp name) (gdefinition name)))) (cond ((neq *boot-state* 'complete) nil) ((or (null gf?) @@ -387,16 +388,14 @@ bootstrapping. (if proto-method (class-name (class-of proto-method)) 'standard-method) - initargs-form - (getf (getf initargs :plist) - :pv-table-symbol))))))) + 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) (if (and (interned-symbol-p (fun-name-block-name name)) @@ -405,7 +404,7 @@ bootstrapping. (if (consp s) (and (eq (car s) 'eql) (constantp (cadr s)) - (let ((sv (eval (cadr s)))) + (let ((sv (constant-form-value (cadr s)))) (or (interned-symbol-p sv) (integerp sv) (and (characterp sv) @@ -414,7 +413,7 @@ bootstrapping. specializers) (consp initargs-form) (eq (car initargs-form) 'list*) - (memq (cadr initargs-form) '(:function :fast-function)) + (memq (cadr initargs-form) '(:function)) (consp (setq fn (caddr initargs-form))) (eq (car fn) 'function) (consp (setq fn-lambda (cadr fn))) @@ -435,8 +434,7 @@ bootstrapping. unspecialized-lambda-list method-class-name `(list* ,(cadr initargs-form) #',mname - ,@(cdddr initargs-form)) - pv-table-symbol))) + ,@(cdddr initargs-form))))) (make-defmethod-form-internal name qualifiers `(list ,@(mapcar (lambda (specializer) @@ -447,12 +445,11 @@ bootstrapping. specializers)) unspecialized-lambda-list method-class-name - initargs-form - pv-table-symbol)))) + 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 @@ -460,11 +457,7 @@ 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)) @@ -580,7 +573,7 @@ bootstrapping. ;; 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)) + (list 'slot-object #+nil (find-class 'slot-object))) '(ignorable)) ((not (eq *boot-state* 'complete)) ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with @@ -589,6 +582,8 @@ bootstrapping. ;; 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)) ((var-globally-special-p parameter) ;; KLUDGE: Don't declare types for global special variables ;; -- our rebinding magic for SETQ cases don't work right @@ -602,39 +597,65 @@ bootstrapping. '(ignorable)) (t ;; Otherwise, we can usually make Python very happy. - (let ((kind (info :type :kind specializer))) - (ecase kind - ((:primitive) `(type ,specializer ,parameter)) - ((:defined) - (let ((class (find-class specializer nil))) - ;; 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 ,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))))))) + ;; + ;; 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 (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))) + + (flet ((specializer-class () + (if (typep specializer 'class) + specializer + (find-class specializer nil)))) + (ecase kind + ((:primitive) `(type ,specializer ,parameter)) + ((:defined) + (let ((class (specializer-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 ,specializer ,parameter)))) + ((:instance nil) + (let ((class (specializer-class))) + (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)))))))) + +;;; 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 ()) (defun make-method-lambda-internal (method-lambda &optional env) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) @@ -711,7 +732,7 @@ bootstrapping. (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) (constant-value (and constant-value-p - (eval (car real-body)))) + (constant-form-value (car real-body)))) (plist (and constant-value-p (or (typep constant-value '(or number character)) @@ -725,7 +746,8 @@ bootstrapping. (return nil)))))) (multiple-value-bind (walked-lambda call-next-method-p closurep - next-method-p-p setq-p) + next-method-p-p setq-p + parameters-setqd) (walk-method-lambda method-lambda required-parameters env @@ -736,53 +758,59 @@ bootstrapping. 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)))))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@(when call-list + `(:call-list ,call-list)) + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters + ,slot-name-lists + (load-time-value + (intern-pv-table + :slot-name-lists ',slot-name-lists + :call-list ',call-list))) + ,@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)))) + (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)) + (,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 + (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 plist - `(:plist ,plist)) + `(plist ,plist)) ,@(when documentation - `(:documentation ,documentation))))))))))) + `(:documentation ,documentation))))))))))) (unless (fboundp 'make-method-lambda) (setf (gdefinition 'make-method-lambda) @@ -795,10 +823,10 @@ bootstrapping. &body body) `(progn ,method-args ,next-methods - (bind-simple-lexical-method-macros (,method-args ,next-methods) - (bind-lexical-method-functions (,@lmf-options) + (bind-simple-lexical-method-functions (,method-args ,next-methods + ,lmf-options) (bind-args (,lambda-list ,method-args) - ,@body))))) + ,@body)))) (defmacro fast-lexical-method-functions ((lambda-list next-method-call @@ -806,34 +834,42 @@ bootstrapping. 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)) + `(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 + closurep applyp method-name-declaration)) + &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) + ,@(if (safe-code-p env) + `((%check-cnm-args cnm-args + ,method-args + ',method-name-declaration)) + 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-name-declaration + (or cnm-args ,method-args)))))) + ,@(and next-method-p-p + '((next-method-p () + (not (null .next-method.)))))) + ,@body)))) (defun call-no-next-method (method-name-declaration &rest args) (destructuring-bind (name) method-name-declaration @@ -851,6 +887,8 @@ bootstrapping. (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)) @@ -874,6 +912,9 @@ bootstrapping. pv-cell 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)) @@ -939,58 +980,70 @@ bootstrapping. (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)))))))) +(defun effective-method-optimized-slot-access-clause + (emf restp 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 (not restp) + (let ((length (length required-args+rest-arg))) + (cond ((= 1 length) + `((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))))) + ((= 2 length) + `((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) + ))) + +;;; 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 &rest required-args+rest-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 + (invoke-fast-method-call ,emf-n ,@required-args+rest-arg)) + ,@,(unless narrow + `(effective-method-optimized-slot-access-clause + emf-n restp required-args+rest-arg)) + (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) @@ -1061,108 +1114,92 @@ bootstrapping. (function (apply emf args)))) -(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) - &body body) + +(defmacro fast-call-next-method-body ((args next-method-call rest-arg) + method-name-declaration + cnm-args) + `(if ,next-method-call + ,(let ((call `(invoke-narrow-effective-method-function + ,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)) + (call-no-next-method ',method-name-declaration + ,@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 + method-name-declaration + next-method-p-p + closurep + applyp)) + &body body + &environment env) (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)))))) + (rebindings (when (or setq-p call-next-method-p) + (mapcar (lambda (x) (list x x)) all-params)))) + (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-name-declaration)) + nil) + (fast-call-next-method-body (,args + ,next-method-call + ,rest-arg) + ,method-name-declaration + 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 + ,@(when rebindings `((declare (ignorable ,@all-params)))) + ,@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-name-declaration) + (when cnm-args + (let* ((gf (fdefinition (caar method-name-declaration))) + (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.) @@ -1249,13 +1286,18 @@ bootstrapping. 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)) + (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 @@ -1279,7 +1321,34 @@ bootstrapping. ;; 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) + ;; + ;; 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 + ;; 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)))) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) @@ -1294,23 +1363,14 @@ bootstrapping. ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) (constantp (caddr form))) - (let ((parameter (can-optimize-access form - required-parameters - env))) + (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)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) @@ -1318,82 +1378,39 @@ bootstrapping. call-next-method-p closurep next-method-p-p - setq-p))))) + (not (null parameters-setqd)) + parameters-setqd))))) (defun generic-function-name-p (name) (and (legal-fun-name-p name) - (gboundp 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) + (class name quals specls ll initargs source-location) (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) - (load-defmethod-internal class name quals specls - ll initargs pv-table-symbol))) + (setf (getf (getf initargs 'plist) :name) + (make-method-spec name quals specls)) + (load-defmethod-internal class name quals specls + 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)) + initargs source-location) (when (and (eq *boot-state* 'complete) (fboundp gf-spec)) (let* ((gf (fdefinition gf-spec)) @@ -1408,10 +1425,7 @@ bootstrapping. gf-spec qualifiers specializers)))) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list - :definition-source `((defmethod ,gf-spec - ,@qualifiers - ,specializers) - ,*load-pathname*) + :definition-source source-location initargs))) (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) @@ -1429,40 +1443,25 @@ bootstrapping. (defun make-method-spec (gf-spec qualifiers unparsed-specializers) `(slow-method ,gf-spec ,@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 + (mff (and (typep mf '%method-function) + (%method-function-fast-function mf))) + (plist (getf initargs 'plist)) + (name (getf plist :name))) + (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)) (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))))))) + (setf (method-plist-value method :pv-table) + (intern-pv-table :slot-name-lists snl :call-list cl)))))))) (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? @@ -1554,10 +1553,10 @@ bootstrapping. (defun ensure-generic-function (fun-name &rest all-keys - &key environment + &key environment source-location &allow-other-keys) (declare (ignore environment)) - (let ((existing (and (gboundp fun-name) + (let ((existing (and (fboundp fun-name) (gdefinition fun-name)))) (if (and existing (eq *boot-state* 'complete) @@ -1599,6 +1598,11 @@ bootstrapping. (defmacro early-gf-methods (gf) `(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* (!bootstrap-slot-index 'standard-generic-function 'arg-info)) @@ -1733,6 +1737,60 @@ bootstrapping. ~S." gf-keywords))))))) +(defvar *sm-specializers-index* + (!bootstrap-slot-index 'standard-method 'specializers)) +(defvar *sm-%function-index* + (!bootstrap-slot-index 'standard-method '%function)) +(defvar *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))) + (!bootstrap-slot-index 'standard-reader-method s) + (!bootstrap-slot-index 'standard-writer-method s) + (!bootstrap-slot-index 'standard-boundp-method s)))) + +(defun safe-method-specializers (method) + (let ((standard-method-classes + (list *the-class-standard-method* + *the-class-standard-reader-method* + *the-class-standard-writer-method* + *the-class-standard-boundp-method*)) + (class (class-of method))) + (if (member class standard-method-classes) + (clos-slots-ref (get-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 + (list *the-class-standard-method* + *the-class-standard-reader-method* + *the-class-standard-writer-method* + *the-class-standard-boundp-method*)) + (class (class-of method))) + (if (member class standard-method-classes) + (clos-slots-ref (get-slots method) *sm-%function-index*) + (method-function method)))) +(defun safe-method-qualifiers (method) + (let ((standard-method-classes + (list *the-class-standard-method* + *the-class-standard-reader-method* + *the-class-standard-writer-method* + *the-class-standard-boundp-method*)) + (class (class-of method))) + (if (member class standard-method-classes) + (clos-slots-ref (get-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))) @@ -1746,21 +1804,25 @@ bootstrapping. (dolist (method (if new-method (list new-method) methods)) (let* ((specializers (if (or (eq *boot-state* 'complete) (not (consp method))) - (method-specializers 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 ((eq class *the-class-standard-reader-method*) - 'reader) - ((eq class *the-class-standard-writer-method*) - 'writer) - ((eq class *the-class-standard-boundp-method*) - 'boundp))))) + (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) @@ -1825,6 +1887,7 @@ bootstrapping. &key (lambda-list nil lambda-list-p) argument-precedence-order + source-location &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -1834,7 +1897,7 @@ bootstrapping. ((assoc spec *!generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order) + argument-precedence-order source-location) (error "The function ~S is not already defined." spec))) (existing (error "~S should be on the list ~S." @@ -1843,11 +1906,12 @@ bootstrapping. (t (pushnew spec *!early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order)))) + argument-precedence-order source-location)))) (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) + (let ((fin (allocate-standard-funcallable-instance + *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin (or function @@ -1864,7 +1928,7 @@ bootstrapping. (!bootstrap-set-slot 'standard-generic-function fin 'source - *load-pathname*) + source-location) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) @@ -1877,6 +1941,17 @@ bootstrapping. (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 (get-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*) + 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)) @@ -1884,14 +1959,14 @@ bootstrapping. (list* dfun cache info) dfun))) (if (eq *boot-state* 'complete) - (setf (gf-dfun-state gf) new-state) + (setf (safe-gf-dfun-state gf) new-state) (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) + (safe-gf-dfun-state gf) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) @@ -1899,7 +1974,7 @@ bootstrapping. (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) + (safe-gf-dfun-state gf) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) @@ -1939,6 +2014,12 @@ bootstrapping. (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.))) @@ -1950,18 +2031,21 @@ bootstrapping. (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 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) + (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) @@ -1984,12 +2068,30 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name 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))) + (safe-gf-arg-info gf))) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes @@ -1999,8 +2101,7 @@ bootstrapping. arg-info))) (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) (let ((parsed ()) (unparsed ())) ;; Figure out whether we got class objects or class names as the @@ -2018,37 +2119,56 @@ bootstrapping. 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)))) + (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)))))) + (initialize-method-function initargs result) + result))) (defun real-make-a-method (class qualifiers lambda-list specializers initargs doc - &optional slot-name) + &rest args &key slot-name object-class method-class-function) (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)) + (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) + 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,7 +2183,7 @@ bootstrapping. (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 @@ -2087,21 +2207,31 @@ bootstrapping. (setf (fourth early-method) (mapcar #'find-class (cadddr (fifth early-method)))))) (t - (cadddr (fifth early-method)))) + (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))) + (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) - (let* ((gf (ensure-generic-function generic-function-name)) + (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) @@ -2305,7 +2435,7 @@ bootstrapping. (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)) + (and (setq gf (and (or errorp (fboundp gf-spec)) (gdefinition gf-spec))) (let ((nreq (compute-discriminating-function-arglist-info gf))) (setq specls (append (parse-specializers specls)