add STRUCT: support to functors

basis/functors/functors-tests.factor

@@ -1,5 +1,5 @@
-USING: functors tools.test math words kernel multiline parser
-io.streams.string generic ;
+USING: classes.struct functors tools.test math words kernel
+multiline parser io.streams.string generic ;
 IN: functors.tests
 
 <<
@@ -151,3 +151,64 @@ SYMBOL: W-symbol
 
 test-redefinition
 
+<<
+
+FUNCTOR: define-a-struct ( T NAME TYPE N -- )
+
+T-class DEFINES-CLASS ${T}
+
+WHERE
+
+STRUCT: T-class
+    { NAME int }
+    { "x" { TYPE 4 } }
+    { "y" { "short" N } }
+    { "z" TYPE initial: 5 }
+    { "w" { "int" 2 } } ;
+
+;FUNCTOR
+
+"a-struct" "nemo" "char" 2 define-a-struct
+
+>>
+
+[
+    {
+        T{ struct-slot-spec
+            { name "nemo" }
+            { offset 0 }
+            { class integer }
+            { initial 0 } 
+            { c-type "int" }
+        }
+        T{ struct-slot-spec
+            { name "x" }
+            { offset 4 }
+            { class object }
+            { initial f } 
+            { c-type { "char" 4 } }
+        }
+        T{ struct-slot-spec
+            { name "y" }
+            { offset 8 }
+            { class object }
+            { initial f } 
+            { c-type { "short" 2 } }
+        }
+        T{ struct-slot-spec
+            { name "z" }
+            { offset 12 }
+            { class fixnum }
+            { initial 5 } 
+            { c-type "char" }
+        }
+        T{ struct-slot-spec
+            { name "w" }
+            { offset 16 }
+            { class object }
+            { initial f } 
+            { c-type { "int" 2 } }
+        }
+    }
+] [ a-struct struct-slots ] unit-test
+

basis/functors/functors.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.mixin classes.parser
-classes.singleton classes.tuple classes.tuple.parser
+classes.singleton classes.struct classes.tuple classes.tuple.parser
 combinators effects.parser fry generic generic.parser
 generic.standard interpolate io.streams.string kernel lexer
-locals.parser locals.types macros make namespaces parser
-quotations sequences vocabs.parser words words.symbol ;
+locals locals.parser locals.types macros make namespaces parser
+quotations sequences slots vectors vocabs.parser words words.symbol ;
 IN: functors
 
 ! This is a hack
@@ -58,6 +58,32 @@ M: object (fake-quotations>) , ;
     [ parse-definition* ] dip
     parsed ;
 
+: scan-c-type* ( -- c-type/param )
+    scan {
+        { [ dup "{" =  ] [ drop \ } parse-until >array ] }
+        { [ dup search ] [ search ] }
+        [ ]
+    } cond ;
+
+:: parse-struct-slot* ( accum -- accum )
+    scan-param :> name
+    scan-c-type* :> c-type
+    \ } parse-until :> attributes
+    accum {
+        \ struct-slot-spec new 
+            name >>name
+            c-type [ >>c-type ] [ struct-slot-class >>class ] bi
+            attributes [ dup empty? ] [ peel-off-attributes ] until drop
+        over push
+    } over push-all ;
+
+: parse-struct-slots* ( accum -- accum more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot* t ] }
+        [ invalid-struct-slot ]
+    } case ;
+
 SYNTAX: `TUPLE:
     scan-param parsed
     scan {
@@ -71,6 +97,12 @@ SYNTAX: `TUPLE:
     } case
     \ define-tuple-class parsed ;
 
+SYNTAX: `STRUCT:
+    scan-param parsed
+    [ 8 <vector> ] over push-all
+    [ parse-struct-slots* ] [ ] while
+    [ >array define-struct-class ] over push-all ;
+
 SYNTAX: `SINGLETON:
     scan-param parsed
     \ define-singleton-class parsed ;
@@ -147,6 +179,7 @@ DEFER: ;FUNCTOR delimiter
 : functor-words ( -- assoc )
     H{
         { "TUPLE:" POSTPONE: `TUPLE: }
+        { "STRUCT:" POSTPONE: `STRUCT: }
         { "SINGLETON:" POSTPONE: `SINGLETON: }
         { "MIXIN:" POSTPONE: `MIXIN: }
         { "M:" POSTPONE: `M: }