X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fdefbangstruct.lisp;h=3e5c3a6981748db3180717201d217cf4b1f273eb;hb=731d5dd65a7b94b5d49d1663d9b60c3a406ce38c;hp=7a8d3aef938f4f2093d50f7c25facad6628f1ed3;hpb=d202a453b45430e04671b966c01bc067c2667442;p=sbcl.git

diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp
index 7a8d3ae..3e5c3a6 100644
--- a/src/code/defbangstruct.lisp
+++ b/src/code/defbangstruct.lisp
@@ -75,9 +75,19 @@
 ;;; objects
 (defun just-dump-it-normally (object &optional (env nil env-p))
   (declare (type structure!object object))
+  (declare (ignorable env env-p object))
+  ;; KLUDGE: we require essentially three different behaviours of
+  ;; JUST-DUMP-IT-NORMALLY, two of which (host compiler's
+  ;; MAKE-LOAD-FORM, cross-compiler's MAKE-LOAD-FORM) are handled by
+  ;; the #+SB-XC-HOST clause.  The #-SB-XC-HOST clause is the
+  ;; behaviour required by the target, before the CLOS-based
+  ;; MAKE-LOAD-FORM-SAVING-SLOTS is implemented.
+  #+sb-xc-host
   (if env-p
       (sb!xc:make-load-form-saving-slots object :environment env)
-      (sb!xc:make-load-form-saving-slots object)))
+      (sb!xc:make-load-form-saving-slots object))
+  #-sb-xc-host
+  :sb-just-dump-it-normally)
 
 ;;; a MAKE-LOAD-FORM function for objects which don't use the load
 ;;; form system. This is used for LAYOUT objects because the special
@@ -104,7 +114,7 @@
   ;; DEF!STRUCT is made to work fully, this list is processed, then
   ;; made unbound, and should no longer be used.
   (defvar *delayed-def!structs* nil))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
   ;; Parse the arguments for a DEF!STRUCT call, and return
   ;;   (VALUES NAME DEFSTRUCT-ARGS MAKE-LOAD-FORM-FUN DEF!STRUCT-SUPERTYPE),
   ;; where NAME is the name of the new type, DEFSTRUCT-ARGS is the
@@ -118,6 +128,7 @@
 	(if (consp nameoid)
 	    (values (first nameoid) (rest nameoid))
 	    (values nameoid nil))
+      (declare (type list options))
       (let* ((include-clause (find :include options :key #'first))
 	     (def!struct-supertype nil) ; may change below
 	     (mlff-clause (find :make-load-form-fun options :key #'first))
@@ -144,11 +155,11 @@
 (progn
   (defun %instance-length (instance)
     (aver (typep instance 'structure!object))
-    (layout-length (class-layout (sb!xc:find-class (type-of instance)))))
+    (layout-length (classoid-layout (find-classoid (type-of instance)))))
   (defun %instance-ref (instance index)
     (aver (typep instance 'structure!object))
-    (let* ((class (sb!xc:find-class (type-of instance)))
-	   (layout (class-layout class)))
+    (let* ((class (find-classoid (type-of instance)))
+	   (layout (classoid-layout class)))
       (if (zerop index)
 	  layout
 	  (let* ((dd (layout-info layout))
@@ -158,8 +169,8 @@
 	    (funcall accessor-name instance)))))
   (defun %instance-set (instance index new-value)
     (aver (typep instance 'structure!object))
-    (let* ((class (sb!xc:find-class (type-of instance)))
-	   (layout (class-layout class)))
+    (let* ((class (find-classoid (type-of instance)))
+	   (layout (classoid-layout class)))
       (if (zerop index)
 	  (error "can't set %INSTANCE-REF FOO 0 in cross-compilation host")
 	  (let* ((dd (layout-info layout))
@@ -208,12 +219,18 @@
   (multiple-value-bind (name defstruct-args mlff def!struct-supertype)
       (apply #'parse-def!struct-args args)
     `(progn
-       ;; Make sure that we really do include STRUCTURE!OBJECT. (If an
-       ;; :INCLUDE clause was used, and the included class didn't
-       ;; itself include STRUCTURE!OBJECT, then we wouldn't; and it's
-       ;; better to find out ASAP then to let the bug lurk until
-       ;; someone tries to do MAKE-LOAD-FORM on the object.)
-       (aver (subtypep ',def!struct-supertype 'structure!object))
+       ;; There are two valid cases here: creating the
+       ;; STRUCTURE!OBJECT root of the inheritance hierarchy, or
+       ;; inheriting from STRUCTURE!OBJECT somehow.
+      ;;
+       ;; The invalid case that we want to exclude is when an :INCLUDE
+       ;; clause was used, and the included class didn't inherit frmo
+       ;; STRUCTURE!OBJECT. We want to catch that error ASAP because
+       ;; otherwise the bug might lurk until someone tried to do
+       ;; MAKE-LOAD-FORM on an instance of the class.
+       ,@(if (eq name 'structure!object)
+	     (aver (null def!struct-supertype))
+	     `((aver (subtypep ',def!struct-supertype 'structure!object))))
        (defstruct ,@defstruct-args)
        (setf (def!struct-type-make-load-form-fun ',name)
 	     ,(if (symbolp mlff)
@@ -221,20 +238,6 @@
 		  mlff)
 	     (def!struct-supertype ',name)
 	     ',def!struct-supertype)
-       ;; This bit of commented-out code hasn't been needed for quite
-       ;; some time, but the comments here about why not might still
-       ;; be useful to me until I finally get the system to work. When
-       ;; I do remove all this, I should be sure also to remove the
-       ;; "outside the EVAL-WHEN" comments above, since they will no
-       ;; longer make sense. -- WHN 19990803
-       ;;(eval-when (:compile-toplevel :load-toplevel :execute)
-       ;;  ;; (The DEFSTRUCT used to be in here, but that failed when trying
-       ;;  ;; to cross-compile the hash table implementation.)
-       ;;  ;;(defstruct ,@defstruct-args)
-       ;;  ;; The (SETF (DEF!STRUCT-TYPE-MAKE-LOAD-FORM-FUN ..) ..) used to
-       ;;  ;; be in here too, but that failed an assertion in the SETF
-       ;;  ;; definition once we moved the DEFSTRUCT outside.)
-       ;;  )
        #+sb-xc-host ,(let ((u (uncross-defstruct-args defstruct-args)))
 		       (if (boundp '*delayed-def!structs*)
 			   `(push (make-delayed-def!struct :args ',u)