X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fboot.lisp;h=fc939a6c5eb645c36c857a662a5499b8ea104083;hb=47bf3e24a52a2687bd8f07c4674cb9e81163085d;hp=411411091af84d974c20e71edd3d3f92a1c9553f;hpb=3a5eefac8a65dfd36729031f0a9b9dd8c022b7f2;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 4114110..fc939a6 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -227,7 +227,8 @@ bootstrapping. `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (compile-or-load-defgeneric ',fun-name)) - (load-defgeneric ',fun-name ',lambda-list ,@initargs) + (load-defgeneric ',fun-name ',lambda-list + (sb-c:source-location) ,@initargs) ,@(mapcar #'expand-method-definition methods) (fdefinition ',fun-name))))) @@ -239,7 +240,7 @@ bootstrapping. (setf (info :function :type fun-name) (specifier-type 'function)))) -(defun load-defgeneric (fun-name lambda-list &rest initargs) +(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))) @@ -250,7 +251,7 @@ bootstrapping. (apply #'ensure-generic-function fun-name :lambda-list lambda-list - :definition-source `((defgeneric ,fun-name) ,*load-pathname*) + :definition-source source-location initargs)) (define-condition generic-function-lambda-list-error @@ -313,7 +314,7 @@ bootstrapping. (defun prototypes-for-make-method-lambda (name) (if (not (eq *boot-state* 'complete)) (values nil nil) - (let ((gf? (and (gboundp name) + (let ((gf? (and (fboundp name) (gdefinition name)))) (if (or (null gf?) (not (generic-function-p gf?))) @@ -335,7 +336,7 @@ bootstrapping. ;;; ;;; Note: During bootstrapping, this function is allowed to return NIL. (defun method-prototype-for-gf (name) - (let ((gf? (and (gboundp name) + (let ((gf? (and (fboundp name) (gdefinition name)))) (cond ((neq *boot-state* 'complete) nil) ((or (null gf?) @@ -464,7 +465,8 @@ bootstrapping. ;; 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)) + ',pv-table-symbol + (sb-c:source-location))) (defmacro make-method-function (method-lambda &environment env) (make-method-function-internal method-lambda env)) @@ -818,6 +820,10 @@ bootstrapping. (,',next-methods (cdr ,',next-methods))) .next-method. ,',next-methods ,@body)) + (check-cnm-args-body (&environment env method-name-declaration cnm-args) + (if (safe-code-p env) + `(%check-cnm-args ,cnm-args ,',method-args ',method-name-declaration) + nil)) (call-next-method-body (method-name-declaration cnm-args) `(if .next-method. (funcall (if (std-instance-p .next-method.) @@ -1062,7 +1068,8 @@ bootstrapping. (apply emf args)))) (defmacro bind-fast-lexical-method-macros ((args rest-arg next-method-call) - &body body) + &body body + &environment env) (let* ((all-params (append args (when rest-arg (list rest-arg)))) (rebindings (mapcar (lambda (x) (list x x)) all-params))) `(macrolet ((narrowed-emf (emf) @@ -1093,6 +1100,11 @@ bootstrapping. ,emf)) (call-next-method-bind (&body body) `(let () ,@body)) + (check-cnm-args-body (&environment env method-name-declaration cnm-args) + (if (safe-code-p env) + `(%check-cnm-args ,cnm-args (list ,@',args) + ',method-name-declaration) + nil)) (call-next-method-body (method-name-declaration cnm-args) `(if ,',next-method-call ,(locally @@ -1155,15 +1167,42 @@ bootstrapping. `(call-next-method-bind (flet (,@(and call-next-method-p `((call-next-method (&rest cnm-args) - (call-next-method-body - ,method-name-declaration - cnm-args)))) + (check-cnm-args-body ,method-name-declaration cnm-args) + (call-next-method-body ,method-name-declaration cnm-args)))) ,@(and next-method-p-p '((next-method-p () (next-method-p-body))))) (with-rebound-original-args (,call-next-method-p ,setq-p) ,@body)))))) +;;; CMUCL comment (Gerd Moellmann): +;;; +;;; The standard says it's an error if CALL-NEXT-METHOD is called with +;;; arguments, and the set of methods applicable to those arguments is +;;; different from the set of methods applicable to the original +;;; method arguments. (According to Barry Margolin, this rule was +;;; probably added to ensure that before and around methods are always +;;; run before primary methods.) +;;; +;;; This could be optimized for the case that the generic function +;;; doesn't have hairy methods, does have standard method combination, +;;; is a standard generic function, there are no methods defined on it +;;; for COMPUTE-APPLICABLE-METHODS and probably a lot more of such +;;; preconditions. That looks hairy and is probably not worth it, +;;; because this check will never be fast. +(defun %check-cnm-args (cnm-args orig-args method-name-declaration) + (when cnm-args + (let* ((gf (fdefinition (caar method-name-declaration))) + (omethods (compute-applicable-methods gf orig-args)) + (nmethods (compute-applicable-methods gf cnm-args))) + (unless (equal omethods nmethods) + (error "~@" + nmethods (length cnm-args) cnm-args omethods + (length orig-args) orig-args))))) + (defmacro bind-args ((lambda-list args) &body body) (let ((args-tail '.args-tail.) (key '.key.) @@ -1322,7 +1361,7 @@ bootstrapping. (defun generic-function-name-p (name) (and (legal-fun-name-p name) - (gboundp name) + (fboundp name) (if (eq *boot-state* 'complete) (standard-generic-function-p (gdefinition name)) (funcallable-instance-p (gdefinition name))))) @@ -1380,17 +1419,18 @@ bootstrapping. `(method-function-get ,method-function 'closure-generator)) (defun load-defmethod - (class name quals specls ll initargs &optional pv-table-symbol) + (class name quals specls ll initargs pv-table-symbol 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))) + ll initargs pv-table-symbol + source-location))) (defun load-defmethod-internal (method-class gf-spec qualifiers specializers lambda-list - initargs pv-table-symbol) + initargs pv-table-symbol source-location) (when pv-table-symbol (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)) @@ -1408,10 +1448,7 @@ bootstrapping. gf-spec qualifiers specializers)))) (let ((method (apply #'add-named-method gf-spec qualifiers specializers lambda-list - :definition-source `((defmethod ,gf-spec - ,@qualifiers - ,specializers) - ,*load-pathname*) + :definition-source source-location initargs))) (unless (or (eq method-class 'standard-method) (eq (find-class method-class nil) (class-of method))) @@ -1554,10 +1591,10 @@ bootstrapping. (defun ensure-generic-function (fun-name &rest all-keys - &key environment + &key environment source-location &allow-other-keys) (declare (ignore environment)) - (let ((existing (and (gboundp fun-name) + (let ((existing (and (fboundp fun-name) (gdefinition fun-name)))) (if (and existing (eq *boot-state* 'complete) @@ -1599,6 +1636,11 @@ bootstrapping. (defmacro early-gf-methods (gf) `(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*) + (generic-function-methods generic-function))) + (defvar *sgf-arg-info-index* (!bootstrap-slot-index 'standard-generic-function 'arg-info)) @@ -1733,6 +1775,67 @@ bootstrapping. ~S." gf-keywords))))))) +(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-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 fast-function 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) + (!bootstrap-slot-index 'standard-boundp-method s)))) + +(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)))) +(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)))) +(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)))) +(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) + (let ((plist (clos-slots-ref (get-slots method) *sm-plist-index*))) + (getf plist 'qualifiers)) + (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)) (nreq (length (arg-info-metatypes arg-info))) @@ -1746,7 +1849,7 @@ bootstrapping. (dolist (method (if new-method (list new-method) methods)) (let* ((specializers (if (or (eq *boot-state* 'complete) (not (consp method))) - (method-specializers method) + (safe-method-specializers method) (early-method-specializers method t))) (class (if (or (eq *boot-state* 'complete) (not (consp method))) (class-of method) @@ -1825,6 +1928,7 @@ bootstrapping. &key (lambda-list nil lambda-list-p) argument-precedence-order + source-location &allow-other-keys) (declare (ignore keys)) (cond ((and existing (early-gf-p existing)) @@ -1834,7 +1938,7 @@ bootstrapping. ((assoc spec *!generic-function-fixups* :test #'equal) (if existing (make-early-gf spec lambda-list lambda-list-p existing - argument-precedence-order) + argument-precedence-order source-location) (error "The function ~S is not already defined." spec))) (existing (error "~S should be on the list ~S." @@ -1843,19 +1947,19 @@ bootstrapping. (t (pushnew spec *!early-generic-functions* :test #'equal) (make-early-gf spec lambda-list lambda-list-p nil - argument-precedence-order)))) + argument-precedence-order source-location)))) (defun make-early-gf (spec &optional lambda-list lambda-list-p - function argument-precedence-order) + function argument-precedence-order source-location) (let ((fin (allocate-funcallable-instance *sgf-wrapper* *sgf-slots-init*))) (set-funcallable-instance-function fin (or function (if (eq spec 'print-object) - #'(instance-lambda (instance stream) + #'(lambda (instance stream) (print-unreadable-object (instance stream :identity t) (format stream "std-instance"))) - #'(instance-lambda (&rest args) + #'(lambda (&rest args) (declare (ignore args)) (error "The function of the funcallable-instance ~S~ has not been set." fin))))) @@ -1864,7 +1968,7 @@ bootstrapping. (!bootstrap-set-slot 'standard-generic-function fin 'source - *load-pathname*) + source-location) (set-fun-name fin spec) (let ((arg-info (make-arg-info))) (setf (early-gf-arg-info fin) arg-info) @@ -1877,6 +1981,17 @@ bootstrapping. (set-arg-info fin :lambda-list lambda-list)))) fin)) +(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*) + (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*) + new-value) + (setf (gf-dfun-state generic-function) new-value))) + (defun set-dfun (gf &optional dfun cache info) (when cache (setf (cache-owner cache) gf)) @@ -1884,14 +1999,14 @@ bootstrapping. (list* dfun cache info) dfun))) (if (eq *boot-state* 'complete) - (setf (gf-dfun-state gf) new-state) + (setf (safe-gf-dfun-state gf) new-state) (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) - (gf-dfun-state gf) + (safe-gf-dfun-state gf) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) @@ -1899,7 +2014,7 @@ bootstrapping. (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) + (safe-gf-dfun-state gf) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) @@ -1950,7 +2065,9 @@ bootstrapping. (let ((method-class (getf ,all-keys :method-class '.shes-not-there.))) (unless (eq method-class '.shes-not-there.) (setf (getf ,all-keys :method-class) - (find-class method-class t ,env)))))) + (cond ((classp method-class) + method-class) + (t (find-class method-class t ,env)))))))) (defun real-ensure-gf-using-class--generic-function (existing @@ -1984,12 +2101,30 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name 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*) + (gf-arg-info generic-function))) + +;;; FIXME: this function took on a slightly greater role than it +;;; previously had around 2005-11-02, when CSR fixed the bug whereby +;;; having more than one subclass of standard-generic-function caused +;;; the whole system to die horribly through a metacircle in +;;; GF-ARG-INFO. The fix is to be slightly more disciplined about +;;; calling accessor methods -- we call GET-GENERIC-FUN-INFO when +;;; computing discriminating functions, so we need to be careful about +;;; having a base case for the recursion, and we provide that with the +;;; STANDARD-GENERIC-FUNCTION case below. However, we are not (yet) +;;; as disciplined as CLISP's CLOS/MOP, and it would be nice to get to +;;; that stage, where all potentially dangerous cases are enumerated +;;; and stopped. -- CSR, 2005-11-02. (defun get-generic-fun-info (gf) ;; values nreq applyp metatypes nkeys arg-info (multiple-value-bind (applyp metatypes arg-info) (let* ((arg-info (if (early-gf-p gf) (early-gf-arg-info gf) - (gf-arg-info gf))) + (safe-gf-arg-info gf))) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes @@ -2305,7 +2440,7 @@ bootstrapping. (make-symbol (format nil "~S" method)))) (multiple-value-bind (gf-spec quals specls) (parse-defmethod spec) - (and (setq gf (and (or errorp (gboundp gf-spec)) + (and (setq gf (and (or errorp (fboundp gf-spec)) (gdefinition gf-spec))) (let ((nreq (compute-discriminating-function-arglist-info gf))) (setq specls (append (parse-specializers specls)