X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=ecb3bcf4fd6ca114c47d75c18e0efc29dc73b3c5;hb=b5cb7e8676a8bb88e647ceaf5f2571943b960c05;hp=7b6fb1a18c8db15e2e7bbe9a4629e4d18996cf9b;hpb=0ee1135a83da462e6de2a98bb2eff837b278f926;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 7b6fb1a..ecb3bcf 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)) @@ -352,7 +353,7 @@ bootstrapping. (defun prototypes-for-make-method-lambda (name) - (if (not (eq *boot-state* 'complete)) + (if (not (eq **boot-state** 'complete)) (values nil nil) (let ((gf? (and (fboundp name) (gdefinition name)))) @@ -378,7 +379,7 @@ bootstrapping. (defun method-prototype-for-gf (name) (let ((gf? (and (fboundp name) (gdefinition name)))) - (cond ((neq *boot-state* 'complete) nil) + (cond ((neq **boot-state** 'complete) nil) ((or (null gf?) (not (generic-function-p gf?))) ; Someone else MIGHT ; error at load time. @@ -513,9 +514,6 @@ bootstrapping. (sb-c:source-location))) (defmacro make-method-function (method-lambda &environment env) - (make-method-function-internal method-lambda env)) - -(defun make-method-function-internal (method-lambda &optional env) (multiple-value-bind (proto-gf proto-method) (prototypes-for-make-method-lambda nil) (multiple-value-bind (method-function-lambda initargs) @@ -578,28 +576,200 @@ 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) - (declare (ignore proto-gf proto-method)) - (make-method-lambda-internal 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, ~ + is not a lambda form." + method-lambda)) + (multiple-value-bind (real-body declarations documentation) + (parse-body (cddr method-lambda)) + (let* ((name-decl (get-declaration '%method-name declarations)) + (sll-decl (get-declaration '%method-lambda-list declarations)) + (method-name (when (consp name-decl) (car name-decl))) + (generic-function-name (when method-name (car method-name))) + (specialized-lambda-list (or sll-decl (cadr method-lambda))) + ;; the method-cell is a way of communicating what method a + ;; method-function implements, for the purpose of + ;; NO-NEXT-METHOD. We need something that can be shared + ;; between function and initargs, but not something that + ;; will be coalesced as a constant (because we are naughty, + ;; oh yes) with the expansion of any other methods in the + ;; same file. -- CSR, 2007-05-30 + (method-cell (list (make-symbol "METHOD-CELL")))) + (multiple-value-bind (parameters lambda-list specializers) + (parse-specialized-lambda-list specialized-lambda-list) + (let* ((required-parameters + (mapcar (lambda (r s) (declare (ignore s)) r) + parameters + specializers)) + (slots (mapcar #'list required-parameters)) + (class-declarations + `(declare + ;; These declarations seem to be used by PCL to pass + ;; information to itself; when I tried to delete 'em + ;; ca. 0.6.10 it didn't work. I'm not sure how + ;; they work, but note the (VAR-DECLARATION '%CLASS ..) + ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 + ,@(remove nil + (mapcar (lambda (a s) (and (symbolp s) + (neq s t) + `(%class ,a ,s))) + parameters + specializers)) + ;; These TYPE declarations weren't in the original + ;; PCL code, but the Python compiler likes them a + ;; lot. (We're telling the compiler about our + ;; knowledge of specialized argument types so that + ;; it can avoid run-time type dispatch overhead, + ;; which can be a huge win for Python.) + ;; + ;; KLUDGE: when I tried moving these to + ;; ADD-METHOD-DECLARATIONS, things broke. No idea + ;; why. -- CSR, 2004-06-16 + ,@(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 + ;; string is removed to make it easy for us to insert + ;; new declarations later, they will just go after the + ;; CADR of the method lambda. The class declarations + ;; are inserted to communicate the class of the method's + ;; arguments to the code walk. + `(lambda ,lambda-list + ;; The default ignorability of method parameters + ;; doesn't seem to be specified by ANSI. PCL had + ;; them basically ignorable but was a little + ;; inconsistent. E.g. even though the two + ;; method definitions + ;; (DEFMETHOD FOO ((X T) (Y T)) "Z") + ;; (DEFMETHOD FOO ((X T) Y) "Z") + ;; are otherwise equivalent, PCL treated Y as + ;; ignorable in the first definition but not in the + ;; second definition. We make all required + ;; parameters ignorable as a way of systematizing + ;; the old PCL behavior. -- WHN 2000-11-24 + (declare (ignorable ,@required-parameters)) + ,class-declarations + ,@declarations + (block ,(fun-name-block-name generic-function-name) + ,@real-body))) + (constant-value-p (and (null (cdr real-body)) + (constantp (car real-body)))) + (constant-value (and constant-value-p + (constant-form-value (car real-body)))) + (plist (and constant-value-p + (or (typep constant-value + '(or number character)) + (and (symbolp constant-value) + (symbol-package constant-value))) + (list :constant-value constant-value))) + (applyp (dolist (p lambda-list nil) + (cond ((memq p '(&optional &rest &key)) + (return t)) + ((eq p '&aux) + (return nil)))))) + (multiple-value-bind + (walked-lambda call-next-method-p closurep + next-method-p-p setq-p + parameters-setqd) + (walk-method-lambda method-lambda + required-parameters + env + slots) + (multiple-value-bind (walked-lambda-body + walked-declarations + walked-documentation) + (parse-body (cddr walked-lambda)) + (declare (ignore walked-documentation)) + (when (some #'cdr slots) + (let ((slot-name-lists (slot-name-lists-from-slots slots))) + (setq plist + `(,@(when slot-name-lists + `(:slot-name-lists ,slot-name-lists)) + ,@plist)) + (setq walked-lambda-body + `((pv-binding (,required-parameters + ,slot-name-lists + (load-time-value + (intern-pv-table + :slot-name-lists ',slot-name-lists))) + ,@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)))) + (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 + :parameters-setqd ,parameters-setqd + :method-cell ,method-cell + :closurep ,closurep + :applyp ,applyp) + ,@walked-declarations + (locally + (declare (disable-package-locks + %parameter-binding-modified)) + (symbol-macrolet ((%parameter-binding-modified + ',@parameters-setqd)) + (declare (enable-package-locks + %parameter-binding-modified)) + ,@walked-lambda-body)))) + `(,@(when call-next-method-p `(method-cell ,method-cell)) + ,@(when plist `(plist ,plist)) + ,@(when documentation `(:documentation ,documentation))))))))))) + (defun real-make-method-specializers-form (proto-gf proto-method specializer-names env) (declare (ignore env proto-gf proto-method)) (flet ((parse (name) (cond - ((and (eq *boot-state* 'complete) + ((and (eq **boot-state** 'complete) (specializerp name)) name) ((symbolp name) `(find-class ',name)) ((consp name) (ecase (car name) ((eql) `(intern-eql-specializer ,(cadr name))) - ((class-eq) `(class-eq-specializer (find-class ',(cadr name)))) - ((prototype) `(fixme)))) - (t (bug "Foo"))))) + ((class-eq) `(class-eq-specializer (find-class ',(cadr name)))))) + (t + ;; FIXME: Document CLASS-EQ specializers. + (error 'simple-reference-error + :format-control + "~@<~S is not a valid parameter specializer name.~@:>" + :format-arguments (list name) + :references (list '(:ansi-cl :macro defmethod) + '(:ansi-cl :glossary "parameter specializer name"))))))) `(list ,@(mapcar #'parse specializer-names)))) (unless (fboundp 'make-method-specializers-form) @@ -645,8 +815,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 @@ -690,7 +864,7 @@ bootstrapping. ;; cases by blacklisting them here. -- WHN 2001-01-19 (list 'slot-object #+nil (find-class 'slot-object))) '(ignorable)) - ((not (eq *boot-state* 'complete)) + ((not (eq **boot-state** 'complete)) ;; KLUDGE: PCL, in its wisdom, sometimes calls methods with ;; types which don't match their specializers. (Specifically, ;; it calls ENSURE-CLASS-USING-CLASS (T NULL) with a non-NULL @@ -699,16 +873,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. @@ -747,7 +915,7 @@ bootstrapping. ;; the user defines a type and calls (SETF ;; FIND-CLASS) in a consistent way. (when (and class (typep class 'built-in-class)) - `(type ,specializer-nameoid ,parameter)))) + `(type ,(class-name class) ,parameter)))) ((:instance nil) (let ((class (specializer-nameoid-class))) (cond @@ -776,161 +944,6 @@ bootstrapping. ;;; optimized-slot-value* macros. (define-symbol-macro %parameter-binding-modified ()) -(defun make-method-lambda-internal (method-lambda &optional env) - (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda)) - (error "The METHOD-LAMBDA argument to MAKE-METHOD-LAMBDA, ~S, ~ - is not a lambda form." - method-lambda)) - (multiple-value-bind (real-body declarations documentation) - (parse-body (cddr method-lambda)) - (let* ((name-decl (get-declaration '%method-name declarations)) - (sll-decl (get-declaration '%method-lambda-list declarations)) - (method-name (when (consp name-decl) (car name-decl))) - (generic-function-name (when method-name (car method-name))) - (specialized-lambda-list (or sll-decl (cadr method-lambda))) - ;; the method-cell is a way of communicating what method a - ;; method-function implements, for the purpose of - ;; NO-NEXT-METHOD. We need something that can be shared - ;; between function and initargs, but not something that - ;; will be coalesced as a constant (because we are naughty, - ;; oh yes) with the expansion of any other methods in the - ;; same file. -- CSR, 2007-05-30 - (method-cell (list (make-symbol "METHOD-CELL")))) - (multiple-value-bind (parameters lambda-list specializers) - (parse-specialized-lambda-list specialized-lambda-list) - (let* ((required-parameters - (mapcar (lambda (r s) (declare (ignore s)) r) - parameters - specializers)) - (slots (mapcar #'list required-parameters)) - (calls (list nil)) - (class-declarations - `(declare - ;; These declarations seem to be used by PCL to pass - ;; information to itself; when I tried to delete 'em - ;; ca. 0.6.10 it didn't work. I'm not sure how - ;; they work, but note the (VAR-DECLARATION '%CLASS ..) - ;; expression in CAN-OPTIMIZE-ACCESS1. -- WHN 2000-12-30 - ,@(remove nil - (mapcar (lambda (a s) (and (symbolp s) - (neq s t) - `(%class ,a ,s))) - parameters - specializers)) - ;; These TYPE declarations weren't in the original - ;; PCL code, but the Python compiler likes them a - ;; lot. (We're telling the compiler about our - ;; knowledge of specialized argument types so that - ;; it can avoid run-time type dispatch overhead, - ;; which can be a huge win for Python.) - ;; - ;; 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))) - (method-lambda - ;; Remove the documentation string and insert the - ;; appropriate class declarations. The documentation - ;; string is removed to make it easy for us to insert - ;; new declarations later, they will just go after the - ;; CADR of the method lambda. The class declarations - ;; are inserted to communicate the class of the method's - ;; arguments to the code walk. - `(lambda ,lambda-list - ;; The default ignorability of method parameters - ;; doesn't seem to be specified by ANSI. PCL had - ;; them basically ignorable but was a little - ;; inconsistent. E.g. even though the two - ;; method definitions - ;; (DEFMETHOD FOO ((X T) (Y T)) "Z") - ;; (DEFMETHOD FOO ((X T) Y) "Z") - ;; are otherwise equivalent, PCL treated Y as - ;; ignorable in the first definition but not in the - ;; second definition. We make all required - ;; parameters ignorable as a way of systematizing - ;; the old PCL behavior. -- WHN 2000-11-24 - (declare (ignorable ,@required-parameters)) - ,class-declarations - ,@declarations - (block ,(fun-name-block-name generic-function-name) - ,@real-body))) - (constant-value-p (and (null (cdr real-body)) - (constantp (car real-body)))) - (constant-value (and constant-value-p - (constant-form-value (car real-body)))) - (plist (and constant-value-p - (or (typep constant-value - '(or number character)) - (and (symbolp constant-value) - (symbol-package constant-value))) - (list :constant-value constant-value))) - (applyp (dolist (p lambda-list nil) - (cond ((memq p '(&optional &rest &key)) - (return t)) - ((eq p '&aux) - (return nil)))))) - (multiple-value-bind - (walked-lambda call-next-method-p closurep - next-method-p-p setq-p - parameters-setqd) - (walk-method-lambda method-lambda - required-parameters - env - slots - calls) - (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) - (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))) - (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 - :method-cell ,method-cell - :closurep ,closurep - :applyp ,applyp) - ,@walked-declarations - (locally - (declare (disable-package-locks - %parameter-binding-modified)) - (symbol-macrolet ((%parameter-binding-modified - ',@parameters-setqd)) - (declare (enable-package-locks - %parameter-binding-modified)) - ,@walked-lambda-body)))) - `(,@(when call-next-method-p `(method-cell ,method-cell)) - ,@(when plist `(plist ,plist)) - ,@(when documentation `(:documentation ,documentation))))))))))) - (defmacro simple-lexical-method-functions ((lambda-list method-args next-methods @@ -955,7 +968,7 @@ bootstrapping. (defmacro bind-simple-lexical-method-functions ((method-args next-methods (&key call-next-method-p next-method-p-p setq-p - closurep applyp method-cell)) + parameters-setqd closurep applyp method-cell)) &body body &environment env) (if (not (or call-next-method-p setq-p closurep next-method-p-p applyp)) @@ -989,9 +1002,25 @@ bootstrapping. (defun call-no-next-method (method-cell &rest args) (let ((method (car method-cell))) (aver method) + ;; Can't easily provide a RETRY restart here, as the return value here is + ;; for the method, not the generic function. (apply #'no-next-method (method-generic-function method) method args))) +(defun call-no-applicable-method (gf args) + (restart-case + (apply #'no-applicable-method gf args) + (retry () + :report "Retry calling the generic function." + (apply gf args)))) + +(defun call-no-primary-method (gf args) + (restart-case + (apply #'no-primary-method gf args) + (retry () + :report "Retry calling the generic function." + (apply gf args)))) + (defstruct (method-call (:copier nil)) (function #'identity :type function) call-method-args) @@ -1017,7 +1046,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 @@ -1034,7 +1063,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)) @@ -1044,7 +1073,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 @@ -1058,7 +1087,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)))))) @@ -1206,7 +1235,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) @@ -1229,7 +1258,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 @@ -1290,6 +1319,7 @@ bootstrapping. ((args rest-arg next-method-call (&key call-next-method-p setq-p + parameters-setqd method-cell next-method-p-p closurep @@ -1435,7 +1465,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) @@ -1463,23 +1493,6 @@ bootstrapping. (setq next-method-p-p t) form) ((memq (car form) '(setq multiple-value-setq)) - ;; FIXME: this is possibly a little strong as - ;; conditions go. Ideally we would want to detect - ;; which, if any, of the method parameters are - ;; being set, and communicate that information to - ;; e.g. SPLIT-DECLARATIONS. However, the brute - ;; force method doesn't really cost much; a little - ;; loss of discrimination over IGNORED variables - ;; should be all. -- CSR, 2004-07-01 - ;; - ;; As of 2006-09-18 modified parameter bindings - ;; are now tracked with more granularity than just - ;; one SETQ-P flag, in order to disable SLOT-VALUE - ;; optimizations for parameters that are SETQd. - ;; The old binary SETQ-P flag is still used for - ;; all other purposes, since as noted above, the - ;; extra cost is minimal. -- JES, 2006-09-18 - ;; ;; The walker will split (SETQ A 1 B 2) to ;; separate (SETQ A 1) and (SETQ B 2) forms, so we ;; only need to handle the simple case of SETQ @@ -1498,7 +1511,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) @@ -1512,15 +1525,12 @@ bootstrapping. (t nil)))) ((and (memq (car form) '(slot-value set-slot-value slot-boundp)) - (constantp (caddr form))) - (let ((parameter (can-optimize-access form - required-parameters - env))) - (let ((fun (ecase (car form) - (slot-value #'optimize-slot-value) - (set-slot-value #'optimize-set-slot-value) - (slot-boundp #'optimize-slot-boundp)))) - (funcall fun slots parameter form)))) + (constantp (caddr form) env)) + (let ((fun (ecase (car form) + (slot-value #'optimize-slot-value) + (set-slot-value #'optimize-set-slot-value) + (slot-boundp #'optimize-slot-boundp)))) + (funcall fun form slots required-parameters env))) (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) @@ -1540,7 +1550,7 @@ bootstrapping. (defun generic-function-name-p (name) (and (legal-fun-name-p name) (fboundp name) - (if (eq *boot-state* 'complete) + (if (eq **boot-state** 'complete) (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) @@ -1570,15 +1580,17 @@ bootstrapping. (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list initargs source-location) - (when (and (eq *boot-state* 'complete) + (when (and (eq **boot-state** 'complete) (fboundp gf-spec)) (let* ((gf (fdefinition gf-spec)) (method (and (generic-function-p gf) (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 @@ -1618,11 +1630,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? @@ -1704,9 +1715,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 @@ -1720,7 +1728,7 @@ bootstrapping. (let ((existing (and (fboundp fun-name) (gdefinition fun-name)))) (cond ((and existing - (eq *boot-state* 'complete) + (eq **boot-state** 'complete) (null (generic-function-p existing))) (generic-clobbers-function fun-name) (fmakunbound fun-name) @@ -1749,32 +1757,32 @@ bootstrapping. +slot-unbound+)))) (early-collect-inheritance 'standard-generic-function))) -(defvar *sgf-method-class-index* +(defconstant +sgf-method-class-index+ (!bootstrap-slot-index 'standard-generic-function 'method-class)) (defun early-gf-p (x) (and (fsc-instance-p x) - (eq (clos-slots-ref (get-slots x) *sgf-method-class-index*) + (eq (clos-slots-ref (get-slots x) +sgf-method-class-index+) +slot-unbound+))) -(defvar *sgf-methods-index* +(defconstant +sgf-methods-index+ (!bootstrap-slot-index 'standard-generic-function 'methods)) (defmacro early-gf-methods (gf) - `(clos-slots-ref (get-slots ,gf) *sgf-methods-index*)) + `(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*) + (clos-slots-ref (get-slots generic-function) +sgf-methods-index+) (generic-function-methods generic-function))) -(defvar *sgf-arg-info-index* +(defconstant +sgf-arg-info-index+ (!bootstrap-slot-index 'standard-generic-function 'arg-info)) (defmacro early-gf-arg-info (gf) - `(clos-slots-ref (get-slots ,gf) *sgf-arg-info-index*)) + `(clos-slots-ref (get-slots ,gf) +sgf-arg-info-index+)) -(defvar *sgf-dfun-state-index* +(defconstant +sgf-dfun-state-index+ (!bootstrap-slot-index 'standard-generic-function 'dfun-state)) (defstruct (arg-info @@ -1820,10 +1828,10 @@ bootstrapping. (defun set-arg-info (gf &key new-method (lambda-list nil lambda-list-p) argument-precedence-order) - (let* ((arg-info (if (eq *boot-state* 'complete) + (let* ((arg-info (if (eq **boot-state** 'complete) (gf-arg-info gf) (early-gf-arg-info gf))) - (methods (if (eq *boot-state* 'complete) + (methods (if (eq **boot-state** 'complete) (generic-function-methods gf) (early-gf-methods gf))) (was-valid-p (integerp (arg-info-number-optional arg-info))) @@ -1902,59 +1910,51 @@ bootstrapping. ~S." gf-keywords))))))) -(defvar *sm-specializers-index* +(defconstant +sm-specializers-index+ (!bootstrap-slot-index 'standard-method 'specializers)) -(defvar *sm-%function-index* +(defconstant +sm-%function-index+ (!bootstrap-slot-index 'standard-method '%function)) -(defvar *sm-qualifiers-index* +(defconstant +sm-qualifiers-index+ (!bootstrap-slot-index 'standard-method 'qualifiers)) -(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 %function plist)) - (aver (= (symbol-value (intern (format nil "*SM-~A-INDEX*" s))) +(dolist (s '(specializers %function)) + (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)))) + +(defvar *standard-method-class-names* + '(standard-method standard-reader-method + standard-writer-method standard-boundp-method + global-reader-method global-writer-method + global-boundp-method)) + +(declaim (list **standard-method-classes**)) +(defglobal **standard-method-classes** nil) (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)))) + (if (member (class-of method) **standard-method-classes** :test #'eq) + (clos-slots-ref (std-instance-slots method) +sm-specializers-index+) + (method-specializers method))) (defun safe-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-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)))) + (if (member (class-of method) **standard-method-classes** :test #'eq) + (clos-slots-ref (std-instance-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) - (clos-slots-ref (get-slots method) *sm-qualifiers-index*) - (method-qualifiers method)))) + (if (member (class-of method) **standard-method-classes** :test #'eq) + (clos-slots-ref (std-instance-slots method) +sm-qualifiers-index+) + (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)) @@ -1967,16 +1967,16 @@ bootstrapping. nil))) (when (arg-info-valid-p arg-info) (dolist (method (if new-method (list new-method) methods)) - (let* ((specializers (if (or (eq *boot-state* 'complete) + (let* ((specializers (if (or (eq **boot-state** 'complete) (not (consp method))) (safe-method-specializers method) (early-method-specializers method t))) - (class (if (or (eq *boot-state* 'complete) (not (consp method))) + (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)) + (or (not (eq **boot-state** 'complete)) (eq (generic-function-method-combination gf) *standard-method-combination*))) (cond ((or (eq class *the-class-standard-reader-method*) @@ -2004,7 +2004,7 @@ bootstrapping. (unless (gf-info-c-a-m-emf-std-p arg-info) (setf (gf-info-simple-accessor-type arg-info) t)))) (unless was-valid-p - (let ((name (if (eq *boot-state* 'complete) + (let ((name (if (eq **boot-state** 'complete) (generic-function-name gf) (!early-gf-name gf)))) (setf (gf-precompute-dfun-and-emf-p arg-info) @@ -2017,6 +2017,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 @@ -2024,7 +2025,7 @@ bootstrapping. ;; remain. (not (find #\Space (symbol-name symbol)))))))))) (setf (gf-info-fast-mf-p arg-info) - (or (not (eq *boot-state* 'complete)) + (or (not (eq **boot-state** 'complete)) (let* ((method-class (generic-function-method-class gf)) (methods (compute-applicable-methods #'make-method-lambda @@ -2053,6 +2054,7 @@ bootstrapping. lambda-list-p) argument-precedence-order source-location + documentation &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -2062,7 +2064,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." @@ -2070,10 +2073,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 @@ -2089,15 +2094,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 @@ -2107,12 +2115,12 @@ bootstrapping. (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*) + (clos-slots-ref (fsc-instance-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*) + (setf (clos-slots-ref (fsc-instance-slots generic-function) + +sgf-dfun-state-index+) new-value) (setf (gf-dfun-state generic-function) new-value))) @@ -2121,44 +2129,44 @@ bootstrapping. (list* dfun cache info) dfun))) (cond - ((eq *boot-state* 'complete) + ((eq **boot-state** 'complete) ;; Check that we are under the lock. #+sb-thread (aver (eq sb-thread:*current-thread* (sb-thread::spinlock-value (gf-lock gf)))) (setf (safe-gf-dfun-state gf) new-state)) (t - (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) + (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) + (let ((state (if (eq **boot-state** 'complete) (safe-gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)))) (typecase state (function nil) (cons (cadr state))))) (defun gf-dfun-info (gf) - (let ((state (if (eq *boot-state* 'complete) + (let ((state (if (eq **boot-state** 'complete) (safe-gf-dfun-state gf) - (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) + (clos-slots-ref (get-slots gf) +sgf-dfun-state-index+)))) (typecase state (function nil) (cons (cddr state))))) -(defvar *sgf-name-index* +(defconstant +sgf-name-index+ (!bootstrap-slot-index 'standard-generic-function 'name)) (defun !early-gf-name (gf) - (clos-slots-ref (get-slots gf) *sgf-name-index*)) + (clos-slots-ref (get-slots gf) +sgf-name-index+)) (defun gf-lambda-list (gf) - (let ((arg-info (if (eq *boot-state* 'complete) + (let ((arg-info (if (eq **boot-state** 'complete) (gf-arg-info gf) (early-gf-arg-info gf)))) (if (eq :no-lambda-list (arg-info-lambda-list arg-info)) - (let ((methods (if (eq *boot-state* 'complete) + (let ((methods (if (eq **boot-state** 'complete) (generic-function-methods gf) (early-gf-methods gf)))) (if (null methods) @@ -2202,6 +2210,43 @@ bootstrapping. method-class) (t (find-class method-class t ,env)))))))) +(defun note-gf-signature (fun-name lambda-list-p lambda-list) + (unless lambda-list-p + ;; Use the existing lambda-list, if any. It is reasonable to do eg. + ;; + ;; (if (fboundp name) + ;; (ensure-generic-function name) + ;; (ensure-generic-function name :lambda-list '(foo))) + ;; + ;; in which case we end up here with no lambda-list in the first leg. + (setf (values lambda-list lambda-list-p) + (handler-case + (values (generic-function-lambda-list (fdefinition fun-name)) + t) + ((or warning error) () + (values nil nil))))) + (let ((gf-type + (specifier-type + (if lambda-list-p + (ftype-declaration-from-lambda-list lambda-list fun-name) + 'function))) + (old-type nil)) + ;; FIXME: Ideally we would like to not clobber it, but because generic + ;; functions assert their FTYPEs callers believing the FTYPE are left with + ;; unsafe assumptions. Hence the clobbering. Be quiet when the new type + ;; is a subtype of the old one, though -- even though the type is not + ;; trusted anymore, the warning is still not quite as interesting. + (when (and (eq :declared (info :function :where-from fun-name)) + (not (csubtypep gf-type (setf old-type (info :function :type fun-name))))) + (style-warn "~@" + fun-name 'ftype + (type-specifier old-type) + (type-specifier gf-type))) + (setf (info :function :type fun-name) gf-type + (info :function :where-from fun-name) :defined-method) + fun-name)) + (defun real-ensure-gf-using-class--generic-function (existing fun-name @@ -2216,8 +2261,7 @@ bootstrapping. (change-class existing generic-function-class)) (prog1 (apply #'reinitialize-instance existing all-keys) - (when lambda-list-p - (proclaim (defgeneric-declaration fun-name lambda-list))))) + (note-gf-signature fun-name lambda-list-p lambda-list))) (defun real-ensure-gf-using-class--null (existing @@ -2232,13 +2276,12 @@ bootstrapping. (setf (gdefinition fun-name) (apply #'make-instance generic-function-class :name fun-name all-keys)) - (when lambda-list-p - (proclaim (defgeneric-declaration fun-name lambda-list))))) + (note-gf-signature fun-name lambda-list-p 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*) + +sgf-arg-info-index+) (gf-arg-info generic-function))) ;;; FIXME: this function took on a slightly greater role than it @@ -2268,7 +2311,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 @@ -2309,13 +2353,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))) @@ -2331,6 +2377,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 @@ -2389,7 +2436,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 @@ -2403,7 +2452,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)))) @@ -2662,25 +2712,38 @@ bootstrapping. (t (multiple-value-bind (parameters lambda-list specializers required) (parse-specialized-lambda-list (cdr arglist)) + ;; Check for valid arguments. + (unless (or (and (symbolp arg) (not (null arg))) + (and (consp arg) + (consp (cdr arg)) + (null (cddr arg)))) + (error 'specialized-lambda-list-error + :format-control "arg is not a non-NIL symbol or a list of two elements: ~A" + :format-arguments (list arg))) (values (cons (if (listp arg) (car arg) arg) parameters) (cons (if (listp arg) (car arg) arg) lambda-list) (cons (if (listp arg) (cadr arg) t) specializers) (cons (if (listp arg) (car arg) arg) required))))))) -(setq *boot-state* 'early) +(setq **boot-state** 'early) ;;; FIXME: In here there was a #-CMU definition of SYMBOL-MACROLET ;;; which used %WALKER stuff. That suggests to me that maybe the code ;;; walker stuff was only used for implementing stuff like that; maybe ;;; it's not needed any more? Hunt down what it was used for and see. +(defun extract-the (form) + (cond ((and (consp form) (eq (car form) 'the)) + (aver (proper-list-of-length-p form 3)) + (third form)) + (t + form))) + (defmacro with-slots (slots instance &body body) (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) + ,@(let ((instance (extract-the instance))) (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in @@ -2702,9 +2765,7 @@ bootstrapping. (let ((in (gensym))) `(let ((,in ,instance)) (declare (ignorable ,in)) - ,@(let ((instance (if (and (consp instance) (eq (car instance) 'the)) - (third instance) - instance))) + ,@(let ((instance (extract-the instance))) (and (symbolp instance) `((declare (%variable-rebinding ,in ,instance))))) ,in