From 5214129a24e5876a1ad1af4fb6f09ecc353d1c31 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 2 Jun 2008 15:19:15 +0000
Subject: [PATCH] 1.0.17.19: fix interpreted structure constructors
 (regression since 1.0.17.4)

 * Add full definition for %MAKE-STRUCTURE-INSTANCE.

 * Test-case.
---
 src/code/target-defstruct.lisp |   23 +++++++++++++++++++++++
 tests/full-eval.impure.lisp    |   24 ++++++++++++++++++++++++
 version.lisp-expr              |    2 +-
 3 files changed, 48 insertions(+), 1 deletion(-)

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 7db7029..a719bdf 100644
--- a/src/code/target-defstruct.lisp
+++ b/src/code/target-defstruct.lisp
@@ -31,6 +31,29 @@
 (defun %instance-set (instance index new-value)
   (setf (%instance-ref instance index) new-value))
 
+;;; Normally IR2 converted, definition needed for interpreted structure
+;;; constructors only.
+#!+sb-eval
+(defun %make-structure-instance (dd slot-specs &rest slot-values)
+  (let ((instance (%make-instance (dd-instance-length dd))))
+    (setf (%instance-layout instance) (dd-layout-or-lose dd))
+    (mapc (lambda (spec value)
+            (destructuring-bind (raw-type . index) (cdr spec)
+              (macrolet ((make-case ()
+                           `(ecase raw-type
+                              ((t)
+                               (setf (%instance-ref instance index) value))
+                              ,@(mapcar
+                                 (lambda (rsd)
+                                   `(,(raw-slot-data-raw-type rsd)
+                                      (setf (,(raw-slot-data-accessor-name rsd)
+                                              instance index)
+                                            value)))
+                                 *raw-slot-data-list*))))
+                (make-case))))
+          slot-specs slot-values)
+    instance))
+
 #!-hppa
 (progn
   (defun %raw-instance-ref/word (instance index)
diff --git a/tests/full-eval.impure.lisp b/tests/full-eval.impure.lisp
index a35528c..98f345f 100644
--- a/tests/full-eval.impure.lisp
+++ b/tests/full-eval.impure.lisp
@@ -31,3 +31,27 @@
       (funcall fun)
       (assert (gethash '(when t nil) seen-forms)))))
 
+;;; defstruct constructor
+(let ((sb-ext:*evaluator-mode* :interpret))
+  (eval '(progn
+          (defstruct evaluated-struct
+            (pointer nil)
+            (word 0 :type (unsigned-byte #.sb-vm:n-word-bytes))
+            (single 0.0 :type single-float)
+            (double 0.0d0 :type double-float)
+            (csingle (complex 0.0 0.0) :type (complex single-float))
+            (cdouble (complex 0.0d0 0.0d0) :type (complex double-float)))
+          (defvar *evaluated-struct* (make-evaluated-struct
+                                      :pointer :foo
+                                      :word 42
+                                      :single 1.23
+                                      :double 2.34d0
+                                      :csingle (complex 1.0 2.0)
+                                      :cdouble (complex 2.0d0 3.0d0)))
+          (assert (eq :foo (evaluated-struct-pointer *evaluated-struct*)))
+          (assert (eql 42 (evaluated-struct-word *evaluated-struct*)))
+          (assert (eql 1.23 (evaluated-struct-single *evaluated-struct*)))
+          (assert (eql 2.34d0 (evaluated-struct-double *evaluated-struct*)))
+          (assert (eql #c(1.0 2.0) (evaluated-struct-csingle *evaluated-struct*)))
+          (assert (eql #c(2.0d0 3.0d0) (evaluated-struct-cdouble *evaluated-struct*))))))
+
diff --git a/version.lisp-expr b/version.lisp-expr
index b6f8141..ad35188 100644
--- 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".)
-"1.0.17.18"
+"1.0.17.19"
-- 
1.7.10.4