(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 "~@<Invalid declaration specifier in ~
+ DEFGENERIC: ~S~:@>"
+ :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))
(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)
(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))
;; belong here!
(aver (not morep)))))
\f
-(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)
(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))))
(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.
(class-prototype (or (generic-function-method-class gf?)
(find-class 'standard-method)))))))
\f
+;;; 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
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)))
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))
(setf (gdefinition 'make-method-lambda)
(symbol-function 'real-make-method-lambda)))
+(defun declared-specials (declarations)
+ (loop for (declare . specifiers) in declarations
+ append (loop for specifier in specifiers
+ when (eq 'special (car specifier))
+ append (cdr specifier))))
+
(defun make-method-lambda-internal (proto-gf proto-method method-lambda env)
(declare (ignore proto-gf proto-method))
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
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
;; KLUDGE: when I tried moving these to
;; ADD-METHOD-DECLARATIONS, things broke. No idea
;; why. -- CSR, 2004-06-16
- ,@(mapcar #'parameter-specializer-declaration-in-defmethod
- parameters
- specializers)))
+ ,@(let ((specials (declared-specials declarations)))
+ (mapcar (lambda (par spec)
+ (parameter-specializer-declaration-in-defmethod
+ par spec specials env))
+ parameters
+ specializers))))
(method-lambda
;; Remove the documentation string and insert the
;; appropriate class declarations. The documentation
(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)
%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)))))))))))
(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))
((consp name) (ecase (car name)
((eql) `(intern-eql-specializer ,(cadr name)))
- ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))
- ((prototype) `(fixme))))
- (t (bug "Foo")))))
+ ((class-eq) `(class-eq-specializer (find-class ',(cadr name))))))
+ (t
+ ;; FIXME: Document CLASS-EQ specializers.
+ (error 'simple-reference-error
+ :format-control
+ "~@<~S is not a valid parameter specializer name.~@:>"
+ :format-arguments (list name)
+ :references (list '(:ansi-cl :macro defmethod)
+ '(:ansi-cl :glossary "parameter specializer name")))))))
`(list ,@(mapcar #'parse specializer-names))))
(unless (fboundp 'make-method-specializers-form)
(symbol-function 'real-unparse-specializer-using-class)))
;;; a helper function for creating Python-friendly type declarations
-;;; in DEFMETHOD forms
-(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
+;;; in DEFMETHOD forms.
+;;;
+;;; We're too lazy to cons up a new environment for this, so we just pass in
+;;; the list of locally declared specials in addition to the old environment.
+(defun parameter-specializer-declaration-in-defmethod
+ (parameter specializer specials env)
(cond ((and (consp specializer)
(eq (car specializer) 'eql))
;; KLUDGE: ANSI, in its wisdom, says that
;; 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
'(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
- ;; there.
- ;;
- ;; FIXME: It would be better to detect the SETQ earlier and
- ;; skip declarations for specials only when needed, not
- ;; always.
- ;;
- ;; --NS 2004-10-14
+ ((or (var-special-p parameter env) (member parameter specials))
+ ;; Don't declare types for special variables -- our rebinding magic
+ ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE),
+ ;; etc. make things undecidable.
'(ignorable))
(t
;; Otherwise, we can usually make Python very happy.
;; 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
(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))
(,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)
((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):
;;; 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 "~@<The set of methods ~S applicable to argument~P ~
- ~{~S~^, ~} to call-next-method is different from ~
- the set of methods ~S applicable to the original ~
- method argument~P ~{~S~^, ~}.~@:>"
- 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 "~@<The set of methods ~S applicable to argument~P ~
+ ~{~S~^, ~} to call-next-method is different from ~
+ the set of methods ~S applicable to the original ~
+ method argument~P ~{~S~^, ~}.~@:>"
+ 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.)
;; 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
(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)))))
\f
(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
(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)
: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)
+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
(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)))
~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)
(!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))
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*)
(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)
;; 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
&key (lambda-list nil
lambda-list-p)
argument-precedence-order
- source-location
+ definition-source
documentation
&allow-other-keys)
(declare (ignore keys))
((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
(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
(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)))
(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)
(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)
method-class)
(t (find-class method-class t ,env))))))))
+(defun note-gf-signature (fun-name lambda-list-p lambda-list)
+ (unless lambda-list-p
+ ;; Use the existing lambda-list, if any. It is reasonable to do eg.
+ ;;
+ ;; (if (fboundp name)
+ ;; (ensure-generic-function name)
+ ;; (ensure-generic-function name :lambda-list '(foo)))
+ ;;
+ ;; in which case we end up here with no lambda-list in the first leg.
+ (setf (values lambda-list lambda-list-p)
+ (handler-case
+ (values (generic-function-lambda-list (fdefinition fun-name))
+ t)
+ ((or warning error) ()
+ (values nil nil)))))
+ (let ((gf-type
+ (specifier-type
+ (if lambda-list-p
+ (ftype-declaration-from-lambda-list lambda-list fun-name)
+ 'function)))
+ (old-type nil))
+ ;; FIXME: Ideally we would like to not clobber it, but because generic
+ ;; functions assert their FTYPEs callers believing the FTYPE are left with
+ ;; unsafe assumptions. Hence the clobbering. Be quiet when the new type
+ ;; is a subtype of the old one, though -- even though the type is not
+ ;; trusted anymore, the warning is still not quite as interesting.
+ (when (and (eq :declared (info :function :where-from fun-name))
+ (not (csubtypep gf-type (setf old-type (info :function :type fun-name)))))
+ (style-warn "~@<Generic function ~S clobbers an earlier ~S proclamation ~S ~
+ for the same name with ~S.~:@>"
+ fun-name 'ftype
+ (type-specifier old-type)
+ (type-specifier gf-type)))
+ (setf (info :function :type fun-name) gf-type
+ (info :function :where-from fun-name) :defined-method)
+ fun-name))
+
(defun real-ensure-gf-using-class--generic-function
(existing
fun-name
(change-class existing generic-function-class))
(prog1
(apply #'reinitialize-instance existing all-keys)
- (when lambda-list-p
- (setf (info :function :type fun-name)
- (specifier-type
- (ftype-declaration-from-lambda-list lambda-list fun-name))
- (info :function :where-from fun-name) :defined-method))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
(defun real-ensure-gf-using-class--null
(existing
(setf (gdefinition fun-name)
(apply #'make-instance generic-function-class
:name fun-name all-keys))
- (when lambda-list-p
- (setf (info :function :type fun-name)
- (specifier-type
- (ftype-declaration-from-lambda-list lambda-list fun-name))
- (info :function :where-from fun-name) :defined-method))))
+ (note-gf-signature fun-name lambda-list-p lambda-list)))
\f
(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
(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
;;; 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))
(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)))))))
\f
-(setq *boot-state* 'early)
+(setq **boot-state** 'early)
\f
;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET
;;; which used %WALKER stuff. That suggests to me that maybe the code
(defun extract-the (form)
(cond ((and (consp form) (eq (car form) 'the))
- (aver (proper-list-of-length-p 3))
+ (aver (proper-list-of-length-p form 3))
(third form))
(t
form)))
projects / sbcl.git / blobdiff