X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=97bb828be136ef1b6ce38f0b0f46234ed2393074;hb=c553e4be6da2d18f0827f190589c88e837b8b8a6;hp=3d5f353171072daedc5866449baa818636cb8524;hpb=4ff2057326cb82db04380aae96493bd5fcb3c203;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3d5f353..97bb828 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -187,18 +187,16 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defvar *standard-slot-locations* (make-hash-table :test 'equal)) (defun compute-standard-slot-locations () - (clrhash *standard-slot-locations*) - (dolist (class-name *standard-classes*) - (let ((class (find-class class-name))) - (dolist (slot (class-slots class)) - (setf (gethash (cons class (slot-definition-name slot)) - *standard-slot-locations*) - (slot-definition-location slot)))))) - -;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS -;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS. -(defun maybe-update-standard-class-locations (class) - (when (and (eq *boot-state* 'complete) + (let ((new (make-hash-table :test 'equal))) + (dolist (class-name *standard-classes*) + (let ((class (find-class class-name))) + (dolist (slot (class-slots class)) + (setf (gethash (cons class (slot-definition-name slot)) new) + (slot-definition-location slot))))) + (setf *standard-slot-locations* new))) + +(defun maybe-update-standard-slot-locations (class) + (when (and (eq **boot-state** 'complete) (memq (class-name class) *standard-classes*)) (compute-standard-slot-locations))) @@ -531,7 +529,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (generic-function-methods gf))) (default '(unknown))) (and (null applyp) - (or (not (eq *boot-state* 'complete)) + (or (not (eq **boot-state** 'complete)) ;; If COMPUTE-APPLICABLE-METHODS is specialized, we ;; can't use this, of course, because we can't tell ;; which methods will be considered applicable. @@ -552,7 +550,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; method has qualifiers, to make sure that emfs are really ;; method functions; see above. (dolist (method methods t) - (when (eq *boot-state* 'complete) + (when (eq **boot-state** 'complete) (when (or (some #'eql-specializer-p (safe-method-specializers method)) (safe-method-qualifiers method)) @@ -591,7 +589,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return t))))) (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) - (when (eq *boot-state* 'complete) + (when (eq **boot-state** 'complete) (unless (or caching-p (gf-requires-emf-keyword-checks gf) ;; DISPATCH-DFUN-COST will error if it encounters a @@ -764,10 +762,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) (cond - ((and (eq *boot-state* 'complete) + ((and (eq **boot-state** 'complete) (not (finalize-specializers gf))) (values initial-dfun nil (initial-dfun-info))) - ((and (eq *boot-state* 'complete) + ((and (eq **boot-state** 'complete) (compute-applicable-methods-emf-std-p gf)) (let* ((caching-p (use-caching-dfun-p gf)) ;; KLUDGE: the only effect of this (when @@ -1225,7 +1223,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (safe-method-qualifiers meth)) (return-from accessor-values-internal (values nil nil)))) (let* ((meth (car methods)) - (early-p (not (eq *boot-state* 'complete))) + (early-p (not (eq **boot-state** 'complete))) (slot-name (when accessor-class (if (consp meth) (and (early-method-standard-accessor-p meth) @@ -1237,13 +1235,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (class-precedence-list accessor-class)) :test #'eq) - (if early-p - (not (eq *the-class-standard-method* - (early-method-class meth))) - (accessor-method-p meth)) - (if early-p - (early-accessor-method-slot-name meth) - (accessor-method-slot-name meth)))))) + (accessor-method-p meth) + (accessor-method-slot-name meth))))) (slotd (and accessor-class (if early-p (dolist (slot (early-class-slotds accessor-class) nil) @@ -1268,7 +1261,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (generic-function-methods gf))) (all-index nil) (no-class-slots-p t) - (early-p (not (eq *boot-state* 'complete))) + (early-p (not (eq **boot-state** 'complete))) first second (size 0)) (declare (fixnum size)) ;; class -> {(specl slotd)} @@ -1366,7 +1359,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 precedence (lambda (class1 class2 index) (let* ((class (type-class (nth index types))) - (cpl (if (eq *boot-state* 'complete) + (cpl (if (eq **boot-state** 'complete) (class-precedence-list class) (early-class-precedence-list class)))) (if (memq class2 (memq class1 cpl)) @@ -1390,10 +1383,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (stable-sort methods #'sorter))) (defun order-specializers (specl1 specl2 index compare-classes-function) - (let ((type1 (if (eq *boot-state* 'complete) + (let ((type1 (if (eq **boot-state** 'complete) (specializer-type specl1) (!bootstrap-get-slot 'specializer specl1 '%type))) - (type2 (if (eq *boot-state* 'complete) + (type2 (if (eq **boot-state** 'complete) (specializer-type specl2) (!bootstrap-get-slot 'specializer specl2 '%type)))) (cond ((eq specl1 specl2) @@ -1483,7 +1476,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 argument-precedence-order))) (defun cpl-or-nil (class) - (if (eq *boot-state* 'complete) + (if (eq **boot-state** 'complete) (progn ;; KLUDGE: why not use (slot-boundp class ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is @@ -1626,8 +1619,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun map-all-classes (fun &optional (root t)) (let ((all-classes (make-hash-table :test 'eq)) - (braid-p (or (eq *boot-state* 'braid) - (eq *boot-state* 'complete)))) + (braid-p (or (eq **boot-state** 'braid) + (eq **boot-state** 'complete)))) (labels ((do-class (class) (unless (gethash class all-classes) (setf (gethash class all-classes) t) @@ -1707,7 +1700,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 wrappers-p all-applicable-p all-sorted-p function-p) (if (and all-applicable-p all-sorted-p (not function-p)) - (if (eq *boot-state* 'complete) + (if (eq **boot-state** 'complete) (let* ((combin (generic-function-method-combination gf)) (effective (compute-effective-method gf combin methods))) (make-effective-method-function1 gf effective method-alist-p @@ -1730,7 +1723,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p)) (defun methods-contain-eql-specializer-p (methods) - (and (eq *boot-state* 'complete) + (and (eq **boot-state** 'complete) (dolist (method methods nil) (when (dolist (spec (method-specializers method) nil) (when (eql-specializer-p spec) (return t))) @@ -1790,6 +1783,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; I'm aware of, but they look like they might be useful for ;;; debugging or performance tweaking or something, so I've just ;;; commented them out instead of deleting them. -- WHN 2001-03-28 +#|| (defun list-dfun (gf) (let* ((sym (type-of (gf-dfun-info gf))) (a (assq sym *dfun-list*)))