From d29c71d82113799ae0ac7f851da1c05adf8e6642 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Thu, 11 Jun 2009 19:48:14 -0500
Subject: [PATCH] add initial-quot: syntax for tuples

---
 core/bootstrap/syntax.factor                  |  1 +
 core/classes/tuple/parser/parser-tests.factor | 16 +++++++++++++++-
 core/classes/tuple/tuple.factor               | 15 +++++++++++++--
 core/slots/slots.factor                       | 15 +++++++++++++--
 core/syntax/syntax.factor                     |  4 +++-
 5 files changed, 45 insertions(+), 6 deletions(-)

diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index f5182a0210..24538229c6 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -80,6 +80,7 @@ IN: bootstrap.syntax
     ">>"
     "call-next-method"
     "initial:"
+    "initial-quot:"
     "read-only"
     "call("
     "execute("
diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor
index b95507c78b..88fca567f4 100644
--- a/core/classes/tuple/parser/parser-tests.factor
+++ b/core/classes/tuple/parser/parser-tests.factor
@@ -1,7 +1,7 @@
 IN: classes.tuple.parser.tests
 USING: accessors classes.tuple.parser lexer words classes
 sequences math kernel slots tools.test parser compiler.units
-arrays classes.tuple eval ;
+arrays classes.tuple eval multiline ;
 
 TUPLE: test-1 ;
 
@@ -142,3 +142,17 @@ TUPLE: parsing-corner-case x ;
         "    x 3 }"
     } "\n" join eval( -- tuple )
 ] [ error>> unexpected-eof? ] must-fail-with
+
+
+[ ] [
+    <" USE: sequences
+    IN: classes.tuple.tests
+    TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;">
+    eval( -- )
+] unit-test
+
+[ ] [
+    <" IN: classes.tuple.tests
+    TUPLE: monster { hp virtual } ;">
+    eval( -- )
+] unit-test
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 225176f4e5..9e0c0b7316 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -50,8 +50,19 @@ M: tuple class layout-of 2 slot { word } declare ;
 
 PRIVATE>
 
+: initial-value ( slot -- obj )
+    dup initial>> [
+        nip
+    ] [
+        dup initial-quot>> [
+            nip call( -- obj )
+        ] [
+            drop f
+        ] if*
+    ] if* ;
+
 : initial-values ( class -- slots )
-    all-slots [ initial>> ] map ;
+    all-slots [ initial-value ] map ;
 
 : pad-slots ( slots class -- slots' class )
     [ initial-values over length tail append ] keep ; inline
@@ -176,7 +187,7 @@ ERROR: bad-superclass class ;
 : compute-slot-permutation ( new-slots old-slots -- triples )
     [ [ [ name>> ] map ] bi@ [ index ] curry map ]
     [ drop [ class>> ] map ]
-    [ drop [ initial>> ] map ]
+    [ drop [ initial-value ] map ]
     2tri 3array flip ;
 
 : update-slot ( old-values n class initial -- value )
diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 304ded0adb..9db26846d0 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -3,10 +3,10 @@
 USING: arrays byte-arrays kernel kernel.private math namespaces
 make sequences strings effects generic generic.standard
 classes classes.algebra slots.private combinators accessors
-words sequences.private assocs alien quotations hashtables ;
+words sequences.private assocs alien quotations hashtables summary ;
 IN: slots
 
-TUPLE: slot-spec name offset class initial read-only ;
+TUPLE: slot-spec name offset class initial initial-quot read-only ;
 
 PREDICATE: reader < word "reader" word-prop ;
 
@@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ;
     dup empty? [
         unclip {
             { initial: [ [ first >>initial ] [ rest ] bi ] }
+            { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
             { read-only [ [ t >>read-only ] dip ] }
             [ bad-slot-attribute ]
         } case
@@ -197,7 +198,17 @@ ERROR: bad-slot-attribute key ;
 
 ERROR: bad-initial-value name ;
 
+ERROR: duplicate-initial-values slot ;
+
+M: duplicate-initial-values summary
+    drop "Slots can either define initial: or initial-quot:, but not both" ;
+
+: check-duplicate-initial-values ( slot-spec -- slot-spec )
+    dup [ initial>> ] [ initial-quot>> ] bi and
+    [ duplicate-initial-values ] when ;
+
 : check-initial-value ( slot-spec -- slot-spec )
+    check-duplicate-initial-values
     dup initial>> [
         [ ] [
             dup [ initial>> ] [ class>> ] bi instance?
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index 56ac9fa36e..8093b6345b 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -245,7 +245,9 @@ IN: bootstrap.syntax
     ] define-core-syntax
     
     "initial:" "syntax" lookup define-symbol
-    
+
+    "initial-quot:" "syntax" lookup define-symbol
+
     "read-only" "syntax" lookup define-symbol
 
     "call(" [ \ call-effect parse-call( ] define-core-syntax