1.0.12.8: refactor bounding index error signalling functions

[sbcl.git] / src / code / class.lisp

diff --git a/src/code/class.lisp b/src/code/class.lisp
index 78a5432..082484c 100644 (file)
--- a/src/code/class.lisp
+++ b/src/code/class.lisp
@@ -101,7 +101,9 @@
 ;;; cold-load time.
 (defvar *forward-referenced-layouts*)
 (!cold-init-forms
-  (setq *forward-referenced-layouts* (make-hash-table :test 'equal))
+  (setq *forward-referenced-layouts* (make-hash-table :test 'equal
+                                                      #-sb-xc-host #-sb-xc-host
+                                                      :synchronized t))
   #-sb-xc-host (progn
                  (/show0 "processing *!INITIAL-LAYOUTS*")
                  (dolist (x *!initial-layouts*)
@@ -114,6 +116,13 @@
 ;;; type checking and garbage collection. Whenever a class is
 ;;; incompatibly redefined, a new layout is allocated. If two object's
 ;;; layouts are EQ, then they are exactly the same type.
+;;;
+;;; *** IMPORTANT ***
+;;;
+;;; If you change the slots of LAYOUT, you need to alter genesis as
+;;; well, since the initialization of layout slots is hardcoded there.
+;;;
+;;; FIXME: ...it would be better to automate this, of course...
 (def!struct (layout
              ;; KLUDGE: A special hack keeps this from being
              ;; called when building code for the
@@ -185,7 +194,19 @@
   ;; This slot is known to the C runtime support code.
   (n-untagged-slots 0 :type index)
   ;; Definition location
-  (source-location nil))
+  (source-location nil)
+  ;; Information about slots in the class to PCL: this provides fast
+  ;; access to slot-definitions and locations by name, etc.
+  (slot-table #(nil) :type simple-vector)
+  ;; True IFF the layout belongs to a standand-instance or a
+  ;; standard-funcallable-instance -- that is, true only if the layout
+  ;; is really a wrapper.
+  ;;
+  ;; FIXME: If we unify wrappers and layouts this can go away, since
+  ;; it is only used in SB-PCL::EMIT-FETCH-WRAPPERS, which can then
+  ;; use INSTANCE-SLOTS-LAYOUT instead (if there is are no slot
+  ;; layouts, there are no slots for it to pull.)
+  (for-std-class-p nil :type boolean :read-only t))
 
 (def!method print-object ((layout layout) stream)
   (print-unreadable-object (layout stream :type t :identity t)
@@ -453,7 +474,7 @@
     (when classoid-layout
       (modify-classoid classoid)
       (when subclasses
-        (dohash (subclass subclass-layout subclasses)
+        (dohash ((subclass subclass-layout) subclasses :locked t)
           (modify-classoid subclass)
           (when invalidate
             (invalidate-layout subclass-layout))))
@@ -476,7 +497,9 @@
       (let* ((super (layout-classoid super-layout))
              (subclasses (or (classoid-subclasses super)
                              (setf (classoid-subclasses super)
-                                   (make-hash-table :test 'eq)))))
+                                   (make-hash-table :test 'eq
+                                                    #-sb-xc-host #-sb-xc-host
+                                                    :synchronized t)))))
         (when (and (eq (classoid-state super) :sealed)
                    (not (gethash classoid subclasses)))
           (warn "unsealing sealed class ~S in order to subclass it"
@@ -576,7 +599,7 @@
                   (when (zerop count)
                     (push successor free-objs))))))
        (cond ((endp free-objs)
-              (dohash (obj info obj-info)
+              (dohash ((obj info) obj-info)
                 (unless (zerop (first info))
                   (error "Topological sort failed due to constraint on ~S."
                          obj)))
@@ -813,7 +836,7 @@ NIL is returned when no such class exists."
 (defun update-object-layout-or-invalid (object layout)
   (if (typep (classoid-of object) 'standard-classoid)
       (sb!pcl::check-wrapper-validity object)
-      (%layout-invalid-error object layout)))
+      (sb!c::%layout-invalid-error object layout)))
 
 ;;; Simple methods for TYPE= and SUBTYPEP should never be called when
 ;;; the two classes are equal, since there are EQ checks in those
@@ -839,7 +862,7 @@ NIL is returned when no such class exists."
         (o-sub (classoid-subclasses other)))
     (if (and s-sub o-sub)
         (collect ((res *empty-type* type-union))
-          (dohash (subclass layout s-sub)
+          (dohash ((subclass layout) s-sub :locked t)
             (declare (ignore layout))
             (when (gethash subclass o-sub)
               (res (specifier-type subclass))))
@@ -1455,7 +1478,7 @@ NIL is returned when no such class exists."
 ;;; late in the build-order.lisp-expr sequence, and be put in
 ;;; !COLD-INIT-FORMS there?
 (defun !class-finalize ()
-  (dohash (name layout *forward-referenced-layouts*)
+  (dohash ((name layout) *forward-referenced-layouts*)
     (let ((class (find-classoid name nil)))
       (cond ((not class)
              (setf (layout-classoid layout) (make-undefined-classoid name)))