-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences quotations namespaces io
+USING: kernel words sequences quotations namespaces io vectors
classes.tuple accessors prettyprint prettyprint.config
prettyprint.backend prettyprint.custom prettyprint.sections
parser compiler.tree.builder compiler.tree.optimizer
compiler.cfg.registers compiler.cfg.stack-frame
compiler.cfg.linear-scan compiler.cfg.two-operand
compiler.cfg.liveness compiler.cfg.optimizer
-compiler.cfg.mr ;
+compiler.cfg.mr compiler.cfg ;
IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: ds-loc pprint* \ D pprint-loc ;
M: rs-loc pprint* \ R pprint-loc ;
+
+: test-bb ( insns n -- )
+ [ <basic-block> swap >>number swap >>instructions ] keep set ;
+
+: test-diamond ( -- )
+ 1 get 1vector 0 get (>>successors)
+ 2 get 3 get V{ } 2sequence 1 get (>>successors)
+ 4 get 1vector 2 get (>>successors)
+ 4 get 1vector 3 get (>>successors) ;
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2008, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math namespaces sequences kernel fry
-compiler.cfg compiler.cfg.registers compiler.cfg.instructions
-compiler.cfg.liveness compiler.cfg.local ;
-IN: compiler.cfg.height
-
-! Combine multiple stack height changes into one at the
-! start of the basic block.
-
-SYMBOL: ds-height
-SYMBOL: rs-height
-
-GENERIC: compute-heights ( insn -- )
-
-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
-
-GENERIC: normalize-height* ( insn -- insn' )
-
-: normalize-inc-d/r ( insn stack -- insn' )
- swap n>> '[ _ - ] change f ; inline
-
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
-
-GENERIC: loc-stack ( loc -- stack )
-
-M: ds-loc loc-stack drop ds-height ;
-M: rs-loc loc-stack drop rs-height ;
-
-GENERIC: <loc> ( n stack -- loc )
-
-M: ds-loc <loc> drop <ds-loc> ;
-M: rs-loc <loc> drop <rs-loc> ;
-
-: normalize-peek/replace ( insn -- insn' )
- [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
-
-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
-
-M: insn normalize-height* ;
-
-: height-step ( insns -- insns' )
- 0 ds-height set
- 0 rs-height set
- [ [ compute-heights ] each ]
- [ [ [ normalize-height* ] map sift ] with-scope ] bi
- ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
- rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
-
-: normalize-height ( cfg -- cfg' )
- [ drop ] [ height-step ] local-optimization ;
+++ /dev/null
-Stack height normalization coalesces height changes at start of basic block
: live-intervals. ( seq -- )
[ interval-picture ] map simple-table. ;
-
-: test-bb ( insns n -- )
- [ <basic-block> swap >>number swap >>instructions ] keep set ;
\ No newline at end of file
T{ ##return }
} 4 test-bb
-: test-diamond ( -- )
- 1 get 1vector 0 get (>>successors)
- 2 get 3 get V{ } 2sequence 1 get (>>successors)
- 4 get 1vector 2 get (>>successors)
- 4 get 1vector 3 get (>>successors) ;
-
test-diamond
{ 1 2 3 4 } test-linear-scan-on-cfg
USING: accessors arrays classes compiler.cfg
-compiler.cfg.instructions compiler.cfg.linear-scan.debugger
+compiler.cfg.debugger compiler.cfg.instructions
+compiler.cfg.linear-scan.debugger
compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.numbering
compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
-multiline namespaces tools.test vectors ;
+namespaces tools.test vectors ;
IN: compiler.cfg.linear-scan.resolve.tests
[ { 1 2 3 4 5 6 } ] [
USING: kernel sequences accessors combinators namespaces
compiler.cfg.predecessors
compiler.cfg.useless-blocks
-compiler.cfg.height
compiler.cfg.stack-analysis
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
: optimize-cfg ( cfg -- cfg' )
[
compute-predecessors
- delete-useless-blocks
+ ! delete-useless-blocks
delete-useless-conditionals
- normalize-height
stack-analysis
compute-liveness
alias-analysis
SYMBOL: vreg-counter
: next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
-! Stack locations
+! Stack locations -- 'n' is an index starting from the top of the stack
+! going down. So 0 is the top of the stack, 1 is what would be the top
+! of the stack after a 'drop', and so on.
+
+! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
+! an ##inc-d 1 becomes D 1 after ##inc-d 1.
TUPLE: loc { n read-only } ;
TUPLE: ds-loc < loc ;
--- /dev/null
+IN: compiler.cfg.stack-analysis.merge.tests
+USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
+compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg compiler.cfg.registers compiler.cfg.debugger
+cpu.architecture make assocs
+sequences kernel classes ;
+
+[
+ { D 0 }
+ { V int-regs 0 V int-regs 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ [ merge-locs locs>vregs>> keys ] { } make first inputs>>
+] unit-test
+
+[
+ { D 0 }
+ ##peek
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state>
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ [ merge-locs locs>vregs>> keys ] { } make drop
+ ] keep first instructions>> first class
+] unit-test
+
+[
+ 0 ##inc-d
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state> -1 >>ds-height
+ <state> 2array
+
+ [ merge-ds-heights ds-height>> ] { } make drop
+ ] keep first instructions>> first class
+] unit-test
+
+[
+ 0
+ { D 0 }
+ { 1 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
+ <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+ [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
+ ] keep
+ [ instructions>> length ] map
+] unit-test
+
+[
+ -1
+ { D -1 }
+ { 1 1 }
+] [
+ <state>
+
+ <basic-block> V{ T{ ##branch } } >>instructions
+ <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+ [
+ <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
+ <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
+
+ [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
+ [ ds-height>> ] [ locs>vregs>> keys ] bi
+ ] keep
+ [ instructions>> length ] map
+] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs sequences accessors fry combinators grouping
-sets compiler.cfg compiler.cfg.hats
+sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.stack-analysis.state ;
IN: compiler.cfg.stack-analysis.merge
+! XXX critical edges
+
: initial-state ( bb states -- state ) 2drop <state> ;
: single-predecessor ( bb states -- state ) nip first clone ;
-ERROR: must-equal-failed seq ;
+: save-ds-height ( n -- )
+ dup 0 = [ drop ] [ ##inc-d ] if ;
+
+: merge-ds-heights ( state predecessors states -- state )
+ [ ds-height>> ] map dup all-equal?
+ [ nip first >>ds-height ]
+ [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
+
+: save-rs-height ( n -- )
+ dup 0 = [ drop ] [ ##inc-r ] if ;
+
+: merge-rs-heights ( state predecessors states -- state )
+ [ rs-height>> ] map dup all-equal?
+ [ nip first >>rs-height ]
+ [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
-: must-equal ( seq -- elt )
- dup all-equal? [ first ] [ must-equal-failed ] if ;
+: assoc-map-values ( assoc quot -- assoc' )
+ '[ _ dip ] assoc-map ; inline
-: merge-heights ( state predecessors states -- state )
- nip
- [ [ ds-height>> ] map must-equal >>ds-height ]
- [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+: translate-locs ( assoc state -- assoc' )
+ '[ _ translate-loc ] assoc-map-values ;
-: insert-peek ( predecessor loc -- vreg )
- ! XXX critical edges
- '[ _ ^^peek ] add-instructions ;
+: untranslate-locs ( assoc state -- assoc' )
+ '[ _ untranslate-loc ] assoc-map-values ;
-: merge-loc ( predecessors locs>vregs loc -- vreg )
+: collect-locs ( loc-maps states -- assoc )
+ ! assoc maps locs to sequences of vregs
+ [ untranslate-locs ] 2map
+ [ [ keys ] map concat prune ] keep
+ '[ dup _ [ at ] with map ] H{ } map>assoc ;
+
+: insert-peek ( predecessor state loc -- vreg )
+ '[ _ _ swap translate-loc ^^peek ] add-instructions ;
+
+: merge-loc ( predecessors states vregs loc -- vreg )
! Insert a ##phi in the current block where the input
! is the vreg storing loc from each predecessor block
- [ '[ [ _ ] dip at ] map ] keep
- '[ [ ] [ _ insert-peek ] ?if ] 2map
+ '[ dup [ 2nip ] [ drop _ insert-peek ] if ] 3map
dup all-equal? [ first ] [ ^^phi ] if ;
-: (merge-locs) ( predecessors assocs -- assoc )
- dup [ keys ] map concat prune
- [ [ 2nip ] [ merge-loc ] 3bi ] with with
- H{ } map>assoc ;
-
-: merge-locs ( state predecessors states -- state )
- [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
+:: merge-locs ( state predecessors states -- state )
+ states [ locs>vregs>> ] map states collect-locs
+ [| key value |
+ key
+ predecessors states value key merge-loc
+ ] assoc-map
+ state translate-locs
+ state (>>locs>vregs)
+ state ;
-: merge-actual-loc ( locs>vregs loc -- vreg )
- '[ [ _ ] dip at ] map
+: merge-actual-loc ( vregs -- vreg/f )
dup all-equal? [ first ] [ drop f ] if ;
-: merge-actual-locs ( state predecessors states -- state )
- nip
- [ actual-locs>vregs>> ] map
- dup [ keys ] map concat prune
- [ [ nip ] [ merge-actual-loc ] 2bi ] with
- H{ } map>assoc
- [ nip ] assoc-filter
+: merge-actual-locs ( state states -- state )
+ [ [ actual-locs>vregs>> ] map ] keep collect-locs
+ [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
+ over translate-locs
>>actual-locs>vregs ;
-: merge-changed-locs ( state predecessors states -- state )
- nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
+: merge-changed-locs ( state states -- state )
+ [ changed-locs>> ] map assoc-combine >>changed-locs ;
ERROR: cannot-merge-poisoned states ;
: multiple-predecessors ( bb states -- state )
dup [ not ] any? [
- [ <state> ] 2dip
- sift merge-heights
+ 2drop <state>
] [
dup [ poisoned?>> ] any? [
cannot-merge-poisoned
[ state new ] 2dip
[ predecessors>> ] dip
{
+ [ merge-ds-heights ]
+ [ merge-rs-heights ]
[ merge-locs ]
- [ merge-actual-locs ]
- [ merge-heights ]
- [ merge-changed-locs ]
+ [ nip merge-actual-locs ]
+ [ nip merge-changed-locs ]
} 2cleave
] if
] if ;
{ 0 [ initial-state ] }
{ 1 [ single-predecessor ] }
[ drop multiple-predecessors ]
- } case ;
\ No newline at end of file
+ } case ;
compiler.cfg.predecessors compiler.cfg.stack-analysis
compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
-compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
+compiler.cfg.checker compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
-sets namespaces ;
+sets namespaces arrays cpu.architecture ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
compute-predecessors
delete-useless-blocks
delete-useless-conditionals
- normalize-height
stack-analysis
dup check-cfg
dup check-for-redundant-ops ;
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
] unit-test
+
+! Correct height tracking
+[ t ] [
+ [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
+ reverse-post-order 2 swap nth
+ instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
+ 2array { D 1 D 0 } set=
+] unit-test
+
+[ D 1 ] [
+ V{ T{ ##branch } } 0 test-bb
+
+ V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
+
+ V{
+ T{ ##peek f V int-regs 1 D 2 }
+ T{ ##inc-d f -1 }
+ T{ ##branch }
+ } 2 test-bb
+
+ V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
+
+ V{ T{ ##return } } 4 test-bb
+
+ test-diamond
+
+ cfg new 0 get >>entry
+ compute-predecessors
+ stack-analysis
+ drop
+
+ 3 get instructions>> second loc>>
+] unit-test
\ No newline at end of file
compiler.cfg.stack-analysis.merge ;
IN: compiler.cfg.stack-analysis
-! Convert stack operations to register operations
-GENERIC: height-for ( loc -- n )
-
-M: ds-loc height-for drop state get ds-height>> ;
-M: rs-loc height-for drop state get rs-height>> ;
-
-: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
-
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
-M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
-
-GENERIC: untranslate-loc ( loc -- loc' )
-
-M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
-M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
-
: redundant-replace? ( vreg loc -- ? )
- dup untranslate-loc n>> 0 <
+ dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
[ changed-locs>> ] [ locs>vregs>> ] bi '[
_ at swap 2dup redundant-replace?
- [ 2drop ] [ untranslate-loc ##replace ] if
+ [ 2drop ] [ state get untranslate-loc ##replace ] if
] assoc-each ;
ERROR: poisoned-state state ;
: sync-state ( -- )
state get {
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+ [ ds-height>> save-ds-height ]
+ [ rs-height>> save-rs-height ]
[ save-changed-locs ]
[ clear-state ]
} cleave ;
! Abstract interpretation
GENERIC: visit ( insn -- )
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
+M: ##inc-d visit
+ n>> state get [ + ] change-ds-height drop ;
-M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ;
-
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
-
-M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
+M: ##inc-r visit
+ n>> state get [ + ] change-rs-height drop ;
! Instructions which don't have any effect on the stack
UNION: neutral-insn
- ##flushable
- ##effect ;
+ ##effect
+ ##flushable ;
M: neutral-insn visit , ;
[ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit
- dup
- [ dst>> ] [ loc>> translate-loc ] bi
- dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+ [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
+ [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
M: ##replace visit
- [ src>> resolve ] [ loc>> translate-loc ] bi
+ [ src>> resolve ] [ loc>> state get translate-loc ] bi
record-replace ;
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
-M: ##call visit
- [ call-next-method ] [ height>> adjust-ds ] bi ;
-
! Instructions that poison the stack state
UNION: poison-insn
##jump
##fixnum-add
##fixnum-sub
##alien-invoke
- ##alien-indirect ;
+ ##alien-indirect
+ ##alien-callback ;
M: kill-vreg-insn visit sync-state , ;
-: visit-alien-node ( node -- )
- params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
-
-M: ##alien-invoke visit
- [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-indirect visit
- [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-callback visit , ;
-
! Maps basic-blocks to states
SYMBOLS: state-in state-out ;
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets math ;
+USING: kernel accessors namespaces assocs sets math
+compiler.cfg.registers ;
IN: compiler.cfg.stack-analysis.state
TUPLE: state
locs>vregs actual-locs>vregs changed-locs
-ds-height rs-height poisoned? ;
+{ ds-height integer }
+{ rs-height integer }
+poisoned? ;
: <state> ( -- state )
state new
dup changed-loc state get locs>vregs>> set-at ;
: clear-state ( state -- )
- [ locs>vregs>> clear-assoc ]
- [ actual-locs>vregs>> clear-assoc ]
- [ changed-locs>> clear-assoc ]
- tri ;
+ 0 >>ds-height 0 >>rs-height
+ [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
+ [ clear-assoc ] tri@ ;
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
+GENERIC# translate-loc 1 ( loc state -- loc' )
+M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
+GENERIC# untranslate-loc 1 ( loc state -- loc' )
+M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
: parse-long-slot-name ( -- spec )
[ scan , \ } parse-until % ] { } make ;
-: parse-slot-name ( string/f -- ? )
+: parse-slot-name-delim ( end-delim string/f -- ? )
#! This isn't meant to enforce any kind of policy, just
#! to check for mistakes of this form:
#!
{
{ [ dup not ] [ unexpected-eof ] }
{ [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
- { [ dup ";" = ] [ drop f ] }
+ { [ 2dup = ] [ drop f ] }
[ dup "{" = [ drop parse-long-slot-name ] when , t ]
- } cond ;
+ } cond nip ;
+
+: parse-tuple-slots-delim ( end-delim -- )
+ dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+
+: parse-slot-name ( string/f -- ? )
+ ";" swap parse-slot-name-delim ;
: parse-tuple-slots ( -- )
- scan parse-slot-name [ parse-tuple-slots ] when ;
+ ";" parse-tuple-slots-delim ;
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
--- /dev/null
+Syntax and combinators for manipulating algebraic data types
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays classes classes.singleton classes.tuple help.markup
+help.syntax kernel multiline slots quotations ;
+IN: variants
+
+HELP: VARIANT:
+{ $syntax <"
+VARIANT: class-name
+ singleton
+ singleton
+ tuple: { slot slot slot ... }
+ .
+ .
+ .
+ ; "> }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots are able to recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $examples { $code <"
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+"> } } ;
+
+HELP: match
+{ $values { "branches" array } }
+{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with an empty stack. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
+{ $examples { $example <"
+USING: kernel math prettyprint variants ;
+IN: scratchpad
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+
+: list-length ( list -- length )
+ {
+ { nil [ 0 ] }
+ { cons [ nip list-length 1 + ] }
+ } match ;
+
+1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
+"> "4" } } ;
+
+HELP: unboa
+{ $values { "class" class } }
+{ $description "Decomposes a tuple of type " { $snippet "class" } " into its component slot values by order of arguments. The inverse of " { $link boa } "." } ;
+
+HELP: variant-class
+{ $class-description "This class comprises class names that have been defined with " { $link POSTPONE: VARIANT: } ". When a " { $snippet "variant-class" } " is used as the type of a specialized " { $link tuple } " slot, the variant's first member type is used as the default " { $link initial-value } "." } ;
+
+{ POSTPONE: VARIANT: variant-class match } related-words
+
+ARTICLE: "variants" "Algebraic data types"
+"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
+{ $subsection POSTPONE: VARIANT: }
+{ $subsection variant-class }
+{ $subsection match } ;
+
+ABOUT: "variants"
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: kernel math tools.test variants ;
+IN: variants.tests
+
+VARIANT: list
+ nil
+ cons: { { first object } { rest list } }
+ ;
+
+[ t ] [ nil list? ] unit-test
+[ t ] [ 1 nil <cons> list? ] unit-test
+[ f ] [ 1 list? ] unit-test
+
+: list-length ( list -- length )
+ {
+ { nil [ 0 ] }
+ { cons [ nip list-length 1 + ] }
+ } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
--- /dev/null
+! (c)2009 Joe Groff 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 ;
+
+M: variant-class initial-value*
+ dup members [ no-initial-value ]
+ [ nip first dup word? [ initial-value* ] unless ] 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 ;
+
+: 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 members -- )
+ [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
+ [ define-variant-member swap add-mixin-instance ] with each ;
+
+: parse-variant-tuple-member ( name -- member )
+ create-class-in tuple
+ "{" expect
+ [ "}" parse-tuple-slots-delim ] { } make
+ 3array ;
+
+: parse-variant-member ( name -- member )
+ ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
+
+: parse-variant-members ( -- members )
+ [ scan dup ";" = not ]
+ [ parse-variant-member ] produce nip ;
+
+SYNTAX: VARIANT:
+ CREATE-CLASS
+ parse-variant-members
+ define-variant-class ;
+
+MACRO: unboa ( class -- )
+ <wrapper> \ boa [ ] 2sequence [undo] ;
+
+GENERIC# (match-branch) 1 ( class quot -- class quot' )
+
+M: singleton-class (match-branch)
+ \ drop prefix ;
+M: object (match-branch)
+ over \ unboa [ ] 2sequence prepend ;
+
+: ?class ( object -- class )
+ dup word? [ class ] unless ;
+
+MACRO: match ( branches -- )
+ [ dup callable? [ first2 (match-branch) 2array ] unless ] map
+ [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
+
projects / factor.git / commitdiff