|#
-(declaim (notinline make-a-method
- add-named-method
+(declaim (notinline make-a-method add-named-method
ensure-generic-function-using-class
- add-method
- remove-method))
+ add-method remove-method))
(defvar *!early-functions*
- '((make-a-method early-make-a-method
- real-make-a-method)
- (add-named-method early-add-named-method
- real-add-named-method)
- ))
+ '((make-a-method early-make-a-method real-make-a-method)
+ (add-named-method early-add-named-method real-add-named-method)))
;;; For each of the early functions, arrange to have it point to its
;;; early definition. Do this in a way that makes sure that if we
;;; *!GENERIC-FUNCTION-FIXUPS* is used by !FIX-EARLY-GENERIC-FUNCTIONS
;;; to convert the few functions in the bootstrap which are supposed
;;; to be generic functions but can't be early on.
+;;;
+;;; each entry is a list of name and lambda-list, class names as
+;;; specializers, and method body function name.
(defvar *!generic-function-fixups*
'((add-method
- ((generic-function method) ;lambda-list
- (standard-generic-function method) ;specializers
- real-add-method)) ;method-function
+ ((generic-function method)
+ (standard-generic-function method)
+ real-add-method))
(remove-method
((generic-function method)
(standard-generic-function method)
((proto-generic-function proto-method lambda-expression environment)
(standard-generic-function standard-method t t)
real-make-method-lambda))
+ (make-method-specializers-form
+ ((proto-generic-function proto-method specializer-names environment)
+ (standard-generic-function standard-method t t)
+ real-make-method-specializers-form))
+ (parse-specializer-using-class
+ ((generic-function specializer)
+ (standard-generic-function t)
+ real-parse-specializer-using-class))
+ (unparse-specializer-using-class
+ ((generic-function specializer)
+ (standard-generic-function t)
+ real-unparse-specializer-using-class))
(make-method-initargs-form
((proto-generic-function proto-method
lambda-expression
(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)))
+ (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 &environment env)
+(defmacro defmethod (&rest args)
(multiple-value-bind (name qualifiers lambda-list body)
(parse-defmethod args)
- (multiple-value-bind (proto-gf proto-method)
- (prototypes-for-make-method-lambda name)
- (expand-defmethod name
- proto-gf
- proto-method
- qualifiers
- lambda-list
- body
- env))))
+ `(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)))))
+
+(defmacro %defmethod-expander
+ (name qualifiers lambda-list body &environment env)
+ (multiple-value-bind (proto-gf proto-method)
+ (prototypes-for-make-method-lambda name)
+ (expand-defmethod name proto-gf proto-method qualifiers
+ lambda-list body 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.
(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)))
+ (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
;; generic function has an explicit DEFGENERIC and any typos
;; in DEFMETHODs are warned about. Otherwise
;;
- ;; (DEFGENERIC FOO-BAR-BLETCH ((X T)))
+ ;; (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)) ..)
;; 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
+ ,(make-defmethod-form name qualifiers specializers-form
unspecialized-lambda-list
(if proto-method
(class-name (class-of proto-method))
(consp (setq fn (caddr initargs-form)))
(eq (car fn) 'function)
(consp (setq fn-lambda (cadr fn)))
- (eq (car fn-lambda) 'lambda))
+ (eq (car fn-lambda) 'lambda)
+ (bug "Really got here"))
(let* ((specls (mapcar (lambda (specl)
(if (consp specl)
+ ;; CONSTANT-FORM-VALUE? What I
+ ;; kind of want to know, though,
+ ;; is what happens if we don't do
+ ;; this for some slow-method
+ ;; function because of a hairy
+ ;; lexenv -- is the only bad
+ ;; effect that the method
+ ;; function ends up unnamed? If
+ ;; so, couldn't we arrange to
+ ;; name it later?
`(,(car specl) ,(eval (cadr specl)))
specl))
specializers))
,@(cdddr initargs-form)))))
(make-defmethod-form-internal
name qualifiers
+ specializers
+ #+nil
`(list ,@(mapcar (lambda (specializer)
(if (consp specializer)
``(,',(car specializer)
(sb-c:source-location)))
(defmacro make-method-function (method-lambda &environment env)
- (make-method-function-internal method-lambda env))
-
-(defun make-method-function-internal (method-lambda &optional env)
(multiple-value-bind (proto-gf proto-method)
(prototypes-for-make-method-lambda nil)
(multiple-value-bind (method-function-lambda initargs)
(setf (gdefinition 'make-method-initargs-form)
(symbol-function 'real-make-method-initargs-form)))
+;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular
+;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of
+;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the
+;;; REAL-MAKE-METHOD lambda is used as the body of the default method.
+;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function
+;;; so that changing it in a live image is easy, and changes actually
+;;; take effect.
(defun real-make-method-lambda (proto-gf proto-method method-lambda env)
- (declare (ignore proto-gf proto-method))
- (make-method-lambda-internal method-lambda env))
+ (make-method-lambda-internal proto-gf proto-method method-lambda env))
-;;; a helper function for creating Python-friendly type declarations
-;;; in DEFMETHOD forms
-(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
- (cond ((and (consp specializer)
- (eq (car specializer) 'eql))
- ;; KLUDGE: ANSI, in its wisdom, says that
- ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
- ;; DEFMETHOD expansion time. Thus, although one might think
- ;; that in
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 12))
- ;; ..))
- ;; the PACKAGE and (EQL 12) forms are both parallel type
- ;; names, they're not, as is made clear when you do
- ;; (DEFMETHOD FOO ((X PACKAGE)
- ;; (Y (EQL 'BAR)))
- ;; ..)
- ;; where Y needs to be a symbol named "BAR", not some cons
- ;; made by (CONS 'QUOTE 'BAR). I.e. when the
- ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
- ;; to be of type (EQL X). It'd be easy to transform one to
- ;; the other, but it'd be somewhat messier to do so while
- ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
- ;; once. (The new code wouldn't be messy, but it'd require a
- ;; big transformation of the old code.) So instead we punt.
- ;; -- WHN 20000610
- '(ignorable))
- ((member specializer
- ;; KLUDGE: For some low-level implementation
- ;; classes, perhaps because of some problems related
- ;; to the incomplete integration of PCL into SBCL's
- ;; type system, some specializer classes can't be
- ;; declared as argument types. E.g.
- ;; (DEFMETHOD FOO ((X SLOT-OBJECT))
- ;; (DECLARE (TYPE SLOT-OBJECT X))
- ;; ..)
- ;; loses when
- ;; (DEFSTRUCT BAR A B)
- ;; (FOO (MAKE-BAR))
- ;; perhaps because of the way that STRUCTURE-OBJECT
- ;; inherits both from SLOT-OBJECT and from
- ;; 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
- (list 'slot-object #+nil (find-class 'slot-object)))
- '(ignorable))
- ((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
- ;; 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
- ;; 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
- '(ignorable))
- (t
- ;; Otherwise, we can usually make Python very happy.
- ;;
- ;; 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
- "~@<can't find type for presumed class ~S in ~S.~@:>"
- specializer
- 'parameter-specializer-declaration-in-defmethod)
- '(ignorable)))))
- ((:forthcoming-defclass-type)
- '(ignorable))))))))
+(unless (fboundp 'make-method-lambda)
+ (setf (gdefinition 'make-method-lambda)
+ (symbol-function 'real-make-method-lambda)))
-;;; 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 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 (method-lambda &optional env)
+(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))
(error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~
is not a lambda form."
(sll-decl (get-declaration '%method-lambda-list declarations))
(method-name (when (consp name-decl) (car name-decl)))
(generic-function-name (when method-name (car method-name)))
- (specialized-lambda-list (or sll-decl (cadr method-lambda))))
+ (specialized-lambda-list (or sll-decl (cadr 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
+ ;; between function and initargs, but not something that
+ ;; will be coalesced as a constant (because we are naughty,
+ ;; oh yes) with the expansion of any other methods in the
+ ;; same file. -- CSR, 2007-05-30
+ (method-cell (list (make-symbol "METHOD-CELL"))))
(multiple-value-bind (parameters lambda-list specializers)
(parse-specialized-lambda-list specialized-lambda-list)
(let* ((required-parameters
parameters
specializers))
(slots (mapcar #'list required-parameters))
- (calls (list nil))
(class-declarations
`(declare
;; These declarations seem to be used by PCL to pass
;; 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
(walk-method-lambda method-lambda
required-parameters
env
- slots
- calls)
+ slots)
(multiple-value-bind (walked-lambda-body
walked-declarations
walked-documentation)
(parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
(when (some #'cdr slots)
- (multiple-value-bind (slot-name-lists call-list)
- (slot-name-lists-from-slots slots calls)
+ (let ((slot-name-lists (slot-name-lists-from-slots slots)))
(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)))
+ :slot-name-lists ',slot-name-lists)))
,@walked-lambda-body)))))
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
,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
+ :method-cell ,method-cell
:closurep ,closurep
:applyp ,applyp)
,@walked-declarations
(declare (enable-package-locks
%parameter-binding-modified))
,@walked-lambda-body))))
- `(,@(when plist
- `(plist ,plist))
- ,@(when documentation
- `(:documentation ,documentation)))))))))))
+ `(,@(when call-next-method-p `(method-cell ,method-cell))
+ ,@(when plist `(plist ,plist))
+ ,@(when documentation `(:documentation ,documentation)))))))))))
+
+(defun real-make-method-specializers-form
+ (proto-gf proto-method specializer-names env)
+ (declare (ignore env proto-gf proto-method))
+ (flet ((parse (name)
+ (cond
+ ((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))))))
+ (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)
+ (setf (gdefinition 'make-method-specializers-form)
+ (symbol-function 'real-make-method-specializers-form)))
+
+(defun real-parse-specializer-using-class (generic-function specializer)
+ (let ((result (specializer-from-type specializer)))
+ (if (specializerp result)
+ result
+ (error "~@<~S cannot be parsed as a specializer for ~S.~@:>"
+ specializer generic-function))))
+
+(unless (fboundp 'parse-specializer-using-class)
+ (setf (gdefinition 'parse-specializer-using-class)
+ (symbol-function 'real-parse-specializer-using-class)))
+
+(defun real-unparse-specializer-using-class (generic-function specializer)
+ (if (specializerp specializer)
+ ;; FIXME: this HANDLER-CASE is a bit of a hammer to crack a nut:
+ ;; the idea is that we want to unparse permissively, so that the
+ ;; lazy (or rather the "portable") specializer extender (who
+ ;; does not define methods on these new SBCL-specific MOP
+ ;; functions) can still subclass specializer and define methods
+ ;; without everything going wrong. Making it cleaner and
+ ;; clearer that that is what we are defending against would be
+ ;; nice. -- CSR, 2007-06-01
+ (handler-case
+ (let ((type (specializer-type specializer)))
+ (if (and (consp type) (eq (car type) 'class))
+ (let* ((class (cadr type))
+ (class-name (class-name class)))
+ (if (eq class (find-class class-name nil))
+ class-name
+ type))
+ type))
+ (error () specializer))
+ (error "~@<~S is not a legal specializer for ~S.~@:>"
+ specializer generic-function)))
+
+(unless (fboundp 'unparse-specializer-using-class)
+ (setf (gdefinition 'unparse-specializer-using-class)
+ (symbol-function 'real-unparse-specializer-using-class)))
-(unless (fboundp 'make-method-lambda)
- (setf (gdefinition 'make-method-lambda)
- (symbol-function 'real-make-method-lambda)))
+;;; a helper function for creating Python-friendly type declarations
+;;; 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
+ ;; EQL-SPECIALIZER-FORMs in EQL specializers are evaluated at
+ ;; DEFMETHOD expansion time. Thus, although one might think
+ ;; that in
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 12))
+ ;; ..))
+ ;; the PACKAGE and (EQL 12) forms are both parallel type
+ ;; names, they're not, as is made clear when you do
+ ;; (DEFMETHOD FOO ((X PACKAGE)
+ ;; (Y (EQL 'BAR)))
+ ;; ..)
+ ;; where Y needs to be a symbol named "BAR", not some cons
+ ;; made by (CONS 'QUOTE 'BAR). I.e. when the
+ ;; EQL-SPECIALIZER-FORM is (EQL 'X), it requires an argument
+ ;; to be of type (EQL X). It'd be easy to transform one to
+ ;; the other, but it'd be somewhat messier to do so while
+ ;; ensuring that the EQL-SPECIALIZER-FORM is only EVAL'd
+ ;; once. (The new code wouldn't be messy, but it'd require a
+ ;; big transformation of the old code.) So instead we punt.
+ ;; -- WHN 20000610
+ '(ignorable))
+ ((member specializer
+ ;; KLUDGE: For some low-level implementation
+ ;; classes, perhaps because of some problems related
+ ;; to the incomplete integration of PCL into SBCL's
+ ;; type system, some specializer classes can't be
+ ;; declared as argument types. E.g.
+ ;; (DEFMETHOD FOO ((X SLOT-OBJECT))
+ ;; (DECLARE (TYPE SLOT-OBJECT X))
+ ;; ..)
+ ;; loses when
+ ;; (DEFSTRUCT BAR A B)
+ ;; (FOO (MAKE-BAR))
+ ;; perhaps because of the way that STRUCTURE-OBJECT
+ ;; inherits both from SLOT-OBJECT and from
+ ;; 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
+ (list 'slot-object #+nil (find-class 'slot-object)))
+ '(ignorable))
+ ((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
+ ;; 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))
+ ((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.
+ ;;
+ ;; 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-nameoid
+ (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-nameoid)))
+
+ (flet ((specializer-nameoid-class ()
+ (typecase specializer-nameoid
+ (symbol (find-class specializer-nameoid nil))
+ (class specializer-nameoid)
+ (class-eq-specializer
+ (specializer-class specializer-nameoid))
+ (t nil))))
+ (ecase kind
+ ((:primitive) `(type ,specializer-nameoid ,parameter))
+ ((:defined)
+ (let ((class (specializer-nameoid-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-nameoid ,parameter))))
+ ((:instance nil)
+ (let ((class (specializer-nameoid-class)))
+ (cond
+ (class
+ (if (typep class '(or built-in-class structure-class))
+ `(type ,class ,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
+ "~@<can't find type for specializer ~S in ~S.~@:>"
+ specializer-nameoid
+ '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 ())
(defmacro simple-lexical-method-functions ((lambda-list
method-args
(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))
+ closurep applyp method-cell))
&body body
&environment env)
(if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
,@(if (safe-code-p env)
`((%check-cnm-args cnm-args
,method-args
- ',method-name-declaration))
+ ',method-cell))
nil)
(if .next-method.
(funcall (if (std-instance-p .next-method.)
(or cnm-args ,method-args)
,next-methods)
(apply #'call-no-next-method
- ',method-name-declaration
+ ',method-cell
(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
- (destructuring-bind (name &rest qualifiers-and-specializers) name
- ;; KLUDGE: inefficient traversal, but hey. This should only
- ;; happen on the slow error path anyway.
- (let* ((qualifiers (butlast qualifiers-and-specializers))
- (specializers (car (last qualifiers-and-specializers)))
- (method (find-method (gdefinition name) qualifiers specializers)))
- (apply #'no-next-method
- (method-generic-function method)
- method
- args)))))
+(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)
(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
- pv-cell
+ pv
next-method-call
arg-info)
(defstruct (constant-fast-method-call
(defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
`(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args+rest-arg))
&rest required-args)
(macrolet ((generate-call (n)
``(funcall (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args
,@(loop for x below ,n
(0 ,(generate-call 0))
(1 ,(generate-call 1))
(t (multiple-value-call (fast-method-call-function ,method-call)
- (values (fast-method-call-pv-cell ,method-call))
+ (values (fast-method-call-pv ,method-call))
(values (fast-method-call-next-method-call ,method-call))
,@required-args
(sb-c::%more-arg-values ,more-context 0 ,more-count))))))
(nreq (car arg-info)))
(if restp
(apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
+ (fast-method-call-pv emf)
(fast-method-call-next-method-call emf)
args)
(cond ((null args)
:format-arguments nil)))
(t
(apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
+ (fast-method-call-pv emf)
(fast-method-call-next-method-call emf)
args))))))
(method-call
\f
(defmacro fast-call-next-method-body ((args next-method-call rest-arg)
- method-name-declaration
+ method-cell
cnm-args)
`(if ,next-method-call
,(let ((call `(invoke-narrow-effective-method-function
,cnm-args)
,call)
,call))
- (call-no-next-method ',method-name-declaration
+ (call-no-next-method ',method-cell
,@args
,@(when rest-arg
`(,rest-arg)))))
((args rest-arg next-method-call (&key
call-next-method-p
setq-p
- method-name-declaration
+ method-cell
next-method-p-p
closurep
applyp))
(optimize (sb-c:insert-step-conditions 0)))
,@(if (safe-code-p env)
`((%check-cnm-args cnm-args (list ,@args)
- ',method-name-declaration))
+ ',method-cell))
nil)
(fast-call-next-method-body (,args
,next-method-call
,rest-arg)
- ,method-name-declaration
- cnm-args))))
+ ,method-cell
+ cnm-args))))
,@(when next-method-p-p
`((next-method-p ()
(declare (optimize (sb-c:insert-step-conditions 0)))
;;; 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)
+(defun %check-cnm-args (cnm-args orig-args method-cell)
(when cnm-args
- (let* ((gf (fdefinition (caar method-name-declaration)))
+ (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)
when (eq key keyword)
return tail))
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+(defun walk-method-lambda (method-lambda required-parameters env slots)
(let (;; flag indicating that CALL-NEXT-METHOD should be in the
;; method definition
(call-next-method-p nil)
;; another binding it won't have a %CLASS
;; declaration anymore, and this won't get
;; executed.
- (pushnew var parameters-setqd))))
+ (pushnew var parameters-setqd :test #'eq))))
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(t nil))))
((and (memq (car form)
'(slot-value set-slot-value slot-boundp))
- (constantp (caddr form)))
- (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))))
+ (constantp (caddr form) 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 form slots required-parameters env)))
(t form))))
(let ((walked-lambda (walk-form method-lambda env #'walk-function)))
- (values walked-lambda
+ ;;; FIXME: the walker's rewriting of the source code causes
+ ;;; trouble when doing code coverage. The rewrites should be
+ ;;; removed, and the same operations done using
+ ;;; compiler-macros or tranforms.
+ (values (if (sb-c:policy env (= sb-c:store-coverage-data 0))
+ walked-lambda
+ method-lambda)
call-next-method-p
closurep
next-method-p-p
(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
new-value)
(setf (getf (object-plist method) key default) new-value)))
\f
-(defun load-defmethod
- (class name quals specls ll initargs source-location)
- (setq initargs (copy-tree initargs))
- (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 (class name quals specls ll initargs source-location)
+ (let ((method-cell (getf initargs 'method-cell)))
+ (setq initargs (copy-tree initargs))
+ (when method-cell
+ (setf (getf initargs 'method-cell) method-cell))
+ #+nil
+ (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 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
- (parse-specializers specializers)
- nil))))
+ (find-method gf qualifiers specializers nil))))
(when method
- (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD"
- gf-spec qualifiers specializers))))
+ (style-warn 'sb-kernel:redefinition-with-defmethod
+ :generic-function gf-spec :old-method method
+ :qualifiers qualifiers :specializers specializers
+ :new-location source-location))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
:definition-source source-location
method-class (class-name (class-of method))))
method))
-(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
- `(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
+(defun make-method-spec (gf qualifiers specializers)
+ (let ((name (generic-function-name gf))
+ (unparsed-specializers (unparse-specializers gf specializers)))
+ `(slow-method ,name ,@qualifiers ,unparsed-specializers)))
(defun initialize-method-function (initargs method)
(let* ((mf (getf initargs :function))
(mff (and (typep mf '%method-function)
(%method-function-fast-function mf)))
(plist (getf initargs 'plist))
- (name (getf plist :name)))
+ (name (getf plist :name))
+ (method-cell (getf initargs 'method-cell)))
+ (when method-cell
+ (setf (car method-cell) method))
(when name
(when mf
(setq mf (set-fun-name mf 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)
+ (let ((snl (getf plist :slot-name-lists)))
+ (when snl
(setf (method-plist-value method :pv-table)
- (intern-pv-table :slot-name-lists snl :call-list cl))))))))
+ (intern-pv-table :slot-name-lists snl))))))))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
(when (or allow-other-keys-p old-allowp)
'(&allow-other-keys)))))
*))))
-
-(defun defgeneric-declaration (spec lambda-list)
- `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec))
\f
;;;; early generic function support
(declare (ignore environment))
(let ((existing (and (fboundp fun-name)
(gdefinition fun-name))))
- (if (and existing
- (eq *boot-state* 'complete)
- (null (generic-function-p existing)))
- (generic-clobbers-function fun-name)
- (apply #'ensure-generic-function-using-class
- existing fun-name all-keys))))
+ (cond ((and existing
+ (eq **boot-state** 'complete)
+ (null (generic-function-p existing)))
+ (generic-clobbers-function fun-name)
+ (fmakunbound fun-name)
+ (apply #'ensure-generic-function fun-name all-keys))
+ (t
+ (apply #'ensure-generic-function-using-class
+ existing fun-name all-keys)))))
(defun generic-clobbers-function (fun-name)
- (error 'simple-program-error
- :format-control "~S already names an ordinary function or a macro."
- :format-arguments (list fun-name)))
+ (cerror "Replace the function binding"
+ 'simple-program-error
+ :format-control "~S already names an ordinary function or a macro."
+ :format-arguments (list fun-name)))
(defvar *sgf-wrapper*
(boot-make-wrapper (early-class-size 'standard-generic-function)
+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 'standard-boundp-method s)
+ (!bootstrap-slot-index 'global-reader-method s)
+ (!bootstrap-slot-index 'global-writer-method s)
+ (!bootstrap-slot-index 'global-boundp-method s))))
+
+(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
- (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))))
+ (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
- (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))))
+ (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
- (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))))
+ (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)
(package (symbol-package symbol)))
(and (or (eq package *pcl-package*)
(memq package (package-use-list *pcl-package*)))
+ (not (eq package #.(find-package "CL")))
;; FIXME: this test will eventually be
;; superseded by the *internal-pcl...* test,
;; above. While we are in a process of
;; 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
lambda-list-p)
argument-precedence-order
source-location
+ documentation
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
(make-early-gf spec lambda-list lambda-list-p existing
- argument-precedence-order source-location)
- (error "The function ~S is not already defined." spec)))
+ argument-precedence-order source-location
+ documentation)
+ (bug "The function ~S is not already defined." spec)))
(existing
- (error "~S should be on the list ~S."
- spec
- '*!generic-function-fixups*))
+ (bug "~S should be on the list ~S."
+ spec '*!generic-function-fixups*))
(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 source-location
+ documentation))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
- function argument-precedence-order source-location)
+ function argument-precedence-order source-location
+ documentation)
(let ((fin (allocate-standard-funcallable-instance
*sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-function
has not been set." fin)))))
(setf (gdefinition spec) fin)
(!bootstrap-set-slot 'standard-generic-function fin 'name spec)
- (!bootstrap-set-slot 'standard-generic-function
- fin
- 'source
- source-location)
+ (!bootstrap-set-slot 'standard-generic-function fin
+ 'source source-location)
+ (!bootstrap-set-slot 'standard-generic-function fin
+ '%documentation documentation)
(set-fun-name fin spec)
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(when lambda-list-p
- (proclaim (defgeneric-declaration spec lambda-list))
+ (setf (info :function :type spec)
+ (specifier-type
+ (ftype-declaration-from-lambda-list lambda-list spec))
+ (info :function :where-from spec) :defined-method)
(if argument-precedence-order
(set-arg-info fin
:lambda-list lambda-list
(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)))
(defun set-dfun (gf &optional dfun cache info)
- (when cache
- (setf (cache-owner cache) gf))
(let ((new-state (if (and dfun (or cache info))
(list* dfun cache info)
dfun)))
- (if (eq *boot-state* 'complete)
- (setf (safe-gf-dfun-state gf) new-state)
- (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
- new-state)))
+ (cond
+ ((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))))
+ (setf (safe-gf-dfun-state gf) new-state))
+ (t
+ (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)
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
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (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
- (proclaim (defgeneric-declaration fun-name lambda-list)))))
+ (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
arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
- &key slot-name object-class method-class-function)
+ &key slot-name object-class method-class-function
+ definition-source)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
initargs doc)
(when slot-name
(list :slot-name slot-name :object-class object-class
- :method-class-function method-class-function))))))
+ :method-class-function method-class-function))
+ (list :definition-source definition-source)))))
(initialize-method-function initargs result)
result)))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
- &rest args &key slot-name object-class method-class-function)
- (setq specializers (parse-specializers specializers))
+ &rest args &key slot-name object-class method-class-function
+ definition-source)
(if method-class-function
(let* ((object-class (if (classp object-class) object-class
(find-class object-class)))
(apply #'make-instance
(apply method-class-function object-class slot-definition
initargs)
+ :definition-source definition-source
initargs)))
(apply #'make-instance class :qualifiers qualifiers
:lambda-list lambda-list :specializers specializers
(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)
+(defun early-add-named-method (generic-function-name qualifiers
+ specializers arglist &rest initargs
+ &key documentation definition-source
+ &allow-other-keys)
(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
(dolist (m (early-gf-methods gf))
(when (and (equal (early-method-specializers m) specializers)
(equal (early-method-qualifiers m) qualifiers))
- (return m))))
- (new (make-a-method 'standard-method
- qualifiers
- arglist
- specializers
- initargs
- ())))
- (when existing (remove-method gf existing))
- (add-method gf new)))
+ (return m)))))
+ (setf (getf (getf initargs 'plist) :name)
+ (make-method-spec gf qualifiers specializers))
+ (let ((new (make-a-method 'standard-method qualifiers arglist
+ specializers initargs documentation
+ :definition-source definition-source)))
+ (when existing (remove-method gf existing))
+ (add-method gf new))))
;;; This is the early version of ADD-METHOD. Later this will become a
;;; generic function. See !FIX-EARLY-GENERIC-FUNCTIONS which has
(gf (gdefinition fspec))
(methods (mapcar (lambda (method)
(let* ((lambda-list (first method))
- (specializers (second method))
+ (specializers (mapcar #'find-class (second method)))
(method-fn-name (third method))
(fn-name (or method-fn-name fspec))
(fn (fdefinition fn-name))
(setq spec-ll (pop cdr-of-form))
(values name qualifiers spec-ll cdr-of-form)))
-(defun parse-specializers (specializers)
+(defun parse-specializers (generic-function specializers)
(declare (list specializers))
(flet ((parse (spec)
- (let ((result (specializer-from-type spec)))
- (if (specializerp result)
- result
- (if (symbolp spec)
- (error "~S was used as a specializer,~%~
- but is not the name of a class."
- spec)
- (error "~S is not a legal specializer." spec))))))
+ (parse-specializer-using-class generic-function spec)))
(mapcar #'parse specializers)))
-(defun unparse-specializers (specializers-or-method)
- (if (listp specializers-or-method)
- (flet ((unparse (spec)
- (if (specializerp spec)
- (let ((type (specializer-type spec)))
- (if (and (consp type)
- (eq (car type) 'class))
- (let* ((class (cadr type))
- (class-name (class-name class)))
- (if (eq class (find-class class-name nil))
- class-name
- type))
- type))
- (error "~S is not a legal specializer." spec))))
- (mapcar #'unparse specializers-or-method))
- (unparse-specializers (method-specializers specializers-or-method))))
-
-(defun parse-method-or-spec (spec &optional (errorp t))
- (let (gf method name temp)
- (if (method-p spec)
- (setq method spec
- gf (method-generic-function method)
- temp (and gf (generic-function-name gf))
- name (if temp
- (make-method-spec temp
- (method-qualifiers method)
- (unparse-specializers
- (method-specializers method)))
- (make-symbol (format nil "~S" method))))
- (multiple-value-bind (gf-spec quals specls)
- (parse-defmethod 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)
- (make-list (- nreq (length specls))
- :initial-element
- *the-class-t*)))
- (and
- (setq method (get-method gf quals specls errorp))
- (setq name
- (make-method-spec
- gf-spec quals (unparse-specializers specls))))))))
- (values gf method name)))
+(defun unparse-specializers (generic-function specializers)
+ (declare (list specializers))
+ (flet ((unparse (spec)
+ (unparse-specializer-using-class generic-function spec)))
+ (mapcar #'unparse specializers)))
\f
(defun extract-parameters (specialized-lambda-list)
(multiple-value-bind (parameters ignore1 ignore2)
(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
;;; walker stuff was only used for implementing stuff like that; maybe
;;; it's not needed any more? Hunt down what it was used for and see.
+(defun extract-the (form)
+ (cond ((and (consp form) (eq (car form) 'the))
+ (aver (proper-list-of-length-p form 3))
+ (third form))
+ (t
+ form)))
+
(defmacro with-slots (slots instance &body body)
(let ((in (gensym)))
`(let ((,in ,instance))
(declare (ignorable ,in))
- ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
- (third instance)
- instance)))
+ ,@(let ((instance (extract-the instance)))
(and (symbolp instance)
`((declare (%variable-rebinding ,in ,instance)))))
,in
(let ((in (gensym)))
`(let ((,in ,instance))
(declare (ignorable ,in))
- ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the))
- (third instance)
- instance)))
+ ,@(let ((instance (extract-the instance)))
(and (symbolp instance)
`((declare (%variable-rebinding ,in ,instance)))))
,in
projects / sbcl.git / blobdiff