X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=12467fa33bbf0fa9e2e9bd1d9c24da42605fe74c;hb=bc2977763a323f3e180dfb227081688cd8d021af;hp=b05694069d1d35efa36b872743a1b7f874925344;hpb=284c8f6833589a6bddf22a5af30d3ac4eafcd2cc;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index b056940..12467fa 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -252,8 +252,9 @@ bootstrapping. (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))) + (warn 'sb-kernel:redefinition-with-defgeneric :name fun-name + :old fun :new-location source-location) (when (generic-function-p fun) (loop for method in (generic-function-initial-methods fun) do (remove-method fun method)) @@ -575,7 +576,27 @@ bootstrapping. (setf (gdefinition 'make-method-initargs-form) (symbol-function 'real-make-method-initargs-form))) +;;; When bootstrapping PCL MAKE-METHOD-LAMBDA starts out as a regular +;;; functions: REAL-MAKE-METHOD-LAMBDA set to the fdefinition of +;;; MAKE-METHOD-LAMBDA. Once generic functions are born, the +;;; REAL-MAKE-METHOD lambda is used as the body of the default method. +;;; MAKE-METHOD-LAMBDA-INTERNAL is split out into a separate function +;;; so that changing it in a live image is easy, and changes actually +;;; take effect. (defun real-make-method-lambda (proto-gf proto-method method-lambda env) + (make-method-lambda-internal proto-gf proto-method method-lambda env)) + +(unless (fboundp 'make-method-lambda) + (setf (gdefinition 'make-method-lambda) + (symbol-function 'real-make-method-lambda))) + +(defun declared-specials (declarations) + (loop for (declare . specifiers) in declarations + append (loop for specifier in specifiers + when (eq 'special (car specifier)) + append (cdr specifier)))) + +(defun make-method-lambda-internal (proto-gf proto-method method-lambda env) (declare (ignore proto-gf proto-method)) (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ @@ -603,7 +624,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 @@ -627,9 +647,12 @@ bootstrapping. ;; KLUDGE: when I tried moving these to ;; ADD-METHOD-DECLARATIONS, things broke. No idea ;; why. -- CSR, 2004-06-16 - ,@(mapcar #'parameter-specializer-declaration-in-defmethod - parameters - specializers))) + ,@(let ((specials (declared-specials declarations))) + (mapcar (lambda (par spec) + (parameter-specializer-declaration-in-defmethod + par spec specials env)) + parameters + specializers)))) (method-lambda ;; Remove the documentation string and insert the ;; appropriate class declarations. The documentation @@ -678,29 +701,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))) @@ -731,10 +749,6 @@ bootstrapping. ,@(when plist `(plist ,plist)) ,@(when documentation `(:documentation ,documentation))))))))))) -(unless (fboundp 'make-method-lambda) - (setf (gdefinition 'make-method-lambda) - (symbol-function 'real-make-method-lambda))) - (defun real-make-method-specializers-form (proto-gf proto-method specializer-names env) (declare (ignore env proto-gf proto-method)) @@ -794,8 +808,12 @@ bootstrapping. (symbol-function 'real-unparse-specializer-using-class))) ;;; a helper function for creating Python-friendly type declarations -;;; in DEFMETHOD forms -(defun parameter-specializer-declaration-in-defmethod (parameter specializer) +;;; in DEFMETHOD forms. +;;; +;;; We're too lazy to cons up a new environment for this, so we just pass in +;;; the list of locally declared specials in addition to the old environment. +(defun parameter-specializer-declaration-in-defmethod + (parameter specializer specials env) (cond ((and (consp specializer) (eq (car specializer) 'eql)) ;; KLUDGE: ANSI, in its wisdom, says that @@ -848,16 +866,10 @@ bootstrapping. '(ignorable)) ((typep specializer 'eql-specializer) `(type (eql ,(eql-specializer-object specializer)) ,parameter)) - ((var-globally-special-p parameter) - ;; KLUDGE: Don't declare types for global special variables - ;; -- our rebinding magic for SETQ cases don't work right - ;; there. - ;; - ;; FIXME: It would be better to detect the SETQ earlier and - ;; skip declarations for specials only when needed, not - ;; always. - ;; - ;; --NS 2004-10-14 + ((or (var-special-p parameter env) (member parameter specials)) + ;; Don't declare types for special variables -- our rebinding magic + ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE), + ;; etc. make things undecidable. '(ignorable)) (t ;; Otherwise, we can usually make Python very happy. @@ -1011,7 +1023,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 @@ -1028,7 +1040,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)) @@ -1038,7 +1050,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 @@ -1052,7 +1064,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)))))) @@ -1200,7 +1212,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) @@ -1223,7 +1235,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 @@ -1429,7 +1441,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) @@ -1492,7 +1504,7 @@ bootstrapping. ;; another binding it won't have a %CLASS ;; declaration anymore, and this won't get ;; executed. - (pushnew var parameters-setqd)))) + (pushnew var parameters-setqd :test #'eq)))) form) ((and (eq (car form) 'function) (cond ((eq (cadr form) 'call-next-method) @@ -1568,8 +1580,10 @@ bootstrapping. (generic-function-methods gf) (find-method gf qualifiers specializers nil)))) (when method - (style-warn "redefining ~S~{ ~S~} ~S in DEFMETHOD" - gf-spec qualifiers specializers)))) + (style-warn 'sb-kernel:redefinition-with-defmethod + :generic-function gf-spec :old-method method + :qualifiers qualifiers :specializers specializers + :new-location source-location)))) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list :definition-source source-location @@ -1609,11 +1623,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? @@ -1695,9 +1708,6 @@ bootstrapping. (when (or allow-other-keys-p old-allowp) '(&allow-other-keys))))) *)))) - -(defun defgeneric-declaration (spec lambda-list) - `(ftype ,(ftype-declaration-from-lambda-list lambda-list spec) ,spec)) ;;;; early generic function support @@ -1910,14 +1920,19 @@ bootstrapping. (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)))) + (!bootstrap-slot-index 'standard-boundp-method s) + (!bootstrap-slot-index 'global-reader-method s) + (!bootstrap-slot-index 'global-writer-method s) + (!bootstrap-slot-index 'global-boundp-method s)))) + +(define-symbol-macro *standard-method-classes* + (list *the-class-standard-method* *the-class-standard-reader-method* + *the-class-standard-writer-method* *the-class-standard-boundp-method* + *the-class-global-reader-method* *the-class-global-writer-method* + *the-class-global-boundp-method*)) (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*)) + (let ((standard-method-classes *standard-method-classes*) (class (class-of method))) (if (member class standard-method-classes) (clos-slots-ref (get-slots method) *sm-specializers-index*) @@ -1927,21 +1942,13 @@ bootstrapping. (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-reader-method* - *the-class-standard-writer-method* - *the-class-standard-boundp-method*)) + (let ((standard-method-classes *standard-method-classes*) (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*)) + (let ((standard-method-classes *standard-method-classes*) (class (class-of method))) (if (member class standard-method-classes) (clos-slots-ref (get-slots method) *sm-qualifiers-index*) @@ -2008,6 +2015,7 @@ bootstrapping. (package (symbol-package symbol))) (and (or (eq package *pcl-package*) (memq package (package-use-list *pcl-package*))) + (not (eq package #.(find-package "CL"))) ;; FIXME: this test will eventually be ;; superseded by the *internal-pcl...* test, ;; above. While we are in a process of @@ -2044,6 +2052,7 @@ bootstrapping. lambda-list-p) argument-precedence-order source-location + documentation &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -2053,7 +2062,8 @@ bootstrapping. ((assoc spec *!generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order source-location) + argument-precedence-order source-location + documentation) (bug "The function ~S is not already defined." spec))) (existing (bug "~S should be on the list ~S." @@ -2061,10 +2071,12 @@ bootstrapping. (t (pushnew spec *!early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order source-location)))) + argument-precedence-order source-location + documentation)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p - function argument-precedence-order source-location) + function argument-precedence-order source-location + documentation) (let ((fin (allocate-standard-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function @@ -2080,15 +2092,18 @@ bootstrapping. has not been set." fin))))) (setf (gdefinition spec) fin) (!bootstrap-set-slot 'standard-generic-function fin 'name spec) - (!bootstrap-set-slot 'standard-generic-function - fin - 'source - source-location) + (!bootstrap-set-slot 'standard-generic-function fin + 'source source-location) + (!bootstrap-set-slot 'standard-generic-function fin + '%documentation documentation) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) (when lambda-list-p - (proclaim (defgeneric-declaration spec lambda-list)) + (setf (info :function :type spec) + (specifier-type + (ftype-declaration-from-lambda-list lambda-list spec)) + (info :function :where-from spec) :defined-method) (if argument-precedence-order (set-arg-info fin :lambda-list lambda-list @@ -2208,7 +2223,10 @@ bootstrapping. (prog1 (apply #'reinitialize-instance existing all-keys) (when lambda-list-p - (proclaim (defgeneric-declaration fun-name lambda-list))))) + (setf (info :function :type fun-name) + (specifier-type + (ftype-declaration-from-lambda-list lambda-list fun-name)) + (info :function :where-from fun-name) :defined-method)))) (defun real-ensure-gf-using-class--null (existing @@ -2224,7 +2242,10 @@ bootstrapping. (apply #'make-instance generic-function-class :name fun-name all-keys)) (when lambda-list-p - (proclaim (defgeneric-declaration fun-name lambda-list))))) + (setf (info :function :type fun-name) + (specifier-type + (ftype-declaration-from-lambda-list lambda-list fun-name)) + (info :function :where-from fun-name) :defined-method)))) (defun safe-gf-arg-info (generic-function) (if (eq (class-of generic-function) *the-class-standard-generic-function*) @@ -2259,7 +2280,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 @@ -2300,13 +2322,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))) @@ -2322,6 +2346,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 @@ -2380,7 +2405,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 @@ -2394,7 +2421,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 ()))) + specializers initargs documentation + :definition-source definition-source))) (when existing (remove-method gf existing)) (add-method gf new))))