(if proto-method
(class-name (class-of proto-method))
'standard-method)
- initargs-form
- (getf (getf initargs :plist)
- :pv-table-symbol)))))))
+ initargs-form))))))
(defun interned-symbol-p (x)
(and (symbolp x) (symbol-package x)))
-(defun make-defmethod-form (name qualifiers specializers
- unspecialized-lambda-list method-class-name
- initargs-form &optional pv-table-symbol)
+(defun make-defmethod-form
+ (name qualifiers specializers unspecialized-lambda-list
+ method-class-name initargs-form)
(let (fn
fn-lambda)
(if (and (interned-symbol-p (fun-name-block-name name))
specializers)
(consp initargs-form)
(eq (car initargs-form) 'list*)
- (memq (cadr initargs-form) '(:function :fast-function))
+ (memq (cadr initargs-form) '(:function))
(consp (setq fn (caddr initargs-form)))
(eq (car fn) 'function)
(consp (setq fn-lambda (cadr fn)))
unspecialized-lambda-list method-class-name
`(list* ,(cadr initargs-form)
#',mname
- ,@(cdddr initargs-form))
- pv-table-symbol)))
+ ,@(cdddr initargs-form)))))
(make-defmethod-form-internal
name qualifiers
`(list ,@(mapcar (lambda (specializer)
specializers))
unspecialized-lambda-list
method-class-name
- initargs-form
- pv-table-symbol))))
+ initargs-form))))
(defun make-defmethod-form-internal
(name qualifiers specializers-form unspecialized-lambda-list
- method-class-name initargs-form &optional pv-table-symbol)
+ method-class-name initargs-form)
`(load-defmethod
',method-class-name
',name
,specializers-form
',unspecialized-lambda-list
,initargs-form
- ;; Paper over a bug in KCL by passing the cache-symbol here in
- ;; 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
(sb-c:source-location)))
(defmacro make-method-function (method-lambda &environment env)
walked-documentation)
(parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
- (when (or next-method-p-p call-next-method-p)
- (setq plist (list* :needs-next-methods-p t plist)))
(when (some #'cdr slots)
(multiple-value-bind (slot-name-lists call-list)
(slot-name-lists-from-slots slots calls)
- (let ((pv-table-symbol (make-symbol "pv-table")))
- (setq plist
- `(,@(when slot-name-lists
- `(:slot-name-lists ,slot-name-lists))
- ,@(when 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))))))
+ (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)))
+ ,@walked-lambda-body)))))
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
(let ((aux (memq '&aux lambda-list)))
,@walked-declarations
,@walked-lambda-body))
`(,@(when plist
- `(:plist ,plist))
+ `(plist ,plist))
,@(when documentation
`(:documentation ,documentation)))))))))))
(defstruct (method-call (:copier nil))
(function #'identity :type function)
call-method-args)
+(defstruct (constant-method-call (:copier nil) (:include method-call))
+ value)
#-sb-fluid (declaim (sb-ext:freeze-type method-call))
pv-cell
next-method-call
arg-info)
+(defstruct (constant-fast-method-call
+ (:copier nil) (:include fast-method-call))
+ value)
#-sb-fluid (declaim (sb-ext:freeze-type fast-method-call))
(trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
(invoke-fast-method-call ,emf ,@required-args+rest-arg)))
-(defmacro invoke-effective-method-function (emf restp
- &rest required-args+rest-arg)
- (unless (constantp restp)
- (error "The RESTP argument is not constant."))
- ;; FIXME: The RESTP handling here is confusing and maybe slightly
- ;; 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 (constant-form-value restp))
- `(progn
- (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg))
- (cond ((typep ,emf 'fast-method-call)
- (invoke-fast-method-call ,emf ,@required-args+rest-arg))
- ;; "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 also figure it out by looking
- ;; at it without breaking stride. For the rest of us,
- ;; though: From what the code is doing with .SLOTS. and
- ;; whatnot, evidently it's implementing SLOT-VALUEish and
- ;; GET-SLOT-VALUEish things. Then we can reason backwards
- ;; and conclude that setting EMF to a FIXNUM is an
- ;; optimized way to represent these slot access operations.
- ,@(when (and (null restp) (= 1 (length required-args+rest-arg)))
- `(((typep ,emf 'fixnum)
- (let* ((.slots. (get-slots-or-nil
- ,(car required-args+rest-arg)))
- (value (when .slots. (clos-slots-ref .slots. ,emf))))
- (if (eq value +slot-unbound+)
- (slot-unbound-internal ,(car required-args+rest-arg)
- ,emf)
- value)))))
- ,@(when (and (null restp) (= 2 (length required-args+rest-arg)))
- `(((typep ,emf 'fixnum)
- (let ((.new-value. ,(car required-args+rest-arg))
- (.slots. (get-slots-or-nil
- ,(cadr required-args+rest-arg))))
- (when .slots.
- (setf (clos-slots-ref .slots. ,emf) .new-value.))))))
- ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
- ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
- ;; there was no explanation and presumably the code is 10+
- ;; years stale, I simply deleted it. -- WHN)
- (t
- (etypecase ,emf
- (method-call
- (invoke-method-call ,emf ,restp ,@required-args+rest-arg))
- (function
- ,(if restp
- `(apply (the function ,emf) ,@required-args+rest-arg)
- `(funcall (the function ,emf)
- ,@required-args+rest-arg))))))))
+(defun effective-method-optimized-slot-access-clause
+ (emf restp required-args+rest-arg)
+ ;; "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
+ ;; also figure it out by looking at it without breaking stride. For
+ ;; the rest of us, though: From what the code is doing with .SLOTS.
+ ;; and whatnot, evidently it's implementing SLOT-VALUEish and
+ ;; GET-SLOT-VALUEish things. Then we can reason backwards and
+ ;; 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)))
+ (cond ((= 1 length)
+ `((fixnum
+ (let* ((.slots. (get-slots-or-nil
+ ,(car required-args+rest-arg)))
+ (value (when .slots. (clos-slots-ref .slots. ,emf))))
+ (if (eq value +slot-unbound+)
+ (slot-unbound-internal ,(car required-args+rest-arg)
+ ,emf)
+ value)))))
+ ((= 2 length)
+ `((fixnum
+ (let ((.new-value. ,(car required-args+rest-arg))
+ (.slots. (get-slots-or-nil
+ ,(cadr required-args+rest-arg))))
+ (when .slots.
+ (setf (clos-slots-ref .slots. ,emf) .new-value.)))))))
+ ;; (In cmucl-2.4.8 there was a commented-out third ,@(WHEN
+ ;; ...) clause here to handle SLOT-BOUNDish stuff. Since
+ ;; there was no explanation and presumably the code is 10+
+ ;; years stale, I simply deleted it. -- WHN)
+ )))
+
+;;; Before SBCL 0.9.16.7 instead of
+;;; INVOKE-NARROW-EFFECTIVE-METHOD-FUNCTION we passed a (THE (OR
+;;; FUNCTION METHOD-CALL FAST-METHOD-CALL) EMF) form as the EMF. Now,
+;;; 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)
+ (unless (constantp restp)
+ (error "The RESTP argument is not constant."))
+ (setq restp (constant-form-value restp))
+ (with-unique-names (emf-n)
+ `(locally
+ (declare (optimize (sb-c:insert-step-conditions 0)))
+ (let ((,emf-n ,emf))
+ (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))
+ ,@,(unless narrow
+ `(effective-method-optimized-slot-access-clause
+ emf-n restp required-args+rest-arg))
+ (method-call
+ (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))))))))))
+ (def invoke-effective-method-function nil)
+ (def invoke-narrow-effective-method-function t))
(defun invoke-emf (emf args)
(trace-emf-call emf t args)
(apply emf args))))
\f
-(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)
+ ,(let ((call `(invoke-narrow-effective-method-function
+ ,next-method-call
,(not (null rest-arg))
,@args
,@(when rest-arg `(,rest-arg)))))
,@body)
`(flet (,@(when call-next-method-p
`((call-next-method (&rest cnm-args)
- (declare (muffle-conditions code-deletion-note))
+ (declare (muffle-conditions code-deletion-note)
+ (optimize (sb-c:insert-step-conditions 0)))
,@(if (safe-code-p env)
`((%check-cnm-args cnm-args (list ,@args)
',method-name-declaration))
,method-name-declaration
cnm-args))))
,@(when next-method-p-p
- `((next-method-p
- ()
+ `((next-method-p ()
+ (declare (optimize (sb-c:insert-step-conditions 0)))
(not (null ,next-method-call))))))
(let ,rebindings
,@(when rebindings `((declare (ignorable ,@all-params))))
(standard-generic-function-p (gdefinition name))
(funcallable-instance-p (gdefinition name)))))
\f
-(defvar *method-function-plist* (make-hash-table :test 'eq))
-
-(defun method-function-plist (method-function)
- (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))
-
-(defun (setf method-function-get)
- (val method-function key)
- (setf (getf (method-function-plist method-function) key) val))
-
-(defun method-function-pv-table (method-function)
- (method-function-get method-function :pv-table))
-
-(defun method-function-method (method-function)
- (method-function-get method-function :method))
-
-(defun method-function-needs-next-methods-p (method-function)
- (method-function-get method-function :needs-next-methods-p t))
+(defun method-plist-value (method key &optional default)
+ (let ((plist (if (consp method)
+ (getf (early-method-initargs method) 'plist)
+ (object-plist method))))
+ (getf plist key default)))
+
+(defun (setf method-plist-value) (new-value method key &optional default)
+ (if (consp method)
+ (setf (getf (getf (early-method-initargs method) 'plist) key default)
+ new-value)
+ (setf (getf (object-plist method) key default) new-value)))
\f
-(defmacro method-function-closure-generator (method-function)
- `(method-function-get ,method-function 'closure-generator))
-
(defun load-defmethod
- (class name quals specls ll initargs pv-table-symbol source-location)
+ (class name quals specls ll initargs 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
- source-location)))
+ (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 pv-table-symbol source-location)
- (when pv-table-symbol
- (setf (getf (getf initargs :plist) :pv-table-symbol)
- pv-table-symbol))
+ initargs source-location)
(when (and (eq *boot-state* 'complete)
(fboundp gf-spec))
(let* ((gf (fdefinition gf-spec))
(defun make-method-spec (gf-spec qualifiers unparsed-specializers)
`(slow-method ,gf-spec ,@qualifiers ,unparsed-specializers))
-(defun initialize-method-function (initargs &optional return-function-p method)
+(defun initialize-method-function (initargs method)
(let* ((mf (getf initargs :function))
- (method-spec (getf initargs :method-spec))
- (plist (getf initargs :plist))
- (pv-table-symbol (getf plist :pv-table-symbol))
- (pv-table nil)
- (mff (getf initargs :fast-function)))
- (flet ((set-mf-property (p v)
- (when mf
- (setf (method-function-get mf p) v))
- (when mff
- (setf (method-function-get mff p) v))))
- (when method-spec
- (when mf
- (setq mf (set-fun-name mf method-spec)))
- (when mff
- (let ((name `(fast-method ,@(cdr method-spec))))
- (set-fun-name mff name)
- (unless mf
- (set-mf-property :name name)))))
- (when plist
+ (mff (and (typep mf '%method-function)
+ (%method-function-fast-function mf)))
+ (plist (getf initargs 'plist))
+ (name (getf plist :name)))
+ (when name
+ (when mf
+ (setq mf (set-fun-name mf name)))
+ (when (and mff (consp name) (eq (car name) 'slow-method))
+ (let ((fast-name `(fast-method ,@(cdr 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)
- (setq pv-table (intern-pv-table :slot-name-lists snl
- :call-list cl))
- (when pv-table (set pv-table-symbol pv-table))
- (set-mf-property :pv-table pv-table)))
- (loop (when (null plist) (return nil))
- (set-mf-property (pop plist) (pop plist)))
- (when method
- (set-mf-property :method method))
- (when return-function-p
- (or mf (method-function-from-fast-function mff)))))))
+ (setf (method-plist-value method :pv-table)
+ (intern-pv-table :slot-name-lists snl :call-list cl))))))))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
(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-qualifiers-index*
+ (!bootstrap-slot-index 'standard-method 'qualifiers))
(defvar *sm-plist-index*
(!bootstrap-slot-index 'standard-method 'plist))
;;; 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))
+(dolist (s '(specializers %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)
(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))))
+ (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-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))
+ (clos-slots-ref (get-slots method) *sm-qualifiers-index*)
(method-qualifiers method))))
(defun set-arg-info1 (gf arg-info new-method methods was-valid-p first-p)
(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))
- (eq (generic-function-method-combination gf)
- *standard-method-combination*)))
- (cond ((eq class *the-class-standard-reader-method*)
- 'reader)
- ((eq class *the-class-standard-writer-method*)
- 'writer)
- ((eq class *the-class-standard-boundp-method*)
- 'boundp)))))
+ (new-type
+ (when (and class
+ (or (not (eq *boot-state* 'complete))
+ (eq (generic-function-method-combination gf)
+ *standard-method-combination*)))
+ (cond ((or (eq class *the-class-standard-reader-method*)
+ (eq class *the-class-global-reader-method*))
+ 'reader)
+ ((or (eq class *the-class-standard-writer-method*)
+ (eq class *the-class-global-writer-method*))
+ 'writer)
+ ((or (eq class *the-class-standard-boundp-method*)
+ (eq class *the-class-global-boundp-method*))
+ 'boundp)))))
(setq metatypes (mapcar #'raise-metatype metatypes specializers))
(setq type (cond ((null type) new-type)
((eq type new-type) type)
(defun make-early-gf (spec &optional lambda-list lambda-list-p
function argument-precedence-order source-location)
- (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*)))
+ (let ((fin (allocate-standard-funcallable-instance
+ *sgf-wrapper* *sgf-slots-init*)))
(set-funcallable-instance-function
fin
(or function
fun-name
&rest all-keys
&key environment (lambda-list nil lambda-list-p)
- (generic-function-class 'standard-generic-function gf-class-p)
+ (generic-function-class 'standard-generic-function)
&allow-other-keys)
(real-ensure-gf-internal generic-function-class all-keys environment)
- (unless (or (null gf-class-p)
- (eq (class-of existing) generic-function-class))
+ ;; KLUDGE: the above macro does SETQ on GENERIC-FUNCTION-CLASS,
+ ;; which is what makes the next line work
+ (unless (eq (class-of existing) generic-function-class)
(change-class existing generic-function-class))
(prog1
(apply #'reinitialize-instance existing all-keys)
arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
- &optional slot-name)
- (initialize-method-function initargs)
+ &key slot-name object-class method-class-function)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
specializers))
(setq unparsed specializers
parsed ()))
- (list :early-method ;This is an early method dammit!
-
- (getf initargs :function)
- (getf initargs :fast-function)
-
- parsed ;The parsed specializers. This is used
- ;by early-method-specializers to cache
- ;the parse. Note that this only comes
- ;into play when there is more than one
- ;early method on an early gf.
-
- (list class ;A list to which real-make-a-method
- qualifiers ;can be applied to make a real method
- arglist ;corresponding to this early one.
- unparsed
- initargs
- doc
- slot-name))))
+ (let ((result
+ (list :early-method
+
+ (getf initargs :function)
+ (let ((mf (getf initargs :function)))
+ (aver mf)
+ (and (typep mf '%method-function)
+ (%method-function-fast-function mf)))
+
+ ;; the parsed specializers. This is used by
+ ;; EARLY-METHOD-SPECIALIZERS to cache the parse.
+ ;; Note that this only comes into play when there is
+ ;; more than one early method on an early gf.
+ parsed
+
+ ;; A list to which REAL-MAKE-A-METHOD can be applied
+ ;; to make a real method corresponding to this early
+ ;; one.
+ (append
+ (list class qualifiers arglist unparsed
+ initargs doc)
+ (when slot-name
+ (list :slot-name slot-name :object-class object-class
+ :method-class-function method-class-function))))))
+ (initialize-method-function initargs result)
+ result)))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
- &optional slot-name)
+ &rest args &key slot-name object-class method-class-function)
(setq specializers (parse-specializers specializers))
- (apply #'make-instance class
- :qualifiers qualifiers
- :lambda-list lambda-list
- :specializers specializers
- :documentation doc
- :slot-name slot-name
- :allow-other-keys t
- initargs))
+ (if method-class-function
+ (let* ((object-class (if (classp object-class) object-class
+ (find-class object-class)))
+ (slots (class-direct-slots object-class))
+ (slot-definition (find slot-name slots
+ :key #'slot-definition-name)))
+ (aver slot-name)
+ (aver slot-definition)
+ (let ((initargs (list* :qualifiers qualifiers :lambda-list lambda-list
+ :specializers specializers :documentation doc
+ :slot-definition slot-definition
+ :slot-name slot-name initargs)))
+ (apply #'make-instance
+ (apply method-class-function object-class slot-definition
+ initargs)
+ initargs)))
+ (apply #'make-instance class :qualifiers qualifiers
+ :lambda-list lambda-list :specializers specializers
+ :documentation doc (append args initargs))))
(defun early-method-function (early-method)
(values (cadr early-method) (caddr early-method)))
(eq class 'standard-boundp-method))))
(defun early-method-standard-accessor-slot-name (early-method)
- (seventh (fifth early-method)))
+ (eighth (fifth early-method)))
;;; Fetch the specializers of an early method. This is basically just
;;; a simple accessor except that when the second argument is t, this
(setf (fourth early-method)
(mapcar #'find-class (cadddr (fifth early-method))))))
(t
- (cadddr (fifth early-method))))
+ (fourth (fifth early-method))))
(error "~S is not an early-method." early-method)))
(defun early-method-qualifiers (early-method)
- (cadr (fifth early-method)))
+ (second (fifth early-method)))
(defun early-method-lambda-list (early-method)
- (caddr (fifth early-method)))
+ (third (fifth early-method)))
+
+(defun early-method-initargs (early-method)
+ (fifth (fifth early-method)))
+
+(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)
- (let* ((gf (ensure-generic-function generic-function-name))
+ (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
+ ;; functions. (See REAL-ADD-NAMED-METHOD)
+ (gf (ensure-generic-function generic-function-name))
(existing
(dolist (m (early-gf-methods gf))
(when (and (equal (early-method-specializers m) specializers)
projects / sbcl.git / blobdiff