X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=1d25ea590d88f922403eef0d22333b19c9bb1823;hb=a4cffc065c83d046fce193919bf6d4e53f181455;hp=aee604a3d7d28e501de0a195e4a5d5ae4c6882e5;hpb=b3e3fbe7d381147fccc8a3027cb6fae923e57d13;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index aee604a..1d25ea5 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)) @@ -1359,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))))) @@ -1417,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)) @@ -1445,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))) @@ -1591,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) @@ -1862,6 +1862,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)) @@ -1871,7 +1872,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." @@ -1880,10 +1881,10 @@ 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 @@ -1901,7 +1902,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) @@ -2023,12 +2024,26 @@ bootstrapping. (when lambda-list-p (proclaim (defgeneric-declaration fun-name lambda-list))))) +;;; 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))) + (if (eq (class-of gf) *the-class-standard-generic-function*) + (clos-slots-ref (fsc-instance-slots gf) *sgf-arg-info-index*) + (gf-arg-info gf)))) (metatypes (arg-info-metatypes arg-info))) (values (arg-info-applyp arg-info) metatypes @@ -2344,7 +2359,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)