make-load-form-saving-slots: structures: refrence slot by an offset

At least one library (adt) redefines structures with slot names being
uninterned symbols. That means that we lose slot offset if we
reference it by name what leads to load errors if
make-load-form-saving-slots was called. We fix that by handling
structure-object's separately.

allocate-instance is another oddball in the spec when taken with
structure-classes (and it is used in make-load-form-saving-slots). If
there are *some* slots saved then rest must be initialized so object
could be used - we put there NIL without checking for a type. SBCL
tries to find a constructor for a structure (custom protocol) or
errors while CCL initializes slots to NIL. We follow the latter.

src/clos/builtin.lsp

@@ -78,7 +78,7 @@
 (defmethod allocate-instance ((class structure-class) &rest initargs)
   (declare (ignore initargs))
   (apply #'si::make-structure class
-         (make-list (class-size class) :initial-element (si::unbound))))
+         (make-list (class-size class) :initial-element nil)))
 
 (defmethod finalize-inheritance ((class structure-class))
   (call-next-method)

src/clos/print.lsp

@@ -23,21 +23,33 @@
 
 (defun make-load-form-saving-slots (object &key slot-names environment)
   (declare (ignore environment))
-  (do* ((class (class-of object))
-        (initialization (list 'progn))
-        (slots (class-slots class) (cdr slots)))
-      ((endp slots)
-       (values `(allocate-instance ,class) (nreverse initialization)))
-    (let* ((slot (first slots))
-           (slot-name (slot-definition-name slot)))
-      (when (or (and (null slot-names)
-                     (eq (slot-definition-allocation slot) :instance))
-                (member slot-name slot-names))
-        (push (if (slot-boundp object slot-name)
-                  `(setf (slot-value ,object ',slot-name)
-                         ',(slot-value object slot-name))
-                  `(slot-makunbound ,object ',slot-name))
-              initialization)))))
+  (let* ((class (class-of object))
+         (class-name (class-name class))
+         (initialization-form (list 'progn))
+         (slots (class-slots class))
+         (decls (when (typep object 'structure-object)
+                  (get-sysprop class-name 'si::structure-slot-descriptions))))
+    (do ((slot #1=(pop slots) #1#)
+         (desc #2=(pop decls) #2#))
+        ((null slot) (values `(allocate-instance ,class)
+                             (nreverse initialization-form)))
+      (let ((slot-name (slot-definition-name slot)))
+        (when (or (and (null slot-names)
+                       (eq (slot-definition-allocation slot) :instance))
+                  (member slot-name slot-names))
+          (flet ((primitive-set (val)
+                   (if (typep object 'structure-object)
+                       `(si::structure-set ,object ',class-name ,(nth 4 desc) ',val)
+                       `(setf (slot-value ,object ',slot-name) ',val)))
+                 (primitive-nil ()
+                   (if (typep object 'structure-object)
+                       `(si::structure-set ,object ',class-name ,(nth 4 desc) nil)
+                       `(slot-makunbound ,object ',slot-name))))
+            (push
+             (if (slot-boundp object slot-name)
+                 (primitive-set (slot-value object slot-name))
+                 (primitive-nil))
+             initialization-form)))))))
 
 (defun need-to-make-load-form-p (object env)
   "Return T if the object cannot be externalized using the lisp

src/tests/normal-tests/ansi.lsp

@@ -92,8 +92,6 @@
         (signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1 slot-2 slot-3))
         ;; too few slots
         (signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1))
-        ;; incompatible names
-        (signals error (defstruct (my-struct (:constructor make-my-struct)) slot-1x slot-2x))
         (finishes (make-my-struct))))