steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Bruno Deferrari 2008-07-24 21:38:42 -03:00
parent 6f4b5b446b 2bed94df39
commit 4577bee024
25 changed files with 155 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
extra/24-game/24-game.factor
View File

@ -2,7 +2,7 @@
! 24, the Factor game! ! 24, the Factor game!
USING: kernel random namespaces shuffle sequences USING: kernel random namespaces shuffle sequences
parser io math prettyprint combinators parser io math prettyprint combinators continuations
vectors words quotations accessors math.parser vectors words quotations accessors math.parser
backtrack math.ranges locals fry memoize macros assocs ; backtrack math.ranges locals fry memoize macros assocs ;

3
extra/shell/shell.factor
View File

@ -50,7 +50,6 @@ DEFER: expansion
METHOD: expand { back-quoted-expr } METHOD: expand { back-quoted-expr }
expr>> expr>>
expr expr
ast>>
command>> command>>
expansion expansion
utf8 <process-stream> utf8 <process-stream>
@ -122,7 +121,7 @@ DEFER: shell
{ [ dup f = ] [ drop ] } { [ dup f = ] [ drop ] }
{ [ dup "exit" = ] [ drop ] } { [ dup "exit" = ] [ drop ] }
{ [ dup "" = ] [ drop shell ] } { [ dup "" = ] [ drop shell ] }
{ [ dup expr ] [ expr ast>> chant shell ] } { [ dup expr ] [ expr chant shell ] }
{ [ t ] [ drop "ix: ignoring input" print shell ] } { [ t ] [ drop "ix: ignoring input" print shell ] }
} }
cond ; cond ;

4
extra/ui/gadgets/labelled/labelled.factor
View File

@ -12,9 +12,9 @@ TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget ) : <labelled-gadget> ( gadget title -- newgadget )
{ 0 1 } labelled-gadget new-track { 0 1 } labelled-gadget new-track
swap <label> reverse-video-theme f track-add* swap <label> reverse-video-theme f track-add
swap >>content swap >>content
dup content>> 1 track-add* ; dup content>> 1 track-add ;
M: labelled-gadget focusable-child* labelled-gadget-content ; M: labelled-gadget focusable-child* labelled-gadget-content ;

8
extra/ui/gadgets/labels/labels.factor
View File

@ -65,10 +65,10 @@ M: f >label drop <gadget> ;
: label-on-left ( gadget label -- button ) : label-on-left ( gadget label -- button )
{ 1 0 } <track> { 1 0 } <track>
swap >label f track-add* swap >label f track-add
swap 1 track-add* ; swap 1 track-add ;
: label-on-right ( label gadget -- button ) : label-on-right ( label gadget -- button )
{ 1 0 } <track> { 1 0 } <track>
swap f track-add* swap f track-add
swap >label 1 track-add* ; swap >label 1 track-add ;

10
extra/ui/gadgets/slots/slots.factor
View File

@ -71,9 +71,9 @@ M: value-ref finish-editing
: <slot-editor> ( ref -- gadget ) : <slot-editor> ( ref -- gadget )
{ 0 1 } slot-editor new-track { 0 1 } slot-editor new-track
swap >>ref swap >>ref
dup <toolbar> f track-add* dup <toolbar> f track-add
<source-editor> >>text <source-editor> >>text
dup text>> <scroller> 1 track-add* dup text>> <scroller> 1 track-add
dup revert ; dup revert ;
M: slot-editor pref-dim* call-next-method { 600 200 } vmin ; M: slot-editor pref-dim* call-next-method { 600 200 } vmin ;
@ -97,8 +97,8 @@ TUPLE: editable-slot < track printer ref ;
: display-slot ( gadget editable-slot -- ) : display-slot ( gadget editable-slot -- )
dup clear-track dup clear-track
swap 1 track-add* swap 1 track-add
<edit-button> f track-add* <edit-button> f track-add
drop ; drop ;
: update-slot ( editable-slot -- ) : update-slot ( editable-slot -- )
@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
[ clear-track ] [ clear-track ]
[ [
dup ref>> <slot-editor> dup ref>> <slot-editor>
[ 1 track-add* drop ] [ 1 track-add drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi [ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] bi ; ] bi ;

2
extra/ui/gadgets/status-bar/status-bar.factor
View File

@ -12,7 +12,7 @@ IN: ui.gadgets.status-bar
: open-status-window ( gadget title -- ) : open-status-window ( gadget title -- )
f <model> [ <world> ] keep f <model> [ <world> ] keep
<status-bar> f track-add* <status-bar> f track-add
open-world-window ; open-world-window ;
: show-summary ( object gadget -- ) : show-summary ( object gadget -- )

2
extra/ui/gadgets/tiling/tiling.factor
View File

@ -38,7 +38,7 @@ TUPLE: tiling < track gadgets tiles first focused ;
: tiling-map-gadgets ( tiling -- tiling ) : tiling-map-gadgets ( tiling -- tiling )
dup clear-track dup clear-track
dup tiling-gadgets-to-map [ 1 track-add* ] each ; dup tiling-gadgets-to-map [ 1 track-add ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

4
extra/ui/gadgets/tracks/tracks-docs.factor
View File

@ -8,7 +8,7 @@ ARTICLE: "ui-track-layout" "Track layouts"
"Creating empty tracks:" "Creating empty tracks:"
{ $subsection <track> } { $subsection <track> }
"Adding children:" "Adding children:"
{ $subsection track-add* } ; { $subsection track-add } ;
HELP: track HELP: track
{ $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ; { $class-description "A track is like a " { $link pack } " except each child is resized to a fixed multiple of the track's dimension in the direction of " { $link gadget-orientation } ". Tracks are created by calling " { $link <track> } "." } ;
@ -17,7 +17,7 @@ HELP: <track>
{ $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } } { $values { "orientation" "an orientation specifier" } { "track" "a new " { $link track } } }
{ $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ; { $description "Creates a new track which lays out children along the given axis. Children are laid out vertically if the orientation is " { $snippet "{ 0 1 }" } " and horizontally if the orientation is " { $snippet "{ 1 0 }" } "." } ;
HELP: track-add* HELP: track-add
{ $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } } { $values { "gadget" gadget } { "track" track } { "constraint" "a number between 0 and 1, or " { $link f } } }
{ $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ; { $description "Adds a new child to a track. If the constraint is " { $link f } ", the child always occupies its preferred size. Otherwise, the constrant is a fraction of the total size which is allocated for the child." } ;

6
extra/ui/gadgets/tracks/tracks-tests.factor
View File

@ -4,13 +4,13 @@ IN: ui.gadgets.tracks.tests
[ { 100 100 } ] [ [ { 100 100 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 100 100 } >>dim 1 track-add* <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test
[ { 100 110 } ] [ [ { 100 110 } ] [
{ 0 1 } <track> { 0 1 } <track>
<gadget> { 10 10 } >>dim f track-add* <gadget> { 10 10 } >>dim f track-add
<gadget> { 100 100 } >>dim 1 track-add* <gadget> { 100 100 } >>dim 1 track-add
pref-dim pref-dim
] unit-test ] unit-test

2
extra/ui/gadgets/tracks/tracks.factor
View File

@ -50,7 +50,7 @@ M: track pref-dim* ( gadget -- dim )
tri tri
set-axis ; set-axis ;
: track-add* ( track gadget constraint -- track ) : track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ; pick sizes>> push add-gadget ;
: track-remove ( track gadget -- track ) : track-remove ( track gadget -- track )

2
extra/ui/gadgets/worlds/worlds.factor
View File

@ -40,7 +40,7 @@ M: world request-focus-on ( child gadget -- )
{ 0 0 } >>window-loc { 0 0 } >>window-loc
swap >>status swap >>status
swap >>title swap >>title
swap 1 track-add* swap 1 track-add
dup request-focus ; dup request-focus ;
M: world layout* M: world layout*

4
extra/ui/tools/browser/browser.factor
View File

@ -22,9 +22,9 @@ TUPLE: browser-gadget < track pane history ;
: <browser-gadget> ( -- gadget ) : <browser-gadget> ( -- gadget )
{ 0 1 } browser-gadget new-track { 0 1 } browser-gadget new-track
dup init-history dup init-history
dup <toolbar> f track-add* dup <toolbar> f track-add
dup <help-pane> >>pane dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add* ; dup pane>> <scroller> 1 track-add ;
M: browser-gadget call-tool* show-help ; M: browser-gadget call-tool* show-help ;

4
extra/ui/tools/debugger/debugger.factor
View File

@ -25,9 +25,9 @@ TUPLE: debugger < track restarts ;
: <debugger> ( error restarts restart-hook -- gadget ) : <debugger> ( error restarts restart-hook -- gadget )
{ 0 1 } debugger new-track { 0 1 } debugger new-track
dup <toolbar> f track-add* dup <toolbar> f track-add
-rot <restart-list> >>restarts -rot <restart-list> >>restarts
dup restarts>> rot <debugger-display> <scroller> 1 track-add* ; dup restarts>> rot <debugger-display> <scroller> 1 track-add ;
M: debugger focusable-child* debugger-restarts ; M: debugger focusable-child* debugger-restarts ;

4
extra/ui/tools/inspector/inspector.factor
View File

@ -17,9 +17,9 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget ) : <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track { 0 1 } inspector-gadget new-track
dup <toolbar> f track-add* dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add* ; dup pane>> <scroller> 1 track-add ;
: inspect-object ( obj mirror keys inspector -- ) : inspect-object ( obj mirror keys inspector -- )
2nip swap >>object refresh ; 2nip swap >>object refresh ;

8
extra/ui/tools/listener/listener.factor
View File

@ -14,7 +14,7 @@ TUPLE: listener-gadget < track input output stack ;
: listener-output, ( listener -- listener ) : listener-output, ( listener -- listener )
<scrolling-pane> >>output <scrolling-pane> >>output
dup output>> <scroller> "Output" <labelled-gadget> 1 track-add* ; dup output>> <scroller> "Output" <labelled-gadget> 1 track-add ;
: listener-streams ( listener -- input output ) : listener-streams ( listener -- input output )
[ input>> ] [ output>> <pane-stream> ] bi ; [ input>> ] [ output>> <pane-stream> ] bi ;
@ -27,7 +27,7 @@ TUPLE: listener-gadget < track input output stack ;
dup input>> dup input>>
{ 0 100 } <limited-scroller> { 0 100 } <limited-scroller>
"Input" <labelled-gadget> "Input" <labelled-gadget>
f track-add* ; f track-add ;
: welcome. ( -- ) : welcome. ( -- )
"If this is your first time with Factor, please read the " print "If this is your first time with Factor, please read the " print
@ -125,10 +125,10 @@ TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget ) : <stack-display> ( workspace -- gadget )
listener>> listener>>
{ 0 1 } stack-display new-track { 0 1 } stack-display new-track
over <toolbar> f track-add* over <toolbar> f track-add
swap swap
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane> stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add* ; 1 track-add ;
M: stack-display tool-scroller M: stack-display tool-scroller
find-workspace workspace-listener tool-scroller ; find-workspace workspace-listener tool-scroller ;

4
extra/ui/tools/profiler/profiler.factor
View File

@ -9,9 +9,9 @@ TUPLE: profiler-gadget < track pane ;
: <profiler-gadget> ( -- gadget ) : <profiler-gadget> ( -- gadget )
{ 0 1 } profiler-gadget new-track { 0 1 } profiler-gadget new-track
dup <toolbar> f track-add* dup <toolbar> f track-add
<pane> >>pane <pane> >>pane
dup pane>> <scroller> 1 track-add* ; dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- ) : with-profiler-pane ( gadget quot -- )
>r profiler-gadget-pane r> with-pane ; >r profiler-gadget-pane r> with-pane ;

4
extra/ui/tools/search/search.factor
View File

@ -62,9 +62,9 @@ search-field H{
: <live-search> ( string seq limited? presenter -- gadget ) : <live-search> ( string seq limited? presenter -- gadget )
{ 0 1 } live-search new-track { 0 1 } live-search new-track
<search-field> >>field <search-field> >>field
dup field>> f track-add* dup field>> f track-add
-roll <search-list> >>list -roll <search-list> >>list
dup list>> <scroller> 1 track-add* dup list>> <scroller> 1 track-add
swap swap
over field>> set-editor-string over field>> set-editor-string

8
extra/ui/tools/tools.factor
View File

@ -38,10 +38,10 @@ IN: ui.tools
<listener-gadget> >>listener <listener-gadget> >>listener
dup <workspace-book> >>book dup <workspace-book> >>book
dup <workspace-tabs> f track-add* dup <workspace-tabs> f track-add
dup book>> 1/5 track-add* dup book>> 1/5 track-add
dup listener>> 4/5 track-add* dup listener>> 4/5 track-add
dup <toolbar> f track-add* ; dup <toolbar> f track-add ;
: resize-workspace ( workspace -- ) : resize-workspace ( workspace -- )
dup track-sizes over control-value zero? [ dup track-sizes over control-value zero? [

10
extra/ui/tools/traceback/traceback.factor
View File

@ -30,13 +30,13 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup model>> dup model>>
{ 1 0 } <track> { 1 0 } <track>
over <datastack-display> 1/2 track-add* over <datastack-display> 1/2 track-add
swap <retainstack-display> 1/2 track-add* swap <retainstack-display> 1/2 track-add
1/3 track-add* 1/3 track-add
dup model>> <callstack-display> 2/3 track-add* dup model>> <callstack-display> 2/3 track-add
dup <toolbar> f track-add* ; dup <toolbar> f track-add ;
: <namestack-display> ( model -- gadget ) : <namestack-display> ( model -- gadget )
[ [ continuation-name namestack. ] when* ] [ [ continuation-name namestack. ] when* ]

6
extra/ui/tools/walker/walker.factor
View File

@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
swap >>status swap >>status
dup continuation>> <traceback-gadget> >>traceback dup continuation>> <traceback-gadget> >>traceback
dup <toolbar> f track-add* dup <toolbar> f track-add
dup status>> self <thread-status> f track-add* dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add* ; dup traceback>> 1 track-add ;
: walker-help ( -- ) "ui-walker" help-window ; : walker-help ( -- ) "ui-walker" help-window ;

2
extra/ui/tools/workspace/workspace.factor
View File

@ -62,7 +62,7 @@ M: gadget tool-scroller drop f ;
: show-popup ( gadget workspace -- ) : show-popup ( gadget workspace -- )
dup hide-popup dup hide-popup
over >>popup over >>popup
over f track-add* drop over f track-add drop
request-focus ; request-focus ;
: show-titled-popup ( workspace gadget title -- ) : show-titled-popup ( workspace gadget title -- )

6
unfinished/compiler/tree/propagation/constraints/constraints.factor
View File

@ -26,11 +26,9 @@ M: true-constraint assume
[ \ f class-not <class-info> swap value>> refine-value-info ] [ \ f class-not <class-info> swap value>> refine-value-info ]
bi ; bi ;
M: true-constraint satisfied? M: true-constraint satisfied? value>> \ f class-not value-is? ;
value>> value-info class>> \ f class-not class<= ;
M: true-constraint satisfiable? M: true-constraint satisfiable? value>> \ f class-not value-is? ;
value>> value-info class>> \ f class-not classes-intersect? ;
TUPLE: false-constraint value ; TUPLE: false-constraint value ;

98
unfinished/compiler/tree/propagation/info/info.factor
View File

@ -22,7 +22,8 @@ TUPLE: value-info
{ class initial: null } { class initial: null }
{ interval initial: empty-interval } { interval initial: empty-interval }
literal literal
literal? ; literal?
length ;
: class-interval ( class -- interval ) : class-interval ( class -- interval )
dup real class<= dup real class<=
@ -45,36 +46,54 @@ literal? ;
} cond } cond
] if ; ] if ;
: <value-info> ( class interval literal literal? -- info ) : <value-info> ( -- info ) \ value-info new ;
[
2nip : init-value-info ( info -- info )
[ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri dup literal?>> [
t dup literal>> class >>class
dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
] [ ] [
drop dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
2dup [ null class<= ] [ empty-interval eq? ] bi* or [ null >>class
2drop null empty-interval f f empty-interval >>interval
] [ ] [
over integer class<= [ integral-closure ] when dup class>> integer class<= [ [ integral-closure ] change-interval ] when
2dup interval>literal dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
] if ] if
] if ] if ;
\ value-info boa ; foldable
: <class/interval-info> ( class interval -- info ) : <class/interval-info> ( class interval -- info )
f f <value-info> ; foldable <value-info>
swap >>interval
swap >>class
init-value-info ; foldable
: <class-info> ( class -- info ) : <class-info> ( class -- info )
dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
<class/interval-info> ; foldable <class/interval-info> ; foldable
: <interval-info> ( interval -- info ) : <interval-info> ( interval -- info )
real swap <class/interval-info> ; foldable <value-info>
real >>class
swap >>interval
init-value-info ; foldable
: <literal-info> ( literal -- info ) : <literal-info> ( literal -- info )
f f rot t <value-info> ; foldable <value-info>
swap >>literal
t >>literal?
init-value-info ; foldable
: >literal< ( info -- literal literal? ) [ literal>> ] [ literal?>> ] bi ; : <sequence-info> ( value -- info )
<value-info>
object >>class
[-inf,inf] >>interval
swap value-info >>length
init-value-info ; foldable
: >literal< ( info -- literal literal? )
[ literal>> ] [ literal?>> ] bi ;
: intersect-literals ( info1 info2 -- literal literal? ) : intersect-literals ( info1 info2 -- literal literal? )
{ {
@ -84,11 +103,24 @@ literal? ;
[ drop >literal< ] [ drop >literal< ]
} cond ; } cond ;
DEFER: value-info-intersect
: intersect-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ drop ] }
{ [ over not ] [ nip ] }
[ value-info-intersect ]
} cond ;
: (value-info-intersect) ( info1 info2 -- info ) : (value-info-intersect) ( info1 info2 -- info )
[ [ class>> ] bi@ class-and ] [ <value-info> ] 2dip
[ [ interval>> ] bi@ interval-intersect ] {
[ intersect-literals ] [ [ class>> ] bi@ class-and >>class ]
2tri <value-info> ; [ [ interval>> ] bi@ interval-intersect >>interval ]
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
[ intersect-lengths >>length ]
} 2cleave
init-value-info ;
: value-info-intersect ( info1 info2 -- info ) : value-info-intersect ( info1 info2 -- info )
{ {
@ -102,11 +134,24 @@ literal? ;
[ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if [ literal>> ] bi@ 2dup eql? [ drop t ] [ 2drop f f ] if
] [ 2drop f f ] if ; ] [ 2drop f f ] if ;
DEFER: value-info-union
: union-lengths ( info1 info2 -- length )
[ length>> ] bi@ {
{ [ dup not ] [ nip ] }
{ [ over not ] [ drop ] }
[ value-info-union ]
} cond ;
: (value-info-union) ( info1 info2 -- info ) : (value-info-union) ( info1 info2 -- info )
[ [ class>> ] bi@ class-or ] [ <value-info> ] 2dip
[ [ interval>> ] bi@ interval-union ] {
[ union-literals ] [ [ class>> ] bi@ class-or >>class ]
2tri <value-info> ; [ [ interval>> ] bi@ interval-union >>interval ]
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
[ union-lengths >>length ]
} 2cleave
init-value-info ;
: value-info-union ( info1 info2 -- info ) : value-info-union ( info1 info2 -- info )
{ {
@ -144,3 +189,6 @@ SYMBOL: value-infos
[ { t f } ] [ { t f } ]
} cond nip } cond nip
] if ; ] if ;
: value-is? ( value class -- ? )
[ value-info class>> ] dip class<= ;

9
unfinished/compiler/tree/propagation/propagation-tests.factor
View File

@ -2,7 +2,8 @@ USING: kernel compiler.tree.builder compiler.tree
compiler.tree.propagation compiler.tree.copy-equiv compiler.tree.propagation compiler.tree.copy-equiv
compiler.tree.def-use tools.test math math.order compiler.tree.def-use tools.test math math.order
accessors sequences arrays kernel.private vectors accessors sequences arrays kernel.private vectors
alien.accessors alien.c-types sequences.private ; alien.accessors alien.c-types sequences.private
byte-arrays ;
IN: compiler.tree.propagation.tests IN: compiler.tree.propagation.tests
\ propagate must-infer \ propagate must-infer
@ -232,3 +233,9 @@ IN: compiler.tree.propagation.tests
[ V{ 2 } ] [ [ V{ 2 } ] [
[ [ 1 ] [ 1 ] if 1 + ] final-literals [ [ 1 ] [ 1 ] if 1 + ] final-literals
] unit-test ] unit-test
[ V{ t } ] [ [ 10 f <array> length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 10 f <array> ] [ 10 <byte-array> ] if length 10 = ] final-literals ] unit-test
[ V{ t } ] [ [ [ 1 f <array> ] [ 2 f <array> ] if length 3 < ] final-literals ] unit-test

25
unfinished/compiler/tree/propagation/simple/simple.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences assocs words namespaces USING: fry accessors kernel sequences sequences.private assocs
classes.algebra combinators classes continuations words namespaces classes.algebra combinators classes
continuations arrays byte-arrays strings
compiler.tree compiler.tree
compiler.tree.def-use compiler.tree.def-use
compiler.tree.propagation.info compiler.tree.propagation.info
@ -72,9 +73,29 @@ M: #declare propagate-before
out-d>> length object <class-info> <repetition> out-d>> length object <class-info> <repetition>
] ?if ; ] ?if ;
UNION: fixed-length-sequence array byte-array string ;
: sequence-constructor? ( node -- ? )
word>> { <array> <byte-array> <string> } memq? ;
: propagate-sequence-constructor ( node -- infos )
[ default-output-value-infos first ]
[ in-d>> first <sequence-info> ]
bi value-info-intersect 1array ;
: length-accessor? ( node -- ? )
dup in-d>> first fixed-length-sequence value-is?
[ word>> \ length eq? ] [ drop f ] if ;
: propagate-length ( node -- infos )
in-d>> first value-info length>>
[ array-capacity <class-info> ] unless* 1array ;
: output-value-infos ( node -- infos ) : output-value-infos ( node -- infos )
{ {
{ [ dup foldable-call? ] [ fold-call ] } { [ dup foldable-call? ] [ fold-call ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup length-accessor? ] [ propagate-length ] }
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] } { [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ] [ default-output-value-infos ]
} cond ; } cond ;