Add some failing unit tests exposing bugs in initial-quot: implementation

diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 708992f91875b12fbc2aa9415fb07951e0d0a017..2688f7f8f1044eb24bd09eedcd85bb70f58e63f2 100644 (file)
--- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
+++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
@@ -327,4 +327,11 @@ C: <ro-box> ro-box
 
 TUPLE: empty-tuple ;
 
-[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
\ No newline at end of file
+[ ] [ [ empty-tuple boa layout-of ] count-unboxed-allocations drop ] unit-test
+
+! Make sure that initial-quot: doesn't inhibit unboxing
+TUPLE: initial-quot-tuple { x read-only initial-quot: [ 0 ] } ;
+
+[ 1 ] [
+    [ initial-quot-tuple new x>> ] count-unboxed-allocations
+] unit-test
\ No newline at end of file

diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor
index 352d66f19e6d0bc1f8bc72156bc5dfdbee5c78d8..4b23578a297ca8dfb655dac7f5a2fe89fd81ae27 100644 (file)
--- a/core/classes/tuple/tuple-tests.factor
+++ b/core/classes/tuple/tuple-tests.factor
@@ -733,7 +733,11 @@ DEFER: redefine-tuple-twice
 TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ;
 SLOT: winner?
 
-[ f ] [ 100 [ lucky-number new ] replicate all-equal? ] unit-test
+[ t ] [ lucky-number new n>> integer? ] unit-test
+
+: compiled-lucky-number ( -- tuple ) lucky-number new ;
+
+[ t ] [ compiled-lucky-number n>> integer? ] unit-test
 
 ! Reshaping initial-quot:
 lucky-number new dup n>> 2array "luckiest-number" set
@@ -744,3 +748,31 @@ lucky-number new dup n>> 2array "luckiest-number" set
 
 [ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test
 [ t ] [ "luckiest-number" get first winner?>> ] unit-test
+
+! invalid-quot: together with type declaration
+TUPLE: decl-initial-quot { x integer initial-quot: [ 1 ] } ;
+
+[ t ] [ decl-initial-quot new x>> integer? ] unit-test
+
+: compiled-decl-initial-quot ( -- tuple ) decl-initial-quot new ;
+
+[ t ] [ compiled-decl-initial-quot x>> integer? ] unit-test
+
+! invalid-quot: with read-only
+TUPLE: read-only-initial-quot { x integer read-only initial-quot: [ 1 ] } ;
+
+[ t ] [ read-only-initial-quot new x>> integer? ] unit-test
+
+: compiled-read-only-initial-quot ( -- tuple ) read-only-initial-quot new ;
+
+[ t ] [ compiled-read-only-initial-quot x>> integer? ] unit-test
+
+! Specifying both initial: and initial-quot: should fail
+2 [
+    [
+        "IN: classes.tuple.test TUPLE: redundant-decl { x initial: 0 initial-quot: [ 0 ] } ;"
+        eval( -- )
+    ]
+    [ error>> duplicate-initial-values? ]
+    must-fail-with
+] times

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index e5ea80bc391cfa8c6d9817f4489cdebf99ef926f..4ca57a59ed1d1b448e07f2afd1a7380ff3d2f629 100755 (executable)
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -153,8 +153,7 @@ ERROR: bad-superclass class ;
     all-slots [ initial-quot>> ] filter
     [
         [
-            [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
-            [ offset>> , ] bi \ set-slot ,
+            [ initial-quot>> % \ over , ] [ offset>> , ] bi \ set-slot ,
         ] each
     ] [ ] make f like ;
 
@@ -187,15 +186,10 @@ ERROR: bad-superclass class ;
     dup make-tuple-layout "layout" set-word-prop ;
 
 : calculate-initial-value ( slot-spec -- value )
-    dup initial>> [
-        nip
-    ] [
-        dup initial-quot>> [
-            nip call( -- obj )
-        ] [
-            drop f
-        ] if*
-    ] if* ;
+    dup initial>> [ ] [
+        dup initial-quot>>
+        [ call( -- obj ) ] [ drop f ] ?if
+    ] ?if ;
 
 : compute-slot-permutation ( new-slots old-slots -- triples )
     [ [ [ name>> ] map ] bi@ [ index ] curry map ]