1 ! (c)2009 Joe Groff bsd license
2 USING: accessors arrays classes classes.mixin classes.parser
3 classes.singleton classes.tuple classes.tuple.parser
4 classes.union combinators inverse kernel lexer macros make
5 parser quotations sequences slots splitting words ;
8 PREDICATE: variant-class < mixin-class "variant" word-prop ;
10 M: variant-class initial-value*
11 dup members [ no-initial-value ]
12 [ nip first dup word? [ initial-value* ] unless ] if-empty ;
14 : define-tuple-class-and-boa-word ( class superclass slots -- )
15 pick [ define-tuple-class ] dip
16 dup name>> "<" ">" surround create-in swap define-boa-word ;
18 : define-variant-member ( member -- class )
19 dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
21 : define-variant-class ( class -- )
22 [ define-mixin-class ] [ t "variant" set-word-prop ] bi ;
24 : define-variant-class-member ( class member -- )
25 define-variant-member swap add-mixin-instance ;
27 : define-variant-class-members ( class members -- )
28 [ dup define-variant-class ] dip
29 [ define-variant-class-member ] with each ;
31 : parse-variant-tuple-member ( name -- member )
34 [ "}" parse-tuple-slots-delim ] { } make
37 : parse-variant-member ( name -- member )
38 ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
40 : parse-variant-members ( -- members )
41 [ scan dup ";" = not ]
42 [ parse-variant-member ] produce nip ;
47 define-variant-class-members ;
49 SYNTAX: VARIANT-MEMBER:
51 scan parse-variant-member
52 define-variant-class-member ;
54 MACRO: unboa ( class -- )
55 <wrapper> \ boa [ ] 2sequence [undo] ;
57 GENERIC# (match-branch) 1 ( class quot -- class quot' )
59 M: singleton-class (match-branch)
61 M: object (match-branch)
62 over \ unboa [ ] 2sequence prepend ;
64 : ?class ( object -- class )
65 dup word? [ class ] unless ;
67 MACRO: match ( branches -- )
68 [ dup callable? [ first2 (match-branch) 2array ] unless ] map
69 [ \ dup \ ?class ] dip \ case [ ] 4sequence ;