X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=e90c550745deaa8c00ac5f428e44afc3d9ec8c98;hb=57eae6573811f44abe167a9015116d95371543bb;hp=e301b7621ef255d4c57403c265c610688e050030;hpb=32eb2c37fb2d9b12c5b5f674fe33b77f611120cb;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index e301b76..e90c550 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 @@ -906,7 +904,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (cond ((null methods) (values #'(lambda (&rest args) - (apply #'no-applicable-method gf args)) + (call-no-applicable-method gf args)) nil (no-methods-dfun-info))) ((setq type (final-accessor-dfun-type gf)) @@ -1195,8 +1193,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((subcpl (member (ecase type (reader (car specializers)) (writer (cadr specializers))) - cpl))) - (and subcpl (member found-specializer subcpl)))) + cpl :test #'eq))) + (and subcpl (member found-specializer subcpl :test #'eq)))) (setf found-specializer (ecase type (reader (car specializers)) (writer (cadr specializers)))) @@ -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) @@ -1235,14 +1233,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (early-class-precedence-list accessor-class) (class-precedence-list - accessor-class))) - (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-class)) + :test #'eq) + (accessor-method-p meth) + (accessor-method-slot-name meth))))) (slotd (and accessor-class (if early-p (dolist (slot (early-class-slotds accessor-class) nil) @@ -1267,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)} @@ -1280,9 +1274,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (writer (cadr specializers)))) (specl-cpl (if early-p (early-class-precedence-list specl) - (and (class-finalized-p specl) - (class-precedence-list specl)))) - (so-p (member *the-class-standard-object* specl-cpl)) + (when (class-finalized-p specl) + (class-precedence-list specl)))) + (so-p (member *the-class-standard-object* specl-cpl :test #'eq)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) (early-method-standard-accessor-slot-name @@ -1290,23 +1284,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (accessor-method-slot-name method)))) (when (or (null specl-cpl) (null so-p) - (member *the-class-structure-object* specl-cpl)) + (member *the-class-structure-object* specl-cpl :test #'eq)) (return-from make-accessor-table nil)) ;; Collect all the slot-definitions for SLOT-NAME from SPECL and ;; all of its subclasses. If either SPECL or one of the subclasses ;; is not a standard-class, bail out. (labels ((aux (class) - ;; FIND-SLOT-DEFINITION might not be defined yet - (let ((slotd (find-if (lambda (x) - (eq (sb-pcl::slot-definition-name x) - slot-name)) - (sb-pcl::class-slots class)))) + (let ((slotd (find-slot-definition class slot-name))) (when slotd - (unless (or early-p - (slot-accessor-std-p slotd type)) + (unless (or early-p (slot-accessor-std-p slotd type)) (return-from make-accessor-table nil)) (push (cons specl slotd) (gethash class table)))) (dolist (subclass (sb-pcl::class-direct-subclasses class)) + (unless (class-finalized-p subclass) + (return-from make-accessor-table nil)) (aux subclass)))) (aux specl)))) (maphash (lambda (class specl+slotd-list) @@ -1368,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)) @@ -1392,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) @@ -1474,7 +1465,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; CMUCL comment: used only in map-all-orders (defun class-might-precede-p (class1 class2) (if (not *in-precompute-effective-methods-p*) - (not (member class1 (cdr (class-precedence-list class2)))) + (not (member class1 (cdr (class-precedence-list class2)) :test #'eq)) (class-can-precede-p class1 class2))) (defun compute-precedence (lambda-list nreq argument-precedence-order) @@ -1485,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 @@ -1628,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) @@ -1674,15 +1665,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (all-sorted-p t) function-p) (if (null methods) - (if function-p - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - #'(lambda (&rest args) - (apply #'no-applicable-method gf args))) - (lambda (method-alist wrappers) - (declare (ignore method-alist wrappers)) - (lambda (&rest args) - (apply #'no-applicable-method gf args)))) + (lambda (method-alist wrappers) + (declare (ignore method-alist wrappers)) + (lambda (&rest args) + (call-no-applicable-method gf args))) (let* ((key (car methods)) (ht *effective-method-cache*) (ht-value (with-locked-hash-table (ht) @@ -1709,7 +1695,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 @@ -1732,7 +1718,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))) @@ -1792,6 +1778,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*)))