0.pre7.80:

[sbcl.git] / tests / defstruct.impure.lisp

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 0a72dbd..e0995f3 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -132,46 +132,46 @@
 (defun symbol+ (&rest rest)
   (values (intern (apply #'string+ rest))))
 
-(defun accessor-name (concname slotname)
-  (symbol+ concname slotname))
+(defun accessor-name (conc-name slot-name)
+  (symbol+ conc-name slot-name))
 
 ;;; Use the ordinary FDEFINITIONs of accessors (not inline expansions)
 ;;; to read and write a structure slot.
-(defun read-slot-notinline (concname slotname instance)
-  (funcall (accessor-name concname slotname) instance))
-(defun write-slot-notinline (new-value concname slotname instance)
-  (funcall (fdefinition `(setf ,(accessor-name concname slotname)))
+(defun read-slot-notinline (conc-name slot-name instance)
+  (funcall (accessor-name conc-name slot-name) instance))
+(defun write-slot-notinline (new-value conc-name slot-name instance)
+  (funcall (fdefinition `(setf ,(accessor-name conc-name slot-name)))
           new-value instance))
 
 ;;; Use inline expansions of slot accessors, if possible, to read and
 ;;; write a structure slot.
-(defun read-slot-inline (concname slotname instance)
+(defun read-slot-inline (conc-name slot-name instance)
   (funcall (compile nil
                    `(lambda (instance)
-                      (,(accessor-name concname slotname) instance)))
+                      (,(accessor-name conc-name slot-name) instance)))
           instance))
-(defun write-slot-inline (new-value concname slotname instance)
+(defun write-slot-inline (new-value conc-name slot-name instance)
   (funcall (compile nil
                    `(lambda (new-value instance)
-                      (setf (,(accessor-name concname slotname) instance)
+                      (setf (,(accessor-name conc-name slot-name) instance)
                             new-value)))
           new-value
           instance))
 
 ;;; Read a structure slot, checking that the inline and out-of-line
 ;;; accessors give the same result.
-(defun read-slot (concname slotname instance)
-  (let ((inline-value (read-slot-inline concname slotname instance))
-       (notinline-value (read-slot-notinline concname slotname instance)))
+(defun read-slot (conc-name slot-name instance)
+  (let ((inline-value (read-slot-inline conc-name slot-name instance))
+       (notinline-value (read-slot-notinline conc-name slot-name instance)))
     (assert (eql inline-value notinline-value))
     inline-value))
 
 ;;; Write a structure slot, using INLINEP argument to decide
 ;;; on inlineness of accessor used.
-(defun write-slot (new-value concname slotname instance inlinep)
+(defun write-slot (new-value conc-name slot-name instance inlinep)
   (if inlinep
-      (write-slot-inline new-value concname slotname instance)
-      (write-slot-notinline new-value concname slotname instance)))
+      (write-slot-inline new-value conc-name slot-name instance)
+      (write-slot-notinline new-value conc-name slot-name instance)))
 
 ;;; bound during the tests so that we can get to it even if the
 ;;; debugger is having a bad day
@@ -274,6 +274,56 @@
 (test-variant vector-struct :colontype vector)
 (test-variant list-struct :colontype list)
 \f
+;;;; testing raw slots harder
+;;;;
+;;;; The offsets of raw slots need to be rescaled during the punning
+;;;; process which is used to access them. That seems like a good
+;;;; place for errors to lurk, so we'll try hunting for them by
+;;;; verifying that all the raw slot data gets written successfully
+;;;; into the object, can be copied with the object, and can then be
+;;;; read back out (with none of it ending up bogusly outside the
+;;;; object, so that it couldn't be copied, or bogusly overwriting
+;;;; some other raw slot).
+
+(defstruct manyraw
+  (a (expt 2 30) :type (unsigned-byte 32))
+  (b 0.1 :type single-float)
+  (c 0.2d0 :type double-float)
+  (d #c(0.3 0.3) :type (complex single-float))
+  unraw-slot-just-for-variety
+  (e #c(0.4d0 0.4d0) :type (complex double-float))
+  (aa (expt 2 30) :type (unsigned-byte 32))
+  (bb 0.1 :type single-float)
+  (cc 0.2d0 :type double-float)
+  (dd #c(0.3 0.3) :type (complex single-float))
+  (ee #c(0.4d0 0.4d0) :type (complex double-float)))
+
+(defvar *manyraw* (make-manyraw))
+
+(assert (eql (manyraw-a *manyraw*) (expt 2 30)))
+(assert (eql (manyraw-b *manyraw*) 0.1))
+(assert (eql (manyraw-c *manyraw*) 0.2d0))
+(assert (eql (manyraw-d *manyraw*) #c(0.3 0.3)))
+(assert (eql (manyraw-e *manyraw*) #c(0.4d0 0.4d0)))
+(assert (eql (manyraw-aa *manyraw*) (expt 2 30)))
+(assert (eql (manyraw-bb *manyraw*) 0.1))
+(assert (eql (manyraw-cc *manyraw*) 0.2d0))
+(assert (eql (manyraw-dd *manyraw*) #c(0.3 0.3)))
+(assert (eql (manyraw-ee *manyraw*) #c(0.4d0 0.4d0)))
+
+(setf (manyraw-aa *manyraw*) (expt 2 31)
+      (manyraw-bb *manyraw*) 0.11
+      (manyraw-cc *manyraw*) 0.22d0
+      (manyraw-dd *manyraw*) #c(0.33 0.33)
+      (manyraw-ee *manyraw*) #c(0.44d0 0.44d0))
+
+(let ((copy (copy-manyraw *manyraw*)))
+  (assert (eql (manyraw-aa copy) (expt 2 31)))
+  (assert (eql (manyraw-bb copy) 0.11))
+  (assert (eql (manyraw-cc copy) 0.22d0))
+  (assert (eql (manyraw-dd copy) #c(0.33 0.33)))
+  (assert (eql (manyraw-ee copy) #c(0.44d0 0.44d0))))
+\f
 ;;; success
 (format t "~&/returning success~%")
 (quit :unix-status 104)