1 ! Copyright (C) 2009 Joe Groff.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays classes classes.mixin classes.parser
4 classes.singleton classes.tuple classes.tuple.parser
5 classes.union combinators inverse kernel lexer macros make
6 parser quotations sequences slots splitting words ;
9 PREDICATE: variant-class < mixin-class "variant?" word-prop ;
11 M: variant-class initial-value*
12 class-members [ f f ] [
13 first dup word? [ t ] [ initial-value* ] if
16 : define-tuple-class-and-boa-word ( class superclass slots -- )
17 pick [ define-tuple-class ] dip
18 dup name>> "<" ">" surround create-word-in swap define-boa-word ;
20 : define-variant-member ( member -- class )
21 dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
23 : define-variant-class ( class -- )
24 [ define-mixin-class ] [ t "variant?" set-word-prop ] bi ;
26 : define-variant-class-member ( class member -- )
27 define-variant-member swap add-mixin-instance ;
29 : define-variant-class-members ( class members -- )
30 [ dup define-variant-class ] dip
31 [ define-variant-class-member ] with each ;
33 : parse-variant-tuple-member ( name -- member )
36 [ "}" parse-tuple-slots-delim ] { } make
39 : parse-variant-member ( name -- member )
40 ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
42 : parse-variant-members ( -- members )
43 [ scan-token dup ";" = not ]
44 [ parse-variant-member ] produce nip ;
49 define-variant-class-members ;
51 SYNTAX: VARIANT-MEMBER:
53 scan-token parse-variant-member
54 define-variant-class-member ";" expect ;
56 MACRO: unboa ( class -- quot )
57 <wrapper> \ boa [ ] 2sequence [undo] ;
59 GENERIC#: (match-branch) 1 ( class quot -- class quot' )
61 M: singleton-class (match-branch)
63 M: object (match-branch)
64 over \ unboa [ ] 2sequence prepend ;
66 : ?class ( object -- class )
67 dup word? [ class-of ] unless ;
69 MACRO: match ( branches -- quot )
70 [ dup callable? [ first2 (match-branch) 2array ] unless ] map
71 [ \ dup \ ?class ] dip \ case [ ] 4sequence ;