From aa985f566fdedd45e2c74774d6e81f2442dd3802 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= <daniel@turtleware.eu>
Date: Thu, 23 May 2019 08:36:19 +0200
Subject: [PATCH] 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            |  2 +-
 src/clos/print.lsp              | 42 +++++++++++++++++++++------------
 src/tests/normal-tests/ansi.lsp |  2 --
 3 files changed, 28 insertions(+), 18 deletions(-)

diff --git a/src/clos/builtin.lsp b/src/clos/builtin.lsp
index 7aa21bc91..def6d741d 100644
--- a/src/clos/builtin.lsp
+++ b/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)
diff --git a/src/clos/print.lsp b/src/clos/print.lsp
index cd944cd63..d4f16fcd8 100644
--- a/src/clos/print.lsp
+++ b/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
diff --git a/src/tests/normal-tests/ansi.lsp b/src/tests/normal-tests/ansi.lsp
index 962fa18a7..2df7ed8c9 100644
--- a/src/tests/normal-tests/ansi.lsp
+++ b/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))))