X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=e6006942ec8b0bc4b01a83fb4b50a3fc8a5bdb37;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=017e1471ad81ca7e03a756a4d912c7308ba1d9aa;hpb=f3666325b394cc61492be8aaf9621d66e7d9c0bd;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 017e147..e600694 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -617,7 +617,6 @@ bootstrapping. parameters specializers)) (slots (mapcar #'list required-parameters)) - (calls (list nil)) (class-declarations `(declare ;; These declarations seem to be used by PCL to pass @@ -692,29 +691,24 @@ bootstrapping. (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))) @@ -1021,7 +1015,7 @@ bootstrapping. (defstruct (fast-method-call (:copier nil)) (function #'identity :type function) - pv-cell + pv next-method-call arg-info) (defstruct (constant-fast-method-call @@ -1038,7 +1032,7 @@ bootstrapping. (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)) @@ -1048,7 +1042,7 @@ bootstrapping. &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 @@ -1062,7 +1056,7 @@ bootstrapping. (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)))))) @@ -1210,7 +1204,7 @@ bootstrapping. (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) @@ -1233,7 +1227,7 @@ bootstrapping. :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 @@ -1439,7 +1433,7 @@ bootstrapping. 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) @@ -1619,11 +1613,10 @@ bootstrapping. (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)))))))) (defun analyze-lambda-list (lambda-list) (flet (;; FIXME: Is this redundant with SB-C::MAKE-KEYWORD-FOR-ARG? @@ -2273,7 +2266,8 @@ bootstrapping. 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 @@ -2314,13 +2308,15 @@ bootstrapping. 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))) @@ -2336,6 +2332,7 @@ bootstrapping. (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 @@ -2394,7 +2391,9 @@ bootstrapping. (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 @@ -2408,7 +2407,8 @@ bootstrapping. (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))))