0.9.18.38:

[sbcl.git] / src / pcl / cache.lisp

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index 4b0fbc4..bdb7811 100644 (file)
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -258,6 +258,7 @@
         (cond (owrap
                (layout-classoid owrap))
               ((or (*subtypep (class-of class) *the-class-standard-class*)
+                   (*subtypep (class-of class) *the-class-funcallable-standard-class*)
                    (typep class 'forward-referenced-class))
                (cond ((and *pcl-class-boot*
                            (eq (slot-value class 'name) *pcl-class-boot*))
@@ -268,9 +269,11 @@
                         (aver (eq (classoid-pcl-class found) class))
                         found))
                      (t
-                      (make-standard-classoid :pcl-class class))))
+                      (let ((name (slot-value class 'name)))
+                        (make-standard-classoid :pcl-class class
+                                                :name (and (symbolp name) name))))))
               (t
-               (make-random-pcl-classoid :pcl-class class))))))
+               (bug "Got to T branch in ~S" 'make-wrapper))))))
     (t
      (let* ((found (find-classoid (slot-value class 'name)))
             (layout (classoid-layout found)))
@@ -554,21 +557,26 @@
         (logand mask result)
         (the fixnum (1+ (logand mask result))))))
 \f
-;;;  NIL              means nothing so far, no actual arg info has NILs
-;;;                in the metatype
-;;;  CLASS          seen all sorts of metaclasses
-;;;                (specifically, more than one of the next 4 values)
-;;;  T          means everything so far is the class T
-;;;  STANDARD-CLASS   seen only standard classes
-;;;  BUILT-IN-CLASS   seen only built in classes
-;;;  STRUCTURE-CLASS  seen only structure classes
+;;;  NIL: means nothing so far, no actual arg info has NILs in the
+;;;  metatype
+;;;
+;;;  CLASS: seen all sorts of metaclasses (specifically, more than one
+;;;  of the next 5 values) or else have seen something which doesn't
+;;;  fall into a single category (SLOT-INSTANCE, FORWARD).
+;;;
+;;;  T: means everything so far is the class T
+;;;  STANDARD-INSTANCE: seen only standard classes
+;;;  BUILT-IN-INSTANCE: seen only built in classes
+;;;  STRUCTURE-INSTANCE: seen only structure classes
+;;;  CONDITION-INSTANCE: seen only condition classes
 (defun raise-metatype (metatype new-specializer)
   (let ((slot      (find-class 'slot-class))
         (standard  (find-class 'standard-class))
         (fsc       (find-class 'funcallable-standard-class))
         (condition (find-class 'condition-class))
         (structure (find-class 'structure-class))
-        (built-in  (find-class 'built-in-class)))
+        (built-in  (find-class 'built-in-class))
+        (frc       (find-class 'forward-referenced-class)))
     (flet ((specializer->metatype (x)
              (let ((meta-specializer
                      (if (eq *boot-state* 'complete)
@@ -582,18 +590,19 @@
                  ((*subtypep meta-specializer structure) 'structure-instance)
                  ((*subtypep meta-specializer built-in) 'built-in-instance)
                  ((*subtypep meta-specializer slot) 'slot-instance)
+                 ((*subtypep meta-specializer frc) 'forward)
                  (t (error "~@<PCL cannot handle the specializer ~S ~
                             (meta-specializer ~S).~@:>"
-                           new-specializer
-                           meta-specializer))))))
+                           new-specializer meta-specializer))))))
       ;; We implement the following table. The notation is
       ;; that X and Y are distinct meta specializer names.
       ;;
-      ;;   NIL    <anything>    ===>  <anything>
-      ;;    X      X        ===>      X
-      ;;    X      Y        ===>    CLASS
+      ;;    NIL    <anything>    ===>  <anything>
+      ;;    X      X             ===>  X
+      ;;    X      Y             ===>  CLASS
       (let ((new-metatype (specializer->metatype new-specializer)))
         (cond ((eq new-metatype 'slot-instance) 'class)
+              ((eq new-metatype 'forward) 'class)
               ((null metatype) new-metatype)
               ((eq metatype new-metatype) new-metatype)
               (t 'class))))))
@@ -1160,6 +1169,8 @@
           (do-one-fill wrappers value))
         (maybe-check-cache ncache)))))
 \f
+(defvar *pcl-misc-random-state* (make-random-state))
+
 ;;; This is the heart of the cache filling mechanism. It implements
 ;;; the decisions about where entries are placed.
 ;;;
@@ -1196,7 +1207,8 @@
              (when (>= osep limit)
                (return-from find-free-cache-line (values primary nil)))
              (when (cond ((= nsep limit) t)
-                         ((= nsep osep) (zerop (random 2)))
+                         ((= nsep osep)
+                          (zerop (random 2 *pcl-misc-random-state*)))
                          ((> nsep osep) t)
                          (t nil))
                ;; See whether we can displace what is in this line so that we
@@ -1235,4 +1247,3 @@
     ((8 16)  4)
     (otherwise 6)))
 
-(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms