parameters
specializers))
(slots (mapcar #'list required-parameters))
- (calls (list nil))
(class-declarations
`(declare
;; These declarations seem to be used by PCL to pass
(walk-method-lambda method-lambda
required-parameters
env
- slots
- calls)
+ slots)
(multiple-value-bind (walked-lambda-body
walked-declarations
walked-documentation)
(parse-body (cddr walked-lambda))
(declare (ignore walked-documentation))
(when (some #'cdr slots)
- (multiple-value-bind (slot-name-lists call-list)
- (slot-name-lists-from-slots slots calls)
+ (let ((slot-name-lists (slot-name-lists-from-slots slots)))
(setq plist
`(,@(when slot-name-lists
`(:slot-name-lists ,slot-name-lists))
- ,@(when call-list
- `(:call-list ,call-list))
,@plist))
(setq walked-lambda-body
`((pv-binding (,required-parameters
,slot-name-lists
(load-time-value
(intern-pv-table
- :slot-name-lists ',slot-name-lists
- :call-list ',call-list)))
+ :slot-name-lists ',slot-name-lists)))
,@walked-lambda-body)))))
(when (and (memq '&key lambda-list)
(not (memq '&allow-other-keys lambda-list)))
(defstruct (fast-method-call (:copier nil))
(function #'identity :type function)
- pv-cell
+ pv
next-method-call
arg-info)
(defstruct (constant-fast-method-call
(defmacro invoke-fast-method-call (method-call restp &rest required-args+rest-arg)
`(,(if restp 'apply 'funcall) (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args+rest-arg))
&rest required-args)
(macrolet ((generate-call (n)
``(funcall (fast-method-call-function ,method-call)
- (fast-method-call-pv-cell ,method-call)
+ (fast-method-call-pv ,method-call)
(fast-method-call-next-method-call ,method-call)
,@required-args
,@(loop for x below ,n
(0 ,(generate-call 0))
(1 ,(generate-call 1))
(t (multiple-value-call (fast-method-call-function ,method-call)
- (values (fast-method-call-pv-cell ,method-call))
+ (values (fast-method-call-pv ,method-call))
(values (fast-method-call-next-method-call ,method-call))
,@required-args
(sb-c::%more-arg-values ,more-context 0 ,more-count))))))
(nreq (car arg-info)))
(if restp
(apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
+ (fast-method-call-pv emf)
(fast-method-call-next-method-call emf)
args)
(cond ((null args)
:format-arguments nil)))
(t
(apply (fast-method-call-function emf)
- (fast-method-call-pv-cell emf)
+ (fast-method-call-pv emf)
(fast-method-call-next-method-call emf)
args))))))
(method-call
when (eq key keyword)
return tail))
-(defun walk-method-lambda (method-lambda required-parameters env slots calls)
+(defun walk-method-lambda (method-lambda required-parameters env slots)
(let (;; flag indicating that CALL-NEXT-METHOD should be in the
;; method definition
(call-next-method-p nil)
(set-fun-name mff fast-name))))
(when plist
(let ((plist plist))
- (let ((snl (getf plist :slot-name-lists))
- (cl (getf plist :call-list)))
- (when (or snl cl)
+ (let ((snl (getf plist :slot-name-lists)))
+ (when snl
(setf (method-plist-value method :pv-table)
- (intern-pv-table :slot-name-lists snl :call-list cl))))))))
+ (intern-pv-table :slot-name-lists snl))))))))
\f
(defun analyze-lambda-list (lambda-list)
(flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG?
arg-info)))
(defun early-make-a-method (class qualifiers arglist specializers initargs doc
- &key slot-name object-class method-class-function)
+ &key slot-name object-class method-class-function
+ definition-source)
(let ((parsed ())
(unparsed ()))
;; Figure out whether we got class objects or class names as the
initargs doc)
(when slot-name
(list :slot-name slot-name :object-class object-class
- :method-class-function method-class-function))))))
+ :method-class-function method-class-function))
+ (list :definition-source definition-source)))))
(initialize-method-function initargs result)
result)))
(defun real-make-a-method
(class qualifiers lambda-list specializers initargs doc
- &rest args &key slot-name object-class method-class-function)
+ &rest args &key slot-name object-class method-class-function
+ definition-source)
(if method-class-function
(let* ((object-class (if (classp object-class) object-class
(find-class object-class)))
(apply #'make-instance
(apply method-class-function object-class slot-definition
initargs)
+ :definition-source definition-source
initargs)))
(apply #'make-instance class :qualifiers qualifiers
:lambda-list lambda-list :specializers specializers
(setf (fifth (fifth early-method)) new-value))
(defun early-add-named-method (generic-function-name qualifiers
- specializers arglist &rest initargs)
+ specializers arglist &rest initargs
+ &key documentation definition-source
+ &allow-other-keys)
(let* (;; we don't need to deal with the :generic-function-class
;; argument here because the default,
;; STANDARD-GENERIC-FUNCTION, is right for all early generic
(setf (getf (getf initargs 'plist) :name)
(make-method-spec gf qualifiers specializers))
(let ((new (make-a-method 'standard-method qualifiers arglist
- specializers initargs (getf initargs :documentation))))
+ specializers initargs documentation
+ :definition-source definition-source)))
(when existing (remove-method gf existing))
(add-method gf new))))