-! (c)2009 Joe Groff bsd license
+! Copyright (C) 2009 Joe Groff.
+! See https://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes classes.mixin classes.parser
classes.singleton classes.tuple classes.tuple.parser
classes.union combinators inverse kernel lexer macros make
parser quotations sequences slots splitting words ;
IN: variants
-PREDICATE: variant-class < mixin-class "variant" word-prop ;
+PREDICATE: variant-class < mixin-class "variant?" word-prop ;
M: variant-class initial-value*
- dup members [ no-initial-value ]
- [ nip first dup word? [ initial-value* ] unless ] if-empty ;
+ class-members [ f f ] [
+ first dup word? [ t ] [ initial-value* ] if
+ ] if-empty ;
: define-tuple-class-and-boa-word ( class superclass slots -- )
pick [ define-tuple-class ] dip
- dup name>> "<" ">" surround create-in swap define-boa-word ;
+ dup name>> "<" ">" surround create-word-in swap define-boa-word ;
: define-variant-member ( member -- class )
dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
: define-variant-class ( class -- )
- [ define-mixin-class ] [ t "variant" set-word-prop ] bi ;
+ [ define-mixin-class ] [ t "variant?" set-word-prop ] bi ;
: define-variant-class-member ( class member -- )
define-variant-member swap add-mixin-instance ;
":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
: parse-variant-members ( -- members )
- [ scan dup ";" = not ]
+ [ scan-token dup ";" = not ]
[ parse-variant-member ] produce nip ;
SYNTAX: VARIANT:
- CREATE-CLASS
+ scan-new-class
parse-variant-members
define-variant-class-members ;
SYNTAX: VARIANT-MEMBER:
scan-word
- scan parse-variant-member
- define-variant-class-member ;
+ scan-token parse-variant-member
+ define-variant-class-member ";" expect ;
-MACRO: unboa ( class -- )
+MACRO: unboa ( class -- quot )
<wrapper> \ boa [ ] 2sequence [undo] ;
-GENERIC# (match-branch) 1 ( class quot -- class quot' )
+GENERIC#: (match-branch) 1 ( class quot -- class quot' )
M: singleton-class (match-branch)
\ drop prefix ;
over \ unboa [ ] 2sequence prepend ;
: ?class ( object -- class )
- dup word? [ class ] unless ;
+ dup word? [ class-of ] unless ;
-MACRO: match ( branches -- )
+MACRO: match ( branches -- quot )
[ dup callable? [ first2 (match-branch) 2array ] unless ] map
[ \ dup \ ?class ] dip \ case [ ] 4sequence ;
-