X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=1db2f02d2cf2fe624bfe517a4ad4c2220345a526;hb=1acfa21e0796f5d72d776b0fd53645813d5f2d98;hp=15601a106d7a65677484fbd567647fd29c4c7426;hpb=2d10bc4b0d8557a5c553d13a3d520c40b48414db;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 15601a1..1db2f02 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -492,7 +492,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (some (lambda (method) (let ((fmf (if (listp method) (third method) - (method-fast-function method)))) + (safe-method-fast-function method)))) (method-function-get fmf :slot-name-lists))) ;; KLUDGE: As of sbcl-0.6.4, it's very important for ;; efficiency to know the type of the sequence argument to @@ -581,14 +581,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (method methods t) (when (eq *boot-state* 'complete) (when (or (some #'eql-specializer-p - (method-specializers method)) - (method-qualifiers method)) + (safe-method-specializers method)) + (safe-method-qualifiers method)) (return nil))) (let ((value (method-function-get (if early-p (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) + (or (safe-method-fast-function method) + (safe-method-function method))) :constant-value default))) (when (or (eq value default) (and boolean-values-p @@ -987,7 +987,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; which are the parameters of the new state, and get other ;; information from the lexical variables bound above. (flet ((two-class (index w0 w1) - (when (zerop (random 2)) (psetf w0 w1 w1 w0)) + (when (zerop (random 2 *pcl-misc-random-state*)) + (psetf w0 w1 w1 w0)) (dfun-update gf #'make-two-class-accessor-dfun ntype @@ -1224,7 +1225,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; function GF which reads/writes instances of class CLASS. ;;; TYPE is one of the symbols READER or WRITER. (defun find-standard-class-accessor-method (gf class type) - (let ((cpl (standard-slot-value/class class 'class-precedence-list)) + (let ((cpl (standard-slot-value/class class '%class-precedence-list)) (found-specializer *the-class-t*) (found-method nil)) (dolist (method (standard-slot-value/gf gf 'methods) found-method) @@ -1326,21 +1327,26 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 method)) (accessor-method-slot-name method)))) (when (or (null specl-cpl) + (null so-p) (member *the-class-structure-object* specl-cpl)) (return-from make-accessor-table nil)) - (maphash (lambda (class slotd) - (let ((cpl (if early-p - (early-class-precedence-list class) - (class-precedence-list class)))) - (when (memq specl cpl) - (unless (and (or so-p - (member *the-class-standard-object* - cpl)) - (or early-p - (slot-accessor-std-p slotd type))) + ;; 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)))) + (when slotd + (unless (or early-p + (slot-accessor-std-p slotd type)) (return-from make-accessor-table nil)) - (push (cons specl slotd) (gethash class table))))) - (gethash slot-name *name->class->slotd-table*)))) + (push (cons specl slotd) (gethash class table)))) + (dolist (subclass (sb-pcl::class-direct-subclasses class)) + (aux subclass)))) + (aux specl)))) (maphash (lambda (class specl+slotd-list) (dolist (sclass (if early-p (early-class-precedence-list class) @@ -1369,14 +1375,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((definite-p t) (possibly-applicable-methods nil)) (dolist (method (if (early-gf-p generic-function) (early-gf-methods generic-function) - (if (eq (class-of generic-function) - *the-class-standard-generic-function*) - ;; KLUDGE: see comment by GET-GENERIC-FUN-INFO - (clos-slots-ref (fsc-instance-slots generic-function) *sgf-methods-index*) - (generic-function-methods generic-function)))) + (safe-generic-function-methods generic-function))) (let ((specls (if (consp method) (early-method-specializers method t) - (method-specializers method))) + (safe-method-specializers method))) (types types) (possibly-applicable-p t) (applicable-p t)) (dolist (specl specls) @@ -1430,10 +1432,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun order-specializers (specl1 specl2 index compare-classes-function) (let ((type1 (if (eq *boot-state* 'complete) (specializer-type specl1) - (!bootstrap-get-slot 'specializer specl1 'type))) + (!bootstrap-get-slot 'specializer specl1 '%type))) (type2 (if (eq *boot-state* 'complete) (specializer-type specl2) - (!bootstrap-get-slot 'specializer specl2 'type)))) + (!bootstrap-get-slot 'specializer specl2 '%type)))) (cond ((eq specl1 specl2) nil) ((atom type1) @@ -1645,18 +1647,22 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 'specializer-applicable-using-type-p type))))) -(defun map-all-classes (function &optional (root t)) - (let ((braid-p (or (eq *boot-state* 'braid) +(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)))) (labels ((do-class (class) - (mapc #'do-class - (if braid-p - (class-direct-subclasses class) - (early-class-direct-subclasses class))) - (funcall function class))) + (unless (gethash class all-classes) + (setf (gethash class all-classes) t) + (funcall fun class) + (mapc #'do-class + (if braid-p + (class-direct-subclasses class) + (early-class-direct-subclasses class)))))) (do-class (if (symbolp root) (find-class root) - root))))) + root))) + nil)) (defvar *effective-method-cache* (make-hash-table :test 'eq))