1.0.4.41: unbreak threaded build

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

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index 12571a1..84d8418 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -333,7 +333,8 @@
               `((setf (structure-classoid-constructor (find-classoid ',name))
                       #',def-con))))))))
 
-;;; shared logic for CL:DEFSTRUCT and SB!XC:DEFSTRUCT
+;;; shared logic for host macroexpansion for SB!XC:DEFSTRUCT and
+;;; cross-compiler macroexpansion for CL:DEFSTRUCT
 (defmacro !expander-for-defstruct (name-and-options
                                    slot-descriptions
                                    expanding-into-code-for-xc-host-p)
@@ -1158,7 +1159,7 @@
                                    (lambda (x)
                                      (sb!xc:typep x 'structure-classoid))
                                    (lambda (x)
-                                     (sb!xc:typep x (find-classoid class))))
+                                     (sb!xc:typep x (classoid-name (find-classoid class)))))
                                (fdefinition constructor)))
     (setf (classoid-direct-superclasses class)
           (case (dd-name info)
@@ -1551,6 +1552,47 @@
           (dd-type dd) dd-type)
     dd))
 
+;;; make !DEFSTRUCT-WITH-ALTERNATE-METACLASS compilable by the host
+;;; lisp, installing the information we need to reason about the
+;;; structures (layouts and classoids).
+;;;
+;;; FIXME: we should share the parsing and the DD construction between
+;;; this and the cross-compiler version, but my brain was too small to
+;;; get that right.  -- CSR, 2006-09-14
+#+sb-xc-host
+(defmacro !defstruct-with-alternate-metaclass
+    (class-name &key
+                (slot-names (missing-arg))
+                (boa-constructor (missing-arg))
+                (superclass-name (missing-arg))
+                (metaclass-name (missing-arg))
+                (metaclass-constructor (missing-arg))
+                (dd-type (missing-arg))
+                predicate
+                (runtime-type-checks-p t))
+
+  (declare (type (and list (not null)) slot-names))
+  (declare (type (and symbol (not null))
+                 boa-constructor
+                 superclass-name
+                 metaclass-name
+                 metaclass-constructor))
+  (declare (type symbol predicate))
+  (declare (type (member structure funcallable-structure) dd-type))
+  (declare (ignore boa-constructor predicate runtime-type-checks-p))
+
+  (let* ((dd (make-dd-with-alternate-metaclass
+              :class-name class-name
+              :slot-names slot-names
+              :superclass-name superclass-name
+              :metaclass-name metaclass-name
+              :metaclass-constructor metaclass-constructor
+              :dd-type dd-type)))
+    `(progn
+
+      (eval-when (:compile-toplevel :load-toplevel :execute)
+        (%compiler-set-up-layout ',dd ',(inherits-for-structure dd))))))
+
 (sb!xc:defmacro !defstruct-with-alternate-metaclass
     (class-name &key
                 (slot-names (missing-arg))
@@ -1683,4 +1725,12 @@
          (inherits (inherits-for-structure dd)))
     (%compiler-defstruct dd inherits)))
 
+;;; finding these beasts
+(defun find-defstruct-description (name &optional (errorp t))
+  (let ((info (layout-info (classoid-layout (find-classoid name errorp)))))
+    (if (defstruct-description-p info)
+        info
+        (when errorp
+          (error "No DEFSTRUCT-DESCRIPTION for ~S." name)))))
+
 (/show0 "code/defstruct.lisp end of file")