|#
-(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
(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)
(declare (ignore proto-gf proto-method))
(make-method-lambda-internal method-lambda env))
+(unless (fboundp 'make-method-lambda)
+ (setf (gdefinition 'make-method-lambda)
+ (symbol-function 'real-make-method-lambda)))
+
+(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))))
+ ((prototype) `(fixme))))
+ (t (bug "Foo")))))
+ `(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)))
+
;;; a helper function for creating Python-friendly type declarations
;;; in DEFMETHOD forms
(defun parameter-specializer-declaration-in-defmethod (parameter specializer)
;; 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))))
+ (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 ,parameter))
+ ((:primitive) `(type ,specializer-nameoid ,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.
+ (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 ,parameter))))
+ `(type ,specializer-nameoid ,parameter))))
((:instance nil)
- (let ((class (specializer-class)))
+ (let ((class (specializer-nameoid-class)))
(cond
(class
(if (typep class '(or built-in-class structure-class))
- `(type ,specializer ,parameter)
+ `(type ,class ,parameter)
;; don't declare CLOS classes as parameters;
;; it's too expensive.
'(ignorable)))
;; ...)). 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
+ "~@<can't find type for specializer ~S in ~S.~@:>"
+ specializer-nameoid
'parameter-specializer-declaration-in-defmethod)
'(ignorable)))))
((:forthcoming-defclass-type)
(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
,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)))))))))))
-
-(unless (fboundp 'make-method-lambda)
- (setf (gdefinition 'make-method-lambda)
- (symbol-function 'real-make-method-lambda)))
+ `(,@(when call-next-method-p `(method-cell ,method-cell))
+ ,@(when plist `(plist ,plist))
+ ,@(when documentation `(:documentation ,documentation)))))))))))
(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)
+ (apply #'no-next-method (method-generic-function method)
+ method args)))
(defstruct (method-call (:copier nil))
(function #'identity :type function)
#-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
-(defmacro fmc-funcall (fn pv-cell next-method-call &rest args)
- `(funcall ,fn ,pv-cell ,next-method-call ,@args))
-
-(defmacro invoke-fast-method-call (method-call &rest required-args+rest-arg)
- `(fmc-funcall (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
- (fast-method-call-next-method-call ,method-call)
- ,@required-args+rest-arg))
+;; The two variants of INVOKE-FAST-METHOD-CALL differ in how REST-ARGs
+;; are handled. The first one will get REST-ARG as a single list (as
+;; the last argument), and will thus need to use APPLY. The second one
+;; will get them as a &MORE argument, so we can pass the arguments
+;; directly with MULTIPLE-VALUE-CALL and %MORE-ARG-VALUES.
+
+(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-next-method-call ,method-call)
+ ,@required-args+rest-arg))
+
+(defmacro invoke-fast-method-call/more (method-call
+ more-context
+ more-count
+ &rest required-args)
+ (macrolet ((generate-call (n)
+ ``(funcall (fast-method-call-function ,method-call)
+ (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-next-method-call ,method-call)
+ ,@required-args
+ ,@(loop for x below ,n
+ collect `(sb-c::%more-arg ,more-context ,x)))))
+ ;; The cases with only small amounts of required arguments passed
+ ;; are probably very common, and special-casing speeds them up by
+ ;; a factor of 2 with very little effect on the other
+ ;; cases. Though it'd be nice to have the generic case be equally
+ ;; fast.
+ `(case ,more-count
+ (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-next-method-call ,method-call))
+ ,@required-args
+ (sb-c::%more-arg-values ,more-context 0 ,more-count))))))
(defstruct (fast-instance-boundp (:copier nil))
(index 0 :type fixnum))
(trace-emf-call-internal ,emf ,format ,args))))
(defmacro invoke-effective-method-function-fast
- (emf restp &rest required-args+rest-arg)
+ (emf restp &key required-args rest-arg more-arg)
`(progn
- (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
- (invoke-fast-method-call ,emf ,@required-args+rest-arg)))
+ (trace-emf-call ,emf ,restp (list ,@required-args rest-arg))
+ ,(if more-arg
+ `(invoke-fast-method-call/more ,emf
+ ,@more-arg
+ ,@required-args)
+ `(invoke-fast-method-call ,emf
+ ,restp
+ ,@required-args
+ ,@rest-arg))))
(defun effective-method-optimized-slot-access-clause
- (emf restp required-args+rest-arg)
+ (emf restp required-args)
;; "What," you may wonder, "do these next two clauses do?" In that
;; case, you are not a PCL implementor, for they considered this to
;; be self-documenting.:-| Or CSR, for that matter, since he can
;; conclude that setting EMF to a FIXNUM is an optimized way to
;; represent these slot access operations.
(when (not restp)
- (let ((length (length required-args+rest-arg)))
+ (let ((length (length required-args)))
(cond ((= 1 length)
`((fixnum
(let* ((.slots. (get-slots-or-nil
- ,(car required-args+rest-arg)))
+ ,(car required-args)))
(value (when .slots. (clos-slots-ref .slots. ,emf))))
(if (eq value +slot-unbound+)
- (slot-unbound-internal ,(car required-args+rest-arg)
+ (slot-unbound-internal ,(car required-args)
,emf)
value)))))
((= 2 length)
`((fixnum
- (let ((.new-value. ,(car required-args+rest-arg))
+ (let ((.new-value. ,(car required-args))
(.slots. (get-slots-or-nil
- ,(cadr required-args+rest-arg))))
+ ,(cadr required-args))))
(when .slots.
(setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
;;; to make less work for the compiler we take a path that doesn't
;;; involve the slot-accessor clause (where EMF is a FIXNUM) at all.
(macrolet ((def (name &optional narrow)
- `(defmacro ,name (emf restp &rest required-args+rest-arg)
+ `(defmacro ,name (emf restp &key required-args rest-arg more-arg)
(unless (constantp restp)
(error "The RESTP argument is not constant."))
(setq restp (constant-form-value restp))
`(locally
(declare (optimize (sb-c:insert-step-conditions 0)))
(let ((,emf-n ,emf))
- (trace-emf-call ,emf-n ,restp (list ,@required-args+rest-arg))
+ (trace-emf-call ,emf-n ,restp (list ,@required-args ,@rest-arg))
(etypecase ,emf-n
(fast-method-call
- (invoke-fast-method-call ,emf-n ,@required-args+rest-arg))
+ ,(if more-arg
+ `(invoke-fast-method-call/more ,emf-n
+ ,@more-arg
+ ,@required-args)
+ `(invoke-fast-method-call ,emf-n
+ ,restp
+ ,@required-args
+ ,@rest-arg)))
,@,(unless narrow
`(effective-method-optimized-slot-access-clause
- emf-n restp required-args+rest-arg))
+ emf-n restp required-args))
(method-call
- (invoke-method-call ,emf-n ,restp ,@required-args+rest-arg))
+ (invoke-method-call ,emf-n ,restp ,@required-args
+ ,@rest-arg))
(function
,(if restp
- `(apply ,emf-n ,@required-args+rest-arg)
- `(funcall ,emf-n ,@required-args+rest-arg))))))))))
+ `(apply ,emf-n ,@required-args ,@rest-arg)
+ `(funcall ,emf-n ,@required-args
+ ,@rest-arg))))))))))
(def invoke-effective-method-function nil)
(def invoke-narrow-effective-method-function t))
(restp (cdr arg-info))
(nreq (car arg-info)))
(if restp
- (let* ((rest-args (nthcdr nreq args))
- (req-args (ldiff args rest-args)))
- (apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
- (fast-method-call-next-method-call emf)
- (nconc req-args (list rest-args))))
+ (apply (fast-method-call-function emf)
+ (fast-method-call-pv-cell emf)
+ (fast-method-call-next-method-call emf)
+ args)
(cond ((null args)
(if (eql nreq 0)
- (invoke-fast-method-call emf)
+ (invoke-fast-method-call emf nil)
(error 'simple-program-error
:format-control "invalid number of arguments: 0"
:format-arguments nil)))
((null (cdr args))
(if (eql nreq 1)
- (invoke-fast-method-call emf (car args))
+ (invoke-fast-method-call emf nil (car args))
(error 'simple-program-error
:format-control "invalid number of arguments: 1"
:format-arguments nil)))
((null (cddr args))
(if (eql nreq 2)
- (invoke-fast-method-call emf (car args) (cadr args))
+ (invoke-fast-method-call emf nil (car args) (cadr args))
(error 'simple-program-error
:format-control "invalid number of arguments: 2"
:format-arguments nil)))
\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
,next-method-call
,(not (null rest-arg))
- ,@args
- ,@(when rest-arg `(,rest-arg)))))
+ :required-args ,args
+ :rest-arg ,(when rest-arg (list rest-arg)))))
`(if ,cnm-args
(bind-args ((,@args
,@(when rest-arg
,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)
(pop ,args-tail)
,(cadr var)))))
(t
- `((,(caddr var) ,args-tail)
+ `((,(caddr var) (not (null ,args-tail)))
(,(car var) (if ,args-tail
(pop ,args-tail)
,(cadr var)))))))
(car var)))
`((,key (get-key-arg-tail ',keyword
,args-tail))
- (,(caddr var) ,key)
+ (,(caddr var) (not (null,key)))
(,variable (if ,key
(car ,key)
,(cadr var))))))))
(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
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
(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))))
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)))
(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)
(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)))
+ (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
(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)
(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))
(if method-class-function
(let* ((object-class (if (classp object-class) object-class
(find-class object-class)))
(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)
(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 ())))
+ (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)