extend T{ } syntax to build structs

diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index 6b106e48d9be724b72315e51047ff09393245df4..39a5d56f71b9bde7fa3f9b8a6e1297c816b8db00 100644 (file)
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -87,19 +87,21 @@ ERROR: bad-literal-tuple ;
 : parse-slot-values ( -- values )
     [ (parse-slot-values) ] { } make ;
 
-: boa>tuple ( class slots -- tuple )
+GENERIC# boa>object 1 ( class slots -- tuple )
+
+M: tuple-class boa>object
     swap prefix >tuple ;
 
-: assoc>tuple ( class slots -- tuple )
-    [ [ ] [ initial-values ] [ all-slots ] tri ] dip
-    swap [ [ slot-named offset>> 2 - ] curry dip ] curry assoc-map
-    [ dup <enum> ] dip update boa>tuple ;
+: assoc>object ( class slots -- tuple )
+    [ [ ] [ initial-values ] [ class-slots ] tri ] dip
+    swap [ [ slot-named* drop ] curry dip ] curry assoc-map
+    [ dup <enum> ] dip update boa>object ;
 
 : parse-tuple-literal-slots ( class -- tuple )
     scan {
         { f [ unexpected-eof ] }
-        { "f" [ \ } parse-until boa>tuple ] }
-        { "{" [ parse-slot-values assoc>tuple ] }
+        { "f" [ \ } parse-until boa>object ] }
+        { "{" [ parse-slot-values assoc>object ] }
         { "}" [ new ] }
         [ bad-literal-tuple ]
     } case ;

diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 9964df03c0ad6e034b4b06dbf5a4aa780db47ff1..6d0c2c8242a88374cc11e446192c9e37d827b832 100755 (executable)
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -55,11 +55,14 @@ M: tuple class layout-of 2 slot { word } declare ;
 
 PRIVATE>
 
-: initial-values ( class -- slots )
+: tuple-initial-values ( class -- slots )
     all-slots [ initial>> ] map ;
 
+: initial-values ( class -- slots )
+    class-slots [ initial>> ] map ;
+
 : pad-slots ( slots class -- slots' class )
-    [ initial-values over length tail append ] keep ; inline
+    [ tuple-initial-values over length tail append ] keep ; inline
 
 : tuple>array ( tuple -- array )
     prepare-tuple>array
@@ -156,7 +159,7 @@ ERROR: bad-superclass class ;
     dup boa-check-quot "boa-check" set-word-prop ;
 
 : tuple-prototype ( class -- prototype )
-    [ initial-values ] keep over [ ] any?
+    [ tuple-initial-values ] keep over [ ] any?
     [ slots>tuple ] [ 2drop f ] if ;
 
 : define-tuple-prototype ( class -- )

diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 4873a52542c15289ad2f0d4ecf92cc8885587ca0..7e86bd93ee36106660415e927dc64b3df111c057 100755 (executable)
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -236,5 +236,8 @@ M: slot-spec make-slot
 : finalize-slots ( specs base -- specs )
     over length iota [ + ] with map [ >>offset ] 2map ;
 
+: slot-named* ( name specs -- offset spec/f )
+    [ name>> = ] with find ;
+
 : slot-named ( name specs -- spec/f )
-    [ name>> = ] with find nip ;
+    slot-named* nip ;

diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index 8ae72625eb40522dc7ae6b6643b3e01d7e6a2469..29e5718def12fbe49a1a45208bf977f8897c48ac 100644 (file)
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -47,6 +47,14 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
 M: struct-class boa
     <struct-boa> ; inline
 
+: pad-struct-slots ( slots class -- slots' class )
+    [ class-slots [ initial>> ] map over length tail append ] keep ;
+
+M: struct-class boa>object
+    swap pad-struct-slots
+    [ <struct> swap ] [ "struct-slots" word-prop ] bi 
+    [ name>> setter-word execute( struct value -- struct ) ] 2each ;
+
 ! Struct slot accessors
 
 M: struct-class reader-quot