1.0.18.16: many STYLE-WARNING changes.

[sbcl.git] / src / code / target-defstruct.lisp

diff --git a/src/code/target-defstruct.lisp b/src/code/target-defstruct.lisp
index 176c4f5..a719bdf 100644 (file)
--- 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)
@@ -151,19 +174,6 @@
 
 (defun (setf funcallable-instance-fun) (new-value fin)
   (setf (%funcallable-instance-function fin) new-value))
-
-;;; service function for structure constructors
-(defun %make-instance-with-layout (layout)
-  ;; Make sure the object ends at a two-word boundary.  Note that this does
-  ;; not affect the amount of memory used, since the allocator would add the
-  ;; same padding anyway.  However, raw slots are indexed from the length of
-  ;; the object as indicated in the header, so the pad word needs to be
-  ;; included in that length to guarantee proper alignment of raw double float
-  ;; slots, necessary for (at least) the SPARC backend.
-  (let* ((length (layout-length layout))
-         (result (%make-instance (+ length (mod (1+ length) 2)))))
-    (setf (%instance-layout result) layout)
-    result))
 \f
 ;;;; target-only parts of the DEFSTRUCT top level code
 
@@ -417,6 +427,31 @@
             (%raw-instance-ref/word structure i)))
 
     res))
+
+\f
+
+;; Do an EQUALP comparison on the raw slots (only, not the normal slots) of a
+;; structure.
+(defun raw-instance-slots-equalp (layout x y)
+  ;; This implementation sucks, but hopefully EQUALP on raw structures
+  ;; won't be a major bottleneck for anyone. It'd be tempting to do
+  ;; all this with %RAW-INSTANCE-REF/WORD and bitwise comparisons, but
+  ;; that'll fail in some cases. For example -0.0 and 0.0 are EQUALP
+  ;; but have different bit patterns. -- JES, 2007-08-21
+  (loop with i = -1
+        for dsd in (dd-slots (layout-info layout))
+        for raw-type = (dsd-raw-type dsd)
+        for rsd = (when raw-type
+                    (find raw-type
+                          *raw-slot-data-list*
+                          :key 'raw-slot-data-raw-type))
+        for accessor = (when rsd
+                         (raw-slot-data-accessor-name rsd))
+        always (or (not accessor)
+                   (progn
+                     (incf i)
+                     (equalp (funcall accessor x i)
+                             (funcall accessor y i))))))
 \f
 ;;; default PRINT-OBJECT method