extend T{ } syntax to build structs

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 ;

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 -- )

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 ;

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