Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv27440/tests
Modified Files:
defstruct.impure.lisp dynamic-extent.impure.lisp
Log Message:
1.0.17.4: support for dynamic-extent structures
* Replace %MAKE-INSTANCE-WITH-LAYOUT with %MAKE-STRUCTURE-INSTANCE,
which has an IR2 transform that can handle both initialization and
allocation of the structure. On x86 and x86-64 it can initialize
all slots, whereas on other platforms it only does the layout and
non-raw slots. (See RAW-INSTANCE-INIT/* below.)
* EMIT-INITS needs two new kinds of inits to handle: :SLOT for
instance slots, and :DD for the defstruct-description/layout.
* DEF-ALLOC doesn't anymore use a simple boolean for denoting
variable length allocation, but instead a keyword: either
:VAR-ALLOC, :FIXED-ALLOC, or :STRUCTURE-ALLOC.
* New VOPs: RAW-INSTANCE-INIT/* for all raw slot types, which are
almost identical to RAW-INSTANCE-SET[-C]/* VOPs, except that they
always have a constant index and do not return a result. Structures
with raw slots can be stack allocated only on platforms that
implement these VOPs, denoted in make-config.sh by the
:RAW-INSTANCE-INIT-VOPS feature. ...we really could use a
*VM-FEATURES* or something.
Index: defstruct.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/defstruct.impure.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- defstruct.impure.lisp 21 Aug 2007 05:18:42 -0000 1.31
+++ defstruct.impure.lisp 28 May 2008 22:32:28 -0000 1.32
@@ -715,3 +715,25 @@
(make-raw-slot-equalp-bug :a 1d0 :b 3s0))))
(assert (not (equalp (make-raw-slot-equalp-bug :a 1d0 :b 2s0)
(make-raw-slot-equalp-bug :a 2d0 :b 2s0)))))
+
+;;; Check that all slot types (non-raw and raw) can be initialized with
+;;; constant arguments.
+(defstruct constant-arg-inits
+ (a 42 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float)
+ (f #c(5.0 5.0) :type (complex single-float))
+ (g #c(6.0d0 6.0d0) :type (complex double-float)))
+(defun test-constant-arg-inits ()
+ (let ((foo (make-constant-arg-inits)))
+ (declare (dynamic-extent foo))
+ (assert (eql 42 (constant-arg-inits-a foo)))
+ (assert (eql 1 (constant-arg-inits-b foo)))
+ (assert (eql 2 (constant-arg-inits-c foo)))
+ (assert (eql 3.0 (constant-arg-inits-d foo)))
+ (assert (eql 4.0d0 (constant-arg-inits-e foo)))
+ (assert (eql #c(5.0 5.0) (constant-arg-inits-f foo)))
+ (assert (eql #c(6.0d0 6.0d0) (constant-arg-inits-g foo)))))
+(make-constant-arg-inits)
Index: dynamic-extent.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/dynamic-extent.impure.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- dynamic-extent.impure.lisp 12 May 2008 14:12:43 -0000 1.25
+++ dynamic-extent.impure.lisp 28 May 2008 22:32:28 -0000 1.26
@@ -155,6 +155,190 @@
(true v)
nil))
+;;; MAKE-STRUCTURE
+
+(declaim (inline make-fp-struct-1))
+(defstruct fp-struct-1
+ (s 0.0 :type single-float)
+ (d 0.0d0 :type double-float))
+
+(defun-with-dx test-fp-struct-1.1 (s d)
+ (let ((fp (make-fp-struct-1 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql 0.0d0 (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.2 (s d)
+ (let ((fp (make-fp-struct-1 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.3 (s d)
+ (let ((fp (make-fp-struct-1 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.4 (s d)
+ (let ((fp (make-fp-struct-1 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(test-fp-struct-1.1 123.456 876.243d0)
+(test-fp-struct-1.2 123.456 876.243d0)
+(test-fp-struct-1.3 123.456 876.243d0)
+(test-fp-struct-1.4 123.456 876.243d0)
+
+(declaim (inline make-fp-struct-2))
+(defstruct fp-struct-2
+ (d 0.0d0 :type double-float)
+ (s 0.0 :type single-float))
+
+(defun-with-dx test-fp-struct-2.1 (s d)
+ (let ((fp (make-fp-struct-2 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql 0.0d0 (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.2 (s d)
+ (let ((fp (make-fp-struct-2 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.3 (s d)
+ (let ((fp (make-fp-struct-2 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.4 (s d)
+ (let ((fp (make-fp-struct-2 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(test-fp-struct-2.1 123.456 876.243d0)
+(test-fp-struct-2.2 123.456 876.243d0)
+(test-fp-struct-2.3 123.456 876.243d0)
+(test-fp-struct-2.4 123.456 876.243d0)
+
+(declaim (inline make-cfp-struct-1))
+(defstruct cfp-struct-1
+ (s (complex 0.0) :type (complex single-float))
+ (d (complex 0.0d0) :type (complex double-float)))
+
+(defun-with-dx test-cfp-struct-1.1 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.2 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.3 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.4 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+
+(declaim (inline make-cfp-struct-2))
+(defstruct cfp-struct-2
+ (d (complex 0.0d0) :type (complex double-float))
+ (s (complex 0.0) :type (complex single-float)))
+
+(defun-with-dx test-cfp-struct-2.1 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.2 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.3 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.4 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+
+(declaim (inline make-foo1 make-foo2 make-foo3))
+(defstruct foo1 x)
+
+(defun-with-dx make-foo1-on-stack (x)
+ (let ((foo (make-foo1 :x x)))
+ (declare (dynamic-extent foo))
+ (assert (eql x (foo1-x foo)))))
+
+(defstruct foo2
+ (x 0.0 :type single-float)
+ (y 0.0d0 :type double-float)
+ a
+ b
+ c)
+
+(defmacro assert-eql (expected got)
+ `(let ((exp ,expected)
+ (got ,got))
+ (unless (eql exp got)
+ (error "Expected ~S, got ~S!" exp got))))
+
+(defun-with-dx make-foo2-on-stack (x y)
+ (let ((foo (make-foo2 :y y :c 'c)))
+ (declare (dynamic-extent foo))
+ (assert-eql 0.0 (foo2-x foo))
+ (assert-eql y (foo2-y foo))
+ (assert-eql 'c (foo2-c foo))
+ (assert-eql nil (foo2-b foo))))
+
+;;; Check that constants work out as argument for all relevant
+;;; slot types.
+(defstruct foo3
+ (a 0 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float))
+(defun-with-dx make-foo3-on-stack ()
+ (let ((foo (make-foo3)))
+ (declare (dynamic-extent foo))
+ (assert (eql 0 (foo3-a foo)))
+ (assert (eql 1 (foo3-b foo)))
+ (assert (eql 2 (foo3-c foo)))
+ (assert (eql 3.0 (foo3-d foo)))
+ (assert (eql 4.0d0 (foo3-e foo)))))
+
;;; Nested DX
(defun-with-dx nested-dx-lists ()
@@ -250,6 +434,13 @@
(assert-no-consing (dx-value-cell 13))
(assert-no-consing (cons-on-stack 42))
(assert-no-consing (make-array-on-stack))
+ (assert-no-consing (make-foo1-on-stack 123))
+ (#+raw-instance-init-vops assert-no-consing
+ #-raw-instance-init-vops progn
+ (make-foo2-on-stack 1.24 1.23d0))
+ (#+raw-instance-init-vops assert-no-consing
+ #-raw-instance-init-vops progn
+ (make-foo3-on-stack))
(assert-no-consing (nested-dx-conses))
(assert-no-consing (nested-dx-lists))
(assert-consing (nested-dx-not-used *a-cons*))
|