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!
USING: kernel random namespaces shuffle sequences
parser io math prettyprint combinators
parser io math prettyprint combinators continuations
vectors words quotations accessors math.parser
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 }
expr>>
expr
ast>>
command>>
expansion
utf8 <process-stream>
@ -122,7 +121,7 @@ DEFER: shell
{ [ dup f = ] [ drop ] }
{ [ dup "exit" = ] [ drop ] }
{ [ dup "" = ] [ drop shell ] }
{ [ dup expr ] [ expr ast>> chant shell ] }
{ [ dup expr ] [ expr chant shell ] }
{ [ t ] [ drop "ix: ignoring input" print shell ] }
}
cond ;

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

@ -12,9 +12,9 @@ TUPLE: labelled-gadget < track content ;
: <labelled-gadget> ( gadget title -- newgadget )
{ 0 1 } labelled-gadget new-track
swap <label> reverse-video-theme f track-add*
swap <label> reverse-video-theme f track-add
swap >>content
dup content>> 1 track-add* ;
dup content>> 1 track-add ;
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 )
{ 1 0 } <track>
swap >label f track-add*
swap 1 track-add* ;
swap >label f track-add
swap 1 track-add ;
: label-on-right ( label gadget -- button )
{ 1 0 } <track>
swap f track-add*
swap >label 1 track-add* ;
swap f 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 )
{ 0 1 } slot-editor new-track
swap >>ref
dup <toolbar> f track-add*
dup <toolbar> f track-add
<source-editor> >>text
dup text>> <scroller> 1 track-add*
dup text>> <scroller> 1 track-add
dup revert ;
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 -- )
dup clear-track
swap 1 track-add*
<edit-button> f track-add*
swap 1 track-add
<edit-button> f track-add
drop ;
: update-slot ( editable-slot -- )
@ -109,7 +109,7 @@ TUPLE: editable-slot < track printer ref ;
[ clear-track ]
[
dup ref>> <slot-editor>
[ 1 track-add* drop ]
[ 1 track-add drop ]
[ [ scroll>gadget ] [ request-focus ] bi* ] 2bi
] 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 -- )
f <model> [ <world> ] keep
<status-bar> f track-add*
<status-bar> f track-add
open-world-window ;
: 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 )
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:"
{ $subsection <track> }
"Adding children:"
{ $subsection track-add* } ;
{ $subsection track-add } ;
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> } "." } ;
@ -17,7 +17,7 @@ HELP: <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 }" } "." } ;
HELP: track-add*
HELP: track-add
{ $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." } ;

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

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

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

@ -50,7 +50,7 @@ M: track pref-dim* ( gadget -- dim )
tri
set-axis ;
: track-add* ( track gadget constraint -- track )
: track-add ( track gadget constraint -- track )
pick sizes>> push add-gadget ;
: 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
swap >>status
swap >>title
swap 1 track-add*
swap 1 track-add
dup request-focus ;
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 )
{ 0 1 } browser-gadget new-track
dup init-history
dup <toolbar> f track-add*
dup <toolbar> f track-add
dup <help-pane> >>pane
dup pane>> <scroller> 1 track-add* ;
dup pane>> <scroller> 1 track-add ;
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 )
{ 0 1 } debugger new-track
dup <toolbar> f track-add*
dup <toolbar> f track-add
-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 ;

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

@ -17,9 +17,9 @@ TUPLE: inspector-gadget < track object pane ;
: <inspector-gadget> ( -- gadget )
{ 0 1 } inspector-gadget new-track
dup <toolbar> f track-add*
dup <toolbar> f track-add
<pane> >>pane
dup pane>> <scroller> 1 track-add* ;
dup pane>> <scroller> 1 track-add ;
: inspect-object ( obj mirror keys inspector -- )
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 )
<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 )
[ input>> ] [ output>> <pane-stream> ] bi ;
@ -27,7 +27,7 @@ TUPLE: listener-gadget < track input output stack ;
dup input>>
{ 0 100 } <limited-scroller>
"Input" <labelled-gadget>
f track-add* ;
f track-add ;
: welcome. ( -- )
"If this is your first time with Factor, please read the " print
@ -125,10 +125,10 @@ TUPLE: stack-display < track ;
: <stack-display> ( workspace -- gadget )
listener>>
{ 0 1 } stack-display new-track
over <toolbar> f track-add*
over <toolbar> f track-add
swap
stack>> [ [ stack. ] curry try ] t "Data stack" <labelled-pane>
1 track-add* ;
1 track-add ;
M: stack-display 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 )
{ 0 1 } profiler-gadget new-track
dup <toolbar> f track-add*
dup <toolbar> f track-add
<pane> >>pane
dup pane>> <scroller> 1 track-add* ;
dup pane>> <scroller> 1 track-add ;
: with-profiler-pane ( gadget quot -- )
>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 )
{ 0 1 } live-search new-track
<search-field> >>field
dup field>> f track-add*
dup field>> f track-add
-roll <search-list> >>list
dup list>> <scroller> 1 track-add*
dup list>> <scroller> 1 track-add
swap
over field>> set-editor-string

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

@ -38,10 +38,10 @@ IN: ui.tools
<listener-gadget> >>listener
dup <workspace-book> >>book
dup <workspace-tabs> f track-add*
dup book>> 1/5 track-add*
dup listener>> 4/5 track-add*
dup <toolbar> f track-add* ;
dup <workspace-tabs> f track-add
dup book>> 1/5 track-add
dup listener>> 4/5 track-add
dup <toolbar> f track-add ;
: resize-workspace ( workspace -- )
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>>
{ 1 0 } <track>
over <datastack-display> 1/2 track-add*
swap <retainstack-display> 1/2 track-add*
1/3 track-add*
over <datastack-display> 1/2 track-add
swap <retainstack-display> 1/2 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 )
[ [ continuation-name namestack. ] when* ]

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

@ -62,9 +62,9 @@ M: walker-gadget focusable-child*
swap >>status
dup continuation>> <traceback-gadget> >>traceback
dup <toolbar> f track-add*
dup status>> self <thread-status> f track-add*
dup traceback>> 1 track-add* ;
dup <toolbar> f track-add
dup status>> self <thread-status> f track-add
dup traceback>> 1 track-add ;
: 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 -- )
dup hide-popup
over >>popup
over f track-add* drop
over f track-add drop
request-focus ;
: 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 ]
bi ;
M: true-constraint satisfied?
value>> value-info class>> \ f class-not class<= ;
M: true-constraint satisfied? value>> \ f class-not value-is? ;
M: true-constraint satisfiable?
value>> value-info class>> \ f class-not classes-intersect? ;
M: true-constraint satisfiable? value>> \ f class-not value-is? ;
TUPLE: false-constraint value ;

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

@ -22,7 +22,8 @@ TUPLE: value-info
{ class initial: null }
{ interval initial: empty-interval }
literal
literal? ;
literal?
length ;
: class-interval ( class -- interval )
dup real class<=
@ -45,36 +46,54 @@ literal? ;
} cond
] if ;
: <value-info> ( class interval literal literal? -- info )
[
2nip
[ class ] [ dup real? [ [a,a] ] [ drop [-inf,inf] ] if ] [ ] tri
t
: <value-info> ( -- info ) \ value-info new ;
: init-value-info ( info -- info )
dup literal?>> [
dup literal>> class >>class
dup literal>> dup real? [ [a,a] ] [ drop [-inf,inf] ] if >>interval
] [
drop
2dup [ null class<= ] [ empty-interval eq? ] bi* or [
2drop null empty-interval f f
dup [ class>> null class<= ] [ interval>> empty-interval eq? ] bi or [
null >>class
empty-interval >>interval
] [
over integer class<= [ integral-closure ] when
2dup interval>literal
dup class>> integer class<= [ [ integral-closure ] change-interval ] when
dup [ class>> ] [ interval>> ] bi interval>literal
[ >>literal ] [ >>literal? ] bi*
] if
] if
\ value-info boa ; foldable
] if ;
: <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 )
dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
<class/interval-info> ; foldable
: <interval-info> ( interval -- info )
real swap <class/interval-info> ; foldable
<value-info>
real >>class
swap >>interval
init-value-info ; foldable
: <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? )
{
@ -84,11 +103,24 @@ literal? ;
[ drop >literal< ]
} 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 )
[ [ class>> ] bi@ class-and ]
[ [ interval>> ] bi@ interval-intersect ]
[ intersect-literals ]
2tri <value-info> ;
[ <value-info> ] 2dip
{
[ [ class>> ] bi@ class-and >>class ]
[ [ interval>> ] bi@ interval-intersect >>interval ]
[ intersect-literals [ >>literal ] [ >>literal? ] bi* ]
[ intersect-lengths >>length ]
} 2cleave
init-value-info ;
: value-info-intersect ( info1 info2 -- info )
{
@ -102,11 +134,24 @@ literal? ;
[ literal>> ] bi@ 2dup eql? [ drop t ] [ 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 )
[ [ class>> ] bi@ class-or ]
[ [ interval>> ] bi@ interval-union ]
[ union-literals ]
2tri <value-info> ;
[ <value-info> ] 2dip
{
[ [ class>> ] bi@ class-or >>class ]
[ [ interval>> ] bi@ interval-union >>interval ]
[ union-literals [ >>literal ] [ >>literal? ] bi* ]
[ union-lengths >>length ]
} 2cleave
init-value-info ;
: value-info-union ( info1 info2 -- info )
{
@ -144,3 +189,6 @@ SYMBOL: value-infos
[ { t f } ]
} cond nip
] 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.def-use tools.test math math.order
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
\ propagate must-infer
@ -232,3 +233,9 @@ IN: compiler.tree.propagation.tests
[ V{ 2 } ] [
[ [ 1 ] [ 1 ] if 1 + ] final-literals
] 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.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors kernel sequences assocs words namespaces
classes.algebra combinators classes continuations
USING: fry accessors kernel sequences sequences.private assocs
words namespaces classes.algebra combinators classes
continuations arrays byte-arrays strings
compiler.tree
compiler.tree.def-use
compiler.tree.propagation.info
@ -72,9 +73,29 @@ M: #declare propagate-before
out-d>> length object <class-info> <repetition>
] ?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 )
{
{ [ dup foldable-call? ] [ fold-call ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup length-accessor? ] [ propagate-length ] }
{ [ dup word>> +outputs+ word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;