1.0.28.65: fix compiling with *PROFILE-HASH-CACHE* set to T

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

diff --git a/src/pcl/low.lisp b/src/pcl/low.lisp
index 1a1be86..bb0b613 100644 (file)
--- a/src/pcl/low.lisp
+++ b/src/pcl/low.lisp
@@ -66,8 +66,9 @@
                       ;; default of WRAPPER-INVALID. Instead of trying
                       ;; to find out, I just overrode the LAYOUT
                       ;; default here. -- WHN 19991204
-                      (invalid nil))
-            (:conc-name %wrapper-)
+                      (invalid nil)
+                      ;; This allows quick testing of wrapperness.
+                      (for-std-class-p t))
             (:constructor make-wrapper-internal)
             (:copier nil))
   (instance-slots-layout nil :type list)
@@ -261,8 +262,6 @@
   (when (pcl-instance-p instance)
     (get-slots instance)))
 
-(defmacro built-in-or-structure-wrapper (x) `(layout-of ,x))
-
 (defmacro get-wrapper (inst)
   (once-only ((wrapper `(wrapper-of ,inst)))
     `(progn
@@ -306,20 +305,23 @@
 
 ;;; The definition of STRUCTURE-TYPE-P was moved to early-low.lisp.
 
-(defun get-structure-dd (type)
-  (layout-info (classoid-layout (find-classoid type))))
-
-(defun structure-type-included-type-name (type)
-  (let ((include (dd-include (get-structure-dd type))))
-    (if (consp include)
-        (car include)
-        include)))
-
 (defun structure-type-slot-description-list (type)
-  (nthcdr (length (let ((include (structure-type-included-type-name type)))
-                    (and include
-                         (dd-slots (get-structure-dd include)))))
-          (dd-slots (get-structure-dd type))))
+  (let* ((dd (find-defstruct-description type))
+         (include (dd-include dd))
+         (all-slots (dd-slots dd)))
+    (multiple-value-bind (super slot-overrides)
+        (if (consp include)
+            (values (car include) (mapcar #'car (cdr include)))
+            (values include nil))
+      (let ((included-slots
+             (when super
+               (dd-slots (find-defstruct-description super)))))
+        (loop for slot = (pop all-slots)
+              for included-slot = (pop included-slots)
+              while slot
+              when (or (not included-slot)
+                       (member (dsd-name included-slot) slot-overrides :test #'eq))
+              collect slot)))))
 
 (defun structure-slotd-name (slotd)
   (dsd-name slotd))
@@ -332,7 +334,7 @@
 
 (defun structure-slotd-writer-function (type slotd)
   (if (dsd-read-only slotd)
-      (let ((dd (get-structure-dd type)))
+      (let ((dd (find-defstruct-description type)))
         (coerce (slot-setter-lambda-form dd slotd) 'function))
       (fdefinition `(setf ,(dsd-accessor-name slotd)))))
 
@@ -369,28 +371,4 @@
   :metaclass-name static-classoid
   :metaclass-constructor make-static-classoid
   :dd-type funcallable-structure)
-\f
-;;; WITH-PCL-LOCK is used around some forms that were previously
-;;; protected by WITHOUT-INTERRUPTS, but in a threaded SBCL we don't
-;;; have a useful WITHOUT-INTERRUPTS.  In an unthreaded SBCL I'm not
-;;; sure what the desired effect is anyway: should we be protecting
-;;; against the possibility of recursive calls into these functions
-;;; or are we using WITHOUT-INTERRUPTS as WITHOUT-SCHEDULING?
-;;;
-;;; Users: FORCE-CACHE-FLUSHES, MAKE-INSTANCES-OBSOLETE.  Note that
-;;; it's not all certain this is sufficent for threadsafety: do we
-;;; just have to protect against simultaneous calls to these mutators,
-;;; or actually to stop normal slot access etc at the same time as one
-;;; of them runs
-
-#+sb-thread
-(progn
-  (defvar *pcl-lock* (sb-thread::make-spinlock))
-
-  (defmacro with-pcl-lock (&body body)
-    `(sb-thread::with-spinlock (*pcl-lock*)
-      ,@body)))
 
-#-sb-thread
-(defmacro with-pcl-lock (&body body)
-  `(progn ,@body))