`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(compile-or-load-defgeneric ',fun-name))
- (load-defgeneric ',fun-name ',lambda-list ,@initargs)
+ (load-defgeneric ',fun-name ',lambda-list
+ (sb-c:source-location) ,@initargs)
,@(mapcar #'expand-method-definition methods)
(fdefinition ',fun-name)))))
(setf (info :function :type fun-name)
(specifier-type 'function))))
-(defun load-defgeneric (fun-name lambda-list &rest initargs)
+(defun load-defgeneric (fun-name lambda-list source-location &rest initargs)
(when (fboundp fun-name)
(style-warn "redefining ~S in DEFGENERIC" fun-name)
(let ((fun (fdefinition fun-name)))
(apply #'ensure-generic-function
fun-name
:lambda-list lambda-list
- :definition-source `((defgeneric ,fun-name) ,*load-pathname*)
+ :definition-source source-location
initargs))
(define-condition generic-function-lambda-list-error
(defun prototypes-for-make-method-lambda (name)
(if (not (eq *boot-state* 'complete))
(values nil nil)
- (let ((gf? (and (gboundp name)
+ (let ((gf? (and (fboundp name)
(gdefinition name))))
(if (or (null gf?)
(not (generic-function-p gf?)))
;;;
;;; Note: During bootstrapping, this function is allowed to return NIL.
(defun method-prototype-for-gf (name)
- (let ((gf? (and (gboundp name)
+ (let ((gf? (and (fboundp name)
(gdefinition name))))
(cond ((neq *boot-state* 'complete) nil)
((or (null gf?)
(if (consp s)
(and (eq (car s) 'eql)
(constantp (cadr s))
- (let ((sv (eval (cadr s))))
+ (let ((sv (constant-form-value (cadr s))))
(or (interned-symbol-p sv)
(integerp sv)
(and (characterp sv)
;; addition to in the list. FIXME: We should no longer need to do
;; this, since the CLOS code is now SBCL-specific, and doesn't
;; need to be ported to every buggy compiler in existence.
- ',pv-table-symbol))
+ ',pv-table-symbol
+ (sb-c:source-location)))
(defmacro make-method-function (method-lambda &environment env)
(make-method-function-internal method-lambda env))
'(ignorable))
(t
;; Otherwise, we can usually make Python very happy.
- (let ((kind (info :type :kind specializer)))
- (ecase kind
- ((:primitive) `(type ,specializer ,parameter))
- ((:defined)
- (let ((class (find-class specializer nil)))
- ;; CLASS can be null here if the user has erroneously
- ;; tried to use a defined type as a specializer; it
- ;; can be a non-BUILT-IN-CLASS if the user defines a
- ;; type and calls (SETF FIND-CLASS) in a consistent
- ;; way.
- (when (and class (typep class 'built-in-class))
- `(type ,specializer ,parameter))))
- ((:instance nil)
- (let ((class (find-class specializer nil)))
- (cond
- (class
- (if (typep class '(or built-in-class structure-class))
- `(type ,specializer ,parameter)
- ;; don't declare CLOS classes as parameters;
- ;; it's too expensive.
- '(ignorable)))
- (t
- ;; we can get here, and still not have a failure
- ;; case, by doing MOP programming like (PROGN
- ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
- ;; ...)). Best to let the user know we haven't
- ;; been able to extract enough information:
- (style-warn
- "~@<can't find type for presumed class ~S in ~S.~@:>"
- specializer
- 'parameter-specializer-declaration-in-defmethod)
- '(ignorable)))))
- ((:forthcoming-defclass-type) '(ignorable)))))))
+ ;;
+ ;; KLUDGE: Since INFO doesn't work right for class objects here,
+ ;; and they are valid specializers, see if the specializer is
+ ;; a named class, and use the name in that case -- otherwise
+ ;; the class instance is ok, since info will just return NIL, NIL.
+ ;;
+ ;; We still need to deal with the class case too, but at
+ ;; least #.(find-class 'integer) and integer as equivalent
+ ;; specializers with this.
+ (let* ((specializer (if (and (typep specializer 'class)
+ (eq specializer (find-class (class-name specializer))))
+ (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))))))))
(defun make-method-lambda-internal (method-lambda &optional env)
(unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
(constant-value-p (and (null (cdr real-body))
(constantp (car real-body))))
(constant-value (and constant-value-p
- (eval (car real-body))))
+ (constant-form-value (car real-body))))
(plist (and constant-value-p
(or (typep constant-value
'(or number character))
(let ((pv-table-symbol (make-symbol "pv-table")))
(setq plist
`(,@(when slot-name-lists
- `(:slot-name-lists ,slot-name-lists))
+ `(:slot-name-lists ,slot-name-lists))
,@(when call-list
- `(:call-list ,call-list))
+ `(:call-list ,call-list))
:pv-table-symbol ,pv-table-symbol
,@plist))
(setq walked-lambda-body
`((pv-binding (,required-parameters
,slot-name-lists
,pv-table-symbol)
- ,@walked-lambda-body))))))
+ ,@walked-lambda-body))))))
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
(let ((aux (memq '&aux lambda-list)))
- (setq lambda-list (nconc (ldiff lambda-list aux)
- (list '&allow-other-keys)
- aux))))
+ (setq lambda-list (nconc (ldiff lambda-list aux)
+ (list '&allow-other-keys)
+ aux))))
(values `(lambda (.method-args. .next-methods.)
(simple-lexical-method-functions
- (,lambda-list .method-args. .next-methods.
- :call-next-method-p
- ,call-next-method-p
- :next-method-p-p ,next-method-p-p
- :setq-p ,setq-p
- ;; we need to pass this along
- ;; so that NO-NEXT-METHOD can
- ;; be given a suitable METHOD
- ;; argument; we need the
- ;; QUALIFIERS and SPECIALIZERS
- ;; inside the declaration to
- ;; give to FIND-METHOD.
- :method-name-declaration ,name-decl
- :closurep ,closurep
- :applyp ,applyp)
- ,@walked-declarations
- ,@walked-lambda-body))
+ (,lambda-list .method-args. .next-methods.
+ :call-next-method-p
+ ,call-next-method-p
+ :next-method-p-p ,next-method-p-p
+ :setq-p ,setq-p
+ ;; we need to pass this along
+ ;; so that NO-NEXT-METHOD can
+ ;; be given a suitable METHOD
+ ;; argument; we need the
+ ;; QUALIFIERS and SPECIALIZERS
+ ;; inside the declaration to
+ ;; give to FIND-METHOD.
+ :method-name-declaration ,name-decl
+ :closurep ,closurep
+ :applyp ,applyp)
+ ,@walked-declarations
+ ,@walked-lambda-body))
`(,@(when plist
- `(:plist ,plist))
+ `(:plist ,plist))
,@(when documentation
- `(:documentation ,documentation)))))))))))
+ `(:documentation ,documentation)))))))))))
(unless (fboundp 'make-method-lambda)
(setf (gdefinition 'make-method-lambda)
&body body)
`(progn
,method-args ,next-methods
- (bind-simple-lexical-method-macros (,method-args ,next-methods)
- (bind-lexical-method-functions (,@lmf-options)
+ (bind-simple-lexical-method-functions (,method-args ,next-methods
+ ,lmf-options)
(bind-args (,lambda-list ,method-args)
- ,@body)))))
+ ,@body))))
(defmacro fast-lexical-method-functions ((lambda-list
next-method-call
rest-arg
&rest lmf-options)
&body body)
- `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call)
- (bind-lexical-method-functions (,@lmf-options)
- (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
- ,@body))))
-
-(defmacro bind-simple-lexical-method-macros ((method-args next-methods)
- &body body)
- `(macrolet ((call-next-method-bind (&body body)
- `(let ((.next-method. (car ,',next-methods))
- (,',next-methods (cdr ,',next-methods)))
- .next-method. ,',next-methods
- ,@body))
- (check-cnm-args-body (&environment env method-name-declaration cnm-args)
- (if (safe-code-p env)
- `(%check-cnm-args ,cnm-args ,',method-args ',method-name-declaration)
- nil))
- (call-next-method-body (method-name-declaration cnm-args)
- `(if .next-method.
- (funcall (if (std-instance-p .next-method.)
- (method-function .next-method.)
- .next-method.) ; for early methods
- (or ,cnm-args ,',method-args)
- ,',next-methods)
- (apply #'call-no-next-method ',method-name-declaration
- (or ,cnm-args ,',method-args))))
- (next-method-p-body ()
- `(not (null .next-method.)))
- (with-rebound-original-args ((call-next-method-p setq-p)
- &body body)
- (declare (ignore call-next-method-p setq-p))
- `(let () ,@body)))
- ,@body))
+ `(bind-fast-lexical-method-functions (,args ,rest-arg ,next-method-call ,lmf-options)
+ (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg)
+ ,@body)))
+
+(defmacro bind-simple-lexical-method-functions
+ ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p
+ closurep applyp method-name-declaration))
+ &body body
+ &environment env)
+ (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
+ `(locally
+ ,@body)
+ `(let ((.next-method. (car ,next-methods))
+ (,next-methods (cdr ,next-methods)))
+ (declare (ignorable .next-method. ,next-methods))
+ (flet (,@(and call-next-method-p
+ `((call-next-method
+ (&rest cnm-args)
+ ,@(if (safe-code-p env)
+ `((%check-cnm-args cnm-args
+ ,method-args
+ ',method-name-declaration))
+ nil)
+ (if .next-method.
+ (funcall (if (std-instance-p .next-method.)
+ (method-function .next-method.)
+ .next-method.) ; for early methods
+ (or cnm-args ,method-args)
+ ,next-methods)
+ (apply #'call-no-next-method
+ ',method-name-declaration
+ (or cnm-args ,method-args))))))
+ ,@(and next-method-p-p
+ '((next-method-p ()
+ (not (null .next-method.))))))
+ ,@body))))
(defun call-no-next-method (method-name-declaration &rest args)
(destructuring-bind (name) method-name-declaration
;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if
;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...)
;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error.
- (setq restp (eval restp))
+ (setq restp (constant-form-value restp))
`(progn
(trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
(cond ((typep ,emf 'fast-method-call)
(function
(apply emf args))))
\f
-(defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call)
- &body body
- &environment env)
+
+(defmacro fast-narrowed-emf (emf)
+ ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to dispatch on
+ ;; the possibility that EMF might be of type FIXNUM (as an optimized
+ ;; representation of a slot accessor). But as far as I (WHN
+ ;; 2002-06-11) can tell, it's impossible for such a representation
+ ;; to end up as .NEXT-METHOD-CALL. By reassuring INVOKE-E-M-F that
+ ;; when called from this context it needn't worry about the FIXNUM
+ ;; case, we can keep those cases from being compiled, which is good
+ ;; both because it saves bytes and because it avoids annoying type
+ ;; mismatch compiler warnings.
+ ;;
+ ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type system isn't smart
+ ;; enough about NOT and intersection types to benefit from a (NOT
+ ;; FIXNUM) declaration here. -- WHN 2002-06-12 (FIXME: maybe it is
+ ;; now... -- CSR, 2003-06-07)
+ ;;
+ ;; FIXME: Might the FUNCTION type be omittable here, leaving only
+ ;; METHOD-CALLs? Failing that, could this be documented somehow?
+ ;; (It'd be nice if the types involved could be understood without
+ ;; solving the halting problem.)
+ `(the (or function method-call fast-method-call)
+ ,emf))
+
+(defmacro fast-call-next-method-body ((args next-method-call rest-arg)
+ method-name-declaration
+ cnm-args)
+ `(if ,next-method-call
+ ,(let ((call `(invoke-effective-method-function
+ (fast-narrowed-emf ,next-method-call)
+ ,(not (null rest-arg))
+ ,@args
+ ,@(when rest-arg `(,rest-arg)))))
+ `(if ,cnm-args
+ (bind-args ((,@args
+ ,@(when rest-arg
+ `(&rest ,rest-arg)))
+ ,cnm-args)
+ ,call)
+ ,call))
+ (call-no-next-method ',method-name-declaration
+ ,@args
+ ,@(when rest-arg
+ `(,rest-arg)))))
+
+(defmacro bind-fast-lexical-method-functions
+ ((args rest-arg next-method-call (&key
+ call-next-method-p
+ setq-p
+ method-name-declaration
+ next-method-p-p
+ closurep
+ applyp))
+ &body body
+ &environment env)
(let* ((all-params (append args (when rest-arg (list rest-arg))))
- (rebindings (mapcar (lambda (x) (list x x)) all-params)))
- `(macrolet ((narrowed-emf (emf)
- ;; INVOKE-EFFECTIVE-METHOD-FUNCTION has code in it to
- ;; dispatch on the possibility that EMF might be of
- ;; type FIXNUM (as an optimized representation of a
- ;; slot accessor). But as far as I (WHN 2002-06-11)
- ;; can tell, it's impossible for such a representation
- ;; to end up as .NEXT-METHOD-CALL. By reassuring
- ;; INVOKE-E-M-F that when called from this context
- ;; it needn't worry about the FIXNUM case, we can
- ;; keep those cases from being compiled, which is
- ;; good both because it saves bytes and because it
- ;; avoids annoying type mismatch compiler warnings.
- ;;
- ;; KLUDGE: In sbcl-0.7.4.29, the compiler's type
- ;; system isn't smart enough about NOT and
- ;; intersection types to benefit from a (NOT FIXNUM)
- ;; declaration here. -- WHN 2002-06-12 (FIXME: maybe
- ;; it is now... -- CSR, 2003-06-07)
- ;;
- ;; FIXME: Might the FUNCTION type be omittable here,
- ;; leaving only METHOD-CALLs? Failing that, could this
- ;; be documented somehow? (It'd be nice if the types
- ;; involved could be understood without solving the
- ;; halting problem.)
- `(the (or function method-call fast-method-call)
- ,emf))
- (call-next-method-bind (&body body)
- `(let () ,@body))
- (check-cnm-args-body (&environment env method-name-declaration cnm-args)
- (if (safe-code-p env)
- `(%check-cnm-args ,cnm-args (list ,@',args)
- ',method-name-declaration)
- nil))
- (call-next-method-body (method-name-declaration cnm-args)
- `(if ,',next-method-call
- ,(locally
- ;; This declaration suppresses a "deleting
- ;; unreachable code" note for the following IF
- ;; when REST-ARG is NIL. It is not nice for
- ;; debugging SBCL itself, but at least it
- ;; keeps us from annoying users.
- (declare (optimize (inhibit-warnings 3)))
- (if (and (null ',rest-arg)
- (consp cnm-args)
- (eq (car cnm-args) 'list))
- `(invoke-effective-method-function
- (narrowed-emf ,',next-method-call)
- nil
- ,@(cdr cnm-args))
- (let ((call `(invoke-effective-method-function
- (narrowed-emf ,',next-method-call)
- ,',(not (null rest-arg))
- ,@',args
- ,@',(when rest-arg `(,rest-arg)))))
- `(if ,cnm-args
- (bind-args ((,@',args
- ,@',(when rest-arg
- `(&rest ,rest-arg)))
- ,cnm-args)
- ,call)
- ,call))))
- ,(locally
- ;; As above, this declaration suppresses code
- ;; deletion notes.
- (declare (optimize (inhibit-warnings 3)))
- (if (and (null ',rest-arg)
- (consp cnm-args)
- (eq (car cnm-args) 'list))
- `(call-no-next-method ',method-name-declaration
- ,@(cdr cnm-args))
- `(call-no-next-method ',method-name-declaration
- ,@',args
- ,@',(when rest-arg
- `(,rest-arg)))))))
- (next-method-p-body ()
- `(not (null ,',next-method-call)))
- (with-rebound-original-args ((cnm-p setq-p) &body body)
- (if (or cnm-p setq-p)
- `(let ,',rebindings
- (declare (ignorable ,@',all-params))
- ,@body)
- `(let () ,@body))))
- ,@body)))
-
-(defmacro bind-lexical-method-functions
- ((&key call-next-method-p next-method-p-p setq-p
- closurep applyp method-name-declaration)
- &body body)
- (cond ((and (null call-next-method-p) (null next-method-p-p)
- (null closurep) (null applyp) (null setq-p))
- `(let () ,@body))
- (t
- `(call-next-method-bind
- (flet (,@(and call-next-method-p
- `((call-next-method (&rest cnm-args)
- (check-cnm-args-body ,method-name-declaration cnm-args)
- (call-next-method-body ,method-name-declaration cnm-args))))
- ,@(and next-method-p-p
- '((next-method-p ()
- (next-method-p-body)))))
- (with-rebound-original-args (,call-next-method-p ,setq-p)
- ,@body))))))
+ (rebindings (when (or setq-p call-next-method-p)
+ (mapcar (lambda (x) (list x x)) all-params))))
+ (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp))
+ `(locally
+ ,@body)
+ `(flet (,@(when call-next-method-p
+ `((call-next-method (&rest cnm-args)
+ (declare (muffle-conditions code-deletion-note))
+ ,@(if (safe-code-p env)
+ `((%check-cnm-args cnm-args (list ,@args)
+ ',method-name-declaration))
+ nil)
+ (fast-call-next-method-body (,args
+ ,next-method-call
+ ,rest-arg)
+ ,method-name-declaration
+ cnm-args))))
+ ,@(when next-method-p-p
+ `((next-method-p
+ ()
+ (not (null ,next-method-call))))))
+ (let ,rebindings
+ ,@(when rebindings `((declare (ignorable ,@all-params))))
+ ,@body)))))
;;; CMUCL comment (Gerd Moellmann):
;;;
(defun generic-function-name-p (name)
(and (legal-fun-name-p name)
- (gboundp name)
+ (fboundp name)
(if (eq *boot-state* 'complete)
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
\f
(defvar *method-function-plist* (make-hash-table :test 'eq))
-(defvar *mf1* nil)
-(defvar *mf1p* nil)
-(defvar *mf1cp* nil)
-(defvar *mf2* nil)
-(defvar *mf2p* nil)
-(defvar *mf2cp* nil)
(defun method-function-plist (method-function)
- (unless (eq method-function *mf1*)
- (rotatef *mf1* *mf2*)
- (rotatef *mf1p* *mf2p*)
- (rotatef *mf1cp* *mf2cp*))
- (unless (or (eq method-function *mf1*) (null *mf1cp*))
- (setf (gethash *mf1* *method-function-plist*) *mf1p*))
- (unless (eq method-function *mf1*)
- (setf *mf1* method-function
- *mf1cp* nil
- *mf1p* (gethash method-function *method-function-plist*)))
- *mf1p*)
-
-(defun (setf method-function-plist)
- (val method-function)
- (unless (eq method-function *mf1*)
- (rotatef *mf1* *mf2*)
- (rotatef *mf1cp* *mf2cp*)
- (rotatef *mf1p* *mf2p*))
- (unless (or (eq method-function *mf1*) (null *mf1cp*))
- (setf (gethash *mf1* *method-function-plist*) *mf1p*))
- (setf *mf1* method-function
- *mf1cp* t
- *mf1p* val))
+ (gethash method-function *method-function-plist*))
+
+(defun (setf method-function-plist) (val method-function)
+ (setf (gethash method-function *method-function-plist*) val))
(defun method-function-get (method-function key &optional default)
(getf (method-function-plist method-function) key default))
`(method-function-get ,method-function 'closure-generator))
(defun load-defmethod
- (class name quals specls ll initargs &optional pv-table-symbol)
+ (class name quals specls ll initargs pv-table-symbol source-location)
(setq initargs (copy-tree initargs))
(let ((method-spec (or (getf initargs :method-spec)
(make-method-spec name quals specls))))
(setf (getf initargs :method-spec) method-spec)
(load-defmethod-internal class name quals specls
- ll initargs pv-table-symbol)))
+ ll initargs pv-table-symbol
+ source-location)))
(defun load-defmethod-internal
(method-class gf-spec qualifiers specializers lambda-list
- initargs pv-table-symbol)
+ initargs pv-table-symbol source-location)
(when pv-table-symbol
(setf (getf (getf initargs :plist) :pv-table-symbol)
pv-table-symbol))
gf-spec qualifiers specializers))))
(let ((method (apply #'add-named-method
gf-spec qualifiers specializers lambda-list
- :definition-source `((defmethod ,gf-spec
- ,@qualifiers
- ,specializers)
- ,*load-pathname*)
+ :definition-source source-location
initargs)))
(unless (or (eq method-class 'standard-method)
(eq (find-class method-class nil) (class-of method)))
(defun ensure-generic-function (fun-name
&rest all-keys
- &key environment
+ &key environment source-location
&allow-other-keys)
(declare (ignore environment))
- (let ((existing (and (gboundp fun-name)
+ (let ((existing (and (fboundp fun-name)
(gdefinition fun-name))))
(if (and existing
(eq *boot-state* 'complete)
(defmacro early-gf-methods (gf)
`(clos-slots-ref (get-slots ,gf) *sgf-methods-index*))
+(defun safe-generic-function-methods (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (get-slots generic-function) *sgf-methods-index*)
+ (generic-function-methods generic-function)))
+
(defvar *sgf-arg-info-index*
(!bootstrap-slot-index 'standard-generic-function 'arg-info))
~S."
gf-keywords)))))))
+(defvar *sm-specializers-index*
+ (!bootstrap-slot-index 'standard-method 'specializers))
+(defvar *sm-fast-function-index*
+ (!bootstrap-slot-index 'standard-method 'fast-function))
+(defvar *sm-%function-index*
+ (!bootstrap-slot-index 'standard-method '%function))
+(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 fast-function %function plist))
+ (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s)))
+ (!bootstrap-slot-index 'standard-reader-method s)
+ (!bootstrap-slot-index 'standard-writer-method s)
+ (!bootstrap-slot-index 'standard-boundp-method s))))
+
+(defun safe-method-specializers (method)
+ (let ((standard-method-classes
+ (list *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*))
+ (class (class-of method)))
+ (if (member class standard-method-classes)
+ (clos-slots-ref (get-slots method) *sm-specializers-index*)
+ (method-specializers method))))
+(defun safe-method-fast-function (method)
+ (let ((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-fast-function-index*)
+ (method-fast-function method))))
+(defun safe-method-function (method)
+ (let ((standard-method-classes
+ (list *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*))
+ (class (class-of method)))
+ (if (member class standard-method-classes)
+ (clos-slots-ref (get-slots method) *sm-%function-index*)
+ (method-function method))))
+(defun safe-method-qualifiers (method)
+ (let ((standard-method-classes
+ (list *the-class-standard-method*
+ *the-class-standard-reader-method*
+ *the-class-standard-writer-method*
+ *the-class-standard-boundp-method*))
+ (class (class-of method)))
+ (if (member class standard-method-classes)
+ (let ((plist (clos-slots-ref (get-slots method) *sm-plist-index*)))
+ (getf plist 'qualifiers))
+ (method-qualifiers method))))
+
(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
(let* ((existing-p (and methods (cdr methods) new-method))
(nreq (length (arg-info-metatypes arg-info)))
(dolist (method (if new-method (list new-method) methods))
(let* ((specializers (if (or (eq *boot-state* 'complete)
(not (consp method)))
- (method-specializers method)
+ (safe-method-specializers method)
(early-method-specializers method t)))
(class (if (or (eq *boot-state* 'complete) (not (consp method)))
(class-of method)
&key (lambda-list nil
lambda-list-p)
argument-precedence-order
+ source-location
&allow-other-keys)
(declare (ignore keys))
(cond ((and existing (early-gf-p existing))
((assoc spec *!generic-function-fixups* :test #'equal)
(if existing
(make-early-gf spec lambda-list lambda-list-p existing
- argument-precedence-order)
+ argument-precedence-order source-location)
(error "The function ~S is not already defined." spec)))
(existing
(error "~S should be on the list ~S."
(t
(pushnew spec *!early-generic-functions* :test #'equal)
(make-early-gf spec lambda-list lambda-list-p nil
- argument-precedence-order))))
+ argument-precedence-order source-location))))
(defun make-early-gf (spec &optional lambda-list lambda-list-p
- function argument-precedence-order)
+ function argument-precedence-order source-location)
(let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-function
fin
(!bootstrap-set-slot 'standard-generic-function
fin
'source
- *load-pathname*)
+ source-location)
(set-fun-name fin spec)
(let ((arg-info (make-arg-info)))
(setf (early-gf-arg-info fin) arg-info)
(set-arg-info fin :lambda-list lambda-list))))
fin))
+(defun safe-gf-dfun-state (generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*)
+ (gf-dfun-state generic-function)))
+(defun (setf safe-gf-dfun-state) (new-value generic-function)
+ (if (eq (class-of generic-function) *the-class-standard-generic-function*)
+ (setf (clos-slots-ref (get-slots generic-function)
+ *sgf-dfun-state-index*)
+ new-value)
+ (setf (gf-dfun-state generic-function) new-value)))
+
(defun set-dfun (gf &optional dfun cache info)
(when cache
(setf (cache-owner cache) gf))
(list* dfun cache info)
dfun)))
(if (eq *boot-state* 'complete)
- (setf (gf-dfun-state gf) new-state)
+ (setf (safe-gf-dfun-state gf) new-state)
(setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)
new-state)))
dfun)
(defun gf-dfun-cache (gf)
(let ((state (if (eq *boot-state* 'complete)
- (gf-dfun-state gf)
+ (safe-gf-dfun-state gf)
(clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(defun gf-dfun-info (gf)
(let ((state (if (eq *boot-state* 'complete)
- (gf-dfun-state gf)
+ (safe-gf-dfun-state gf)
(clos-slots-ref (get-slots gf) *sgf-dfun-state-index*))))
(typecase state
(function nil)
(error "The :GENERIC-FUNCTION-CLASS argument (~S) was neither a~%~
class nor a symbol that names a class."
,gf-class)))
+ (unless (class-finalized-p ,gf-class)
+ (if (class-has-a-forward-referenced-superclass-p ,gf-class)
+ ;; FIXME: reference MOP documentation -- this is an
+ ;; additional requirement on our users
+ (error "The generic function class ~S is not finalizeable" ,gf-class)
+ (finalize-inheritance ,gf-class)))
(remf ,all-keys :generic-function-class)
(remf ,all-keys :environment)
(let ((combin (getf ,all-keys :method-combination '.shes-not-there.)))
(let ((method-class (getf ,all-keys :method-class '.shes-not-there.)))
(unless (eq method-class '.shes-not-there.)
(setf (getf ,all-keys :method-class)
- (find-class method-class t ,env))))))
+ (cond ((classp method-class)
+ method-class)
+ (t (find-class method-class t ,env))))))))
(defun real-ensure-gf-using-class--generic-function
(existing
(when lambda-list-p
(proclaim (defgeneric-declaration fun-name 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*)
+ (gf-arg-info generic-function)))
+
+;;; FIXME: this function took on a slightly greater role than it
+;;; previously had around 2005-11-02, when CSR fixed the bug whereby
+;;; having more than one subclass of standard-generic-function caused
+;;; the whole system to die horribly through a metacircle in
+;;; GF-ARG-INFO. The fix is to be slightly more disciplined about
+;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when
+;;; computing discriminating functions, so we need to be careful about
+;;; having a base case for the recursion, and we provide that with the
+;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet)
+;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to
+;;; that stage, where all potentially dangerous cases are enumerated
+;;; and stopped. -- CSR, 2005-11-02.
(defun get-generic-fun-info (gf)
;; values nreq applyp metatypes nkeys arg-info
(multiple-value-bind (applyp metatypes arg-info)
(let* ((arg-info (if (early-gf-p gf)
(early-gf-arg-info gf)
- (gf-arg-info gf)))
+ (safe-gf-arg-info gf)))
(metatypes (arg-info-metatypes arg-info)))
(values (arg-info-applyp arg-info)
metatypes
(make-symbol (format nil "~S" method))))
(multiple-value-bind (gf-spec quals specls)
(parse-defmethod spec)
- (and (setq gf (and (or errorp (gboundp gf-spec))
+ (and (setq gf (and (or errorp (fboundp gf-spec))
(gdefinition gf-spec)))
(let ((nreq (compute-discriminating-function-arglist-info gf)))
(setq specls (append (parse-specializers specls)