X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fboot.lisp;h=cb62ef5e1c65d904fef21bd6fe69190007b25d14;hb=72db452798256d266d5909bd330d9eb5b31c6f1e;hp=6ec7f1a3a0fce099c6a92d7452727fdeba899ec6;hpb=15db88b169f732c8d339047bfad92e0725d7cacc;p=sbcl.git diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 6ec7f1a..cb62ef5 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 @@ -405,7 +406,7 @@ bootstrapping. (if (consp s) (and (eq (car s) 'eql) (constantp (cadr s)) - (let ((sv (eval (cadr s)))) + (let ((sv (constant-form-value (cadr s)))) (or (interned-symbol-p sv) (integerp sv) (and (characterp sv) @@ -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)) @@ -711,7 +713,7 @@ bootstrapping. (constant-value-p (and (null (cdr real-body)) (constantp (car real-body)))) (constant-value (and constant-value-p - (eval (car real-body)))) + (constant-form-value (car real-body)))) (plist (and constant-value-p (or (typep constant-value '(or number character)) @@ -951,7 +953,7 @@ bootstrapping. ;; broken if RESTP evaluates to a non-self-evaluating form. E.g. if ;; (INVOKE-EFFECTIVE-METHOD-FUNCTION EMF '(ERROR "gotcha") ...) ;; then TRACE-EMF-CALL-CALL-INTERNAL might die on a gotcha error. - (setq restp (eval restp)) + (setq restp (constant-form-value restp)) `(progn (trace-emf-call ,emf ,restp (list ,@required-args+rest-arg)) (cond ((typep ,emf 'fast-method-call) @@ -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,7 +1591,7 @@ 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 (fboundp fun-name) @@ -1636,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)) @@ -1770,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))) @@ -1783,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) @@ -1862,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)) @@ -1871,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." @@ -1880,10 +1947,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 +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) @@ -1914,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)) @@ -1921,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) @@ -1936,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) @@ -2023,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