From 285c8cecc6e960fc7ea460b22ae857b46e61aefa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 13 Jun 2009 18:34:27 -0500
Subject: [PATCH] Add some failing unit tests exposing bugs in initial-quot:
 implementation

---
 .../escape-analysis-tests.factor              |  9 ++++-
 core/classes/tuple/tuple-tests.factor         | 34 ++++++++++++++++++-
 core/classes/tuple/tuple.factor               | 16 +++------
 3 files changed, 46 insertions(+), 13 deletions(-)

diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor
index 708992f918..2688f7f8f1 100644
--- 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 352d66f19e..4b23578a29 100644
--- 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 e5ea80bc39..4ca57a59ed 100755
--- 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 ]