X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=8ffba535cbafdc4ca5168ff493aaa235b492574e;hb=ebc0f0ebf9efd39519ab86ba28c33abdb25443e0;hp=1d25ea590d88f922403eef0d22333b19c9bb1823;hpb=31f072311935e32751508ecf824905c6b58a1d95;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 1d25ea5..8ffba53 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -406,7 +406,7 @@ bootstrapping. (if (consp s) (and (eq (car s) 'eql) (constantp (cadr s)) - (let ((sv (eval (cadr s)))) + (let ((sv (constant-form-value (cadr s)))) (or (interned-symbol-p sv) (integerp sv) (and (characterp sv) @@ -604,39 +604,58 @@ bootstrapping. '(ignorable)) (t ;; Otherwise, we can usually make Python very happy. - (let ((kind (info :type :kind specializer))) - (ecase kind - ((:primitive) `(type ,specializer ,parameter)) - ((:defined) - (let ((class (find-class specializer nil))) - ;; CLASS can be null here if the user has erroneously - ;; tried to use a defined type as a specializer; it - ;; can be a non-BUILT-IN-CLASS if the user defines a - ;; type and calls (SETF FIND-CLASS) in a consistent - ;; way. - (when (and class (typep class 'built-in-class)) - `(type ,specializer ,parameter)))) - ((:instance nil) - (let ((class (find-class specializer nil))) - (cond - (class - (if (typep class '(or built-in-class structure-class)) - `(type ,specializer ,parameter) - ;; don't declare CLOS classes as parameters; - ;; it's too expensive. - '(ignorable))) - (t - ;; we can get here, and still not have a failure - ;; case, by doing MOP programming like (PROGN - ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO)) - ;; ...)). Best to let the user know we haven't - ;; been able to extract enough information: - (style-warn - "~@" - specializer - 'parameter-specializer-declaration-in-defmethod) - '(ignorable))))) - ((:forthcoming-defclass-type) '(ignorable))))))) + ;; + ;; KLUDGE: Since INFO doesn't work right for class objects here, + ;; and they are valid specializers, see if the specializer is + ;; a named class, and use the name in that case -- otherwise + ;; the class instance is ok, since info will just return NIL, NIL. + ;; + ;; We still need to deal with the class case too, but at + ;; least #.(find-class 'integer) and integer as equivalent + ;; specializers with this. + (let* ((specializer (if (and (typep specializer 'class) + (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 + "~@" + 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)) @@ -713,7 +732,7 @@ bootstrapping. (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) (constant-value (and constant-value-p - (eval (car real-body)))) + (constant-form-value (car real-body)))) (plist (and constant-value-p (or (typep constant-value '(or number character)) @@ -746,45 +765,45 @@ bootstrapping. (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) @@ -797,10 +816,10 @@ bootstrapping. &body body) `(progn ,method-args ,next-methods - (bind-simple-lexical-method-macros (,method-args ,next-methods) - (bind-lexical-method-functions (,@lmf-options) + (bind-simple-lexical-method-functions (,method-args ,next-methods + ,lmf-options) (bind-args (,lambda-list ,method-args) - ,@body))))) + ,@body)))) (defmacro fast-lexical-method-functions ((lambda-list next-method-call @@ -808,38 +827,42 @@ bootstrapping. rest-arg &rest lmf-options) &body body) - `(bind-fast-lexical-method-macros (,args ,rest-arg ,next-method-call) - (bind-lexical-method-functions (,@lmf-options) - (bind-args (,(nthcdr (length args) lambda-list) ,rest-arg) - ,@body)))) - -(defmacro bind-simple-lexical-method-macros ((method-args next-methods) - &body body) - `(macrolet ((call-next-method-bind (&body body) - `(let ((.next-method. (car ,',next-methods)) - (,',next-methods (cdr ,',next-methods))) - .next-method. ,',next-methods - ,@body)) - (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 @@ -953,7 +976,7 @@ bootstrapping. ;; 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) @@ -1067,113 +1090,86 @@ bootstrapping. (function (apply emf args)))) -(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): ;;; @@ -1367,37 +1363,12 @@ bootstrapping. (funcallable-instance-p (gdefinition name))))) (defvar *method-function-plist* (make-hash-table :test 'eq)) -(defvar *mf1* nil) -(defvar *mf1p* nil) -(defvar *mf1cp* nil) -(defvar *mf2* nil) -(defvar *mf2p* nil) -(defvar *mf2cp* nil) (defun method-function-plist (method-function) - (unless (eq method-function *mf1*) - (rotatef *mf1* *mf2*) - (rotatef *mf1p* *mf2p*) - (rotatef *mf1cp* *mf2cp*)) - (unless (or (eq method-function *mf1*) (null *mf1cp*)) - (setf (gethash *mf1* *method-function-plist*) *mf1p*)) - (unless (eq method-function *mf1*) - (setf *mf1* method-function - *mf1cp* nil - *mf1p* (gethash method-function *method-function-plist*))) - *mf1p*) - -(defun (setf method-function-plist) - (val method-function) - (unless (eq method-function *mf1*) - (rotatef *mf1* *mf2*) - (rotatef *mf1cp* *mf2cp*) - (rotatef *mf1p* *mf2p*)) - (unless (or (eq method-function *mf1*) (null *mf1cp*)) - (setf (gethash *mf1* *method-function-plist*) *mf1p*)) - (setf *mf1* method-function - *mf1cp* t - *mf1p* val)) + (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)) @@ -1636,6 +1607,11 @@ bootstrapping. (defmacro early-gf-methods (gf) `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*)) +(defun safe-generic-function-methods (generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (clos-slots-ref (get-slots generic-function) *sgf-methods-index*) + (generic-function-methods generic-function))) + (defvar *sgf-arg-info-index* (!bootstrap-slot-index 'standard-generic-function 'arg-info)) @@ -1770,6 +1746,67 @@ bootstrapping. ~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))) @@ -1783,7 +1820,7 @@ bootstrapping. (dolist (method (if new-method (list new-method) methods)) (let* ((specializers (if (or (eq *boot-state* 'complete) (not (consp method))) - (method-specializers method) + (safe-method-specializers method) (early-method-specializers method t))) (class (if (or (eq *boot-state* 'complete) (not (consp method))) (class-of method) @@ -1915,6 +1952,17 @@ bootstrapping. (set-arg-info fin :lambda-list lambda-list)))) fin)) +(defun safe-gf-dfun-state (generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (clos-slots-ref (get-slots generic-function) *sgf-dfun-state-index*) + (gf-dfun-state generic-function))) +(defun (setf safe-gf-dfun-state) (new-value generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (setf (clos-slots-ref (get-slots generic-function) + *sgf-dfun-state-index*) + new-value) + (setf (gf-dfun-state generic-function) new-value))) + (defun set-dfun (gf &optional dfun cache info) (when cache (setf (cache-owner cache) gf)) @@ -1922,14 +1970,14 @@ bootstrapping. (list* dfun cache info) dfun))) (if (eq *boot-state* 'complete) - (setf (gf-dfun-state gf) new-state) + (setf (safe-gf-dfun-state gf) new-state) (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) dfun) (defun gf-dfun-cache (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) + (safe-gf-dfun-state gf) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) @@ -1937,7 +1985,7 @@ bootstrapping. (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) + (safe-gf-dfun-state gf) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) @@ -2024,6 +2072,12 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name lambda-list))))) +(defun safe-gf-arg-info (generic-function) + (if (eq (class-of generic-function) *the-class-standard-generic-function*) + (clos-slots-ref (fsc-instance-slots generic-function) + *sgf-arg-info-index*) + (gf-arg-info generic-function))) + ;;; FIXME: this function took on a slightly greater role than it ;;; previously had around 2005-11-02, when CSR fixed the bug whereby ;;; having more than one subclass of standard-generic-function caused @@ -2041,9 +2095,7 @@ bootstrapping. (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) - (if (eq (class-of gf) *the-class-standard-generic-function*) - (clos-slots-ref (fsc-instance-slots gf) *sgf-arg-info-index*) - (gf-arg-info gf)))) + (safe-gf-arg-info gf))) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes