0.8alpha.0.37:

	Make MAKE-LOAD-FORM(-SAVING-SLOTS) vaguely conform
	... and in the process, remind myself of just how horrible the
		:JUST-DUMP-IT-NORMALLY hack was.
	... more methods on MAKE-LOAD-FORM;
	... real, CLOS-based introspective definition of
		MAKE-LOAD-FORM-SAVING-SLOTS...
	... which means that we have to hold off from using MLFSS until
		it's around, so make JUST-DUMP-IT-NORMALLY use
		:SB-JUST-DUMP-IT-NORMALLY rather than MLFSS in its
		definition for the target.
	Fix the type.impure.lisp test for the new definition of
	condition classes (oops).

diff --git a/NEWS b/NEWS
index dadddb3..7dcd85a 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1751,6 +1751,10 @@ changes in sbcl-0.8.0 relative to sbcl-0.8alpha.0
        STRUCTURE-CLASS).
     ** SLOT-EXISTS-P now works on conditions, as well as structures
        and CLOS instances.
+    ** MAKE-LOAD-FORM now has the required methods on
+       STRUCTURE-OBJECT, CONDITION and STANDARD-OBJECT.
+    ** MAKE-LOAD-FORM-SAVING-SLOTS no longer returns a special
+       keyword, and now implements the SLOT-NAMES argument.
 
 planned incompatible changes in 0.8.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/src/code/defbangstruct.lisp b/src/code/defbangstruct.lisp
index 7b9ba18..9ba54be 100644 (file)
--- 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))
+  ;; 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

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index e9b5b60..c463637 100644 (file)
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -395,7 +395,7 @@
 
     res))
 \f
-;;; default PRINT-OBJECT and MAKE-LOAD-FORM methods
+;;; default PRINT-OBJECT method
 
 (defun %default-structure-pretty-print (structure stream)
   (let* ((layout (%instance-layout structure))
@@ -468,12 +468,6 @@
         (%default-structure-ugly-print structure stream))))
 (def!method print-object ((x structure-object) stream)
   (default-structure-print x stream *current-level-in-print*))
-
-(defun make-load-form-saving-slots (object &key slot-names environment)
-  (declare (ignore object environment))
-  (if slot-names
-      (error "stub: MAKE-LOAD-FORM-SAVING-SLOTS :SLOT-NAMES not implemented") ; KLUDGE
-      :sb-just-dump-it-normally))
 \f
 ;;;; testing structure types
 

diff --git a/src/pcl/env.lisp b/src/pcl/env.lisp
index 359ad30..d793f9a 100644 (file)
--- a/src/pcl/env.lisp
+++ b/src/pcl/env.lisp
@@ -132,3 +132,33 @@
             (layout-classoid object)))
     `(classoid-layout (find-classoid ',pname))))
 
+(defmethod make-load-form ((object structure-object) &optional env)
+  (declare (ignore env))
+  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+        object 'make-load-form))
+
+(defmethod make-load-form ((object standard-object) &optional env)
+  (declare (ignore env))
+  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+        object 'make-load-form))
+
+(defmethod make-load-form ((object condition) &optional env)
+  (declare (ignore env))
+  (error "~@<don't know how to dump ~S (default ~S method called).~@>"
+        object 'make-load-form))
+
+(defun make-load-form-saving-slots (object &key slot-names environment)
+  (declare (ignore environment))
+  (let ((class (class-of object)))
+    (collect ((inits))
+      (dolist (slot (class-slots class))
+        (let ((slot-name (slot-definition-name slot)))
+          (when (or (memq slot-name slot-names)
+                    (and (null slot-names)
+                         (eq :instance (slot-definition-allocation slot))))
+            (if (slot-boundp-using-class class object slot)
+                (let ((value (slot-value-using-class class object slot)))
+                  (inits `(setf (slot-value ,object ',slot-name) ',value)))
+                (inits `(slot-makunbound ,object ',slot-name))))))
+      (values `(allocate-instance (find-class ',(class-name class)))
+              `(progn ,@(inits))))))

diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp
index 7bd27fb..441f6ff 100644 (file)
--- a/tests/type.impure.lisp
+++ b/tests/type.impure.lisp
@@ -337,6 +337,7 @@
                     (find-class 'simple-condition))
                    (mapcar #'find-class '(simple-condition
                                           condition
+                                          sb-pcl::slot-object
                                           sb-kernel:instance
                                           t))))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 6f119f9..7313c14 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8alpha.0.36"
+"0.8alpha.0.37"