-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
<<
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
+
! 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
[ 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 {
} 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 ;
: functor-words ( -- assoc )
H{
{ "TUPLE:" POSTPONE: `TUPLE: }
+ { "STRUCT:" POSTPONE: `STRUCT: }
{ "SINGLETON:" POSTPONE: `SINGLETON: }
{ "MIXIN:" POSTPONE: `MIXIN: }
{ "M:" POSTPONE: `M: }