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

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

db4
Doug Coleman 2008-07-13 10:48:00 -05:00
parent ca3e39714d 543ad02658
commit 92a186d4c4
19 changed files with 64 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
extra/automata/ui/ui.factor
View File

@ -23,11 +23,8 @@ IN: automata.ui
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
QUALIFIED: ui.gadgets
QUALIFIED: ui.gadgets.grids QUALIFIED: ui.gadgets.grids
: add-gadget ( parent child -- parent ) over ui.gadgets:add-gadget ;
: grid-add ( grid child i j -- grid ) : grid-add ( grid child i j -- grid )
>r >r dupd swap r> r> ui.gadgets.grids:grid-add ; >r >r dupd swap r> r> ui.gadgets.grids:grid-add ;

24
extra/boids/ui/ui.factor
View File

@ -120,24 +120,24 @@ VARS: population-label cohesion-label alignment-label separation-label ;
[ "1 - Randomize" [ drop randomize ] button* ] [ "1 - Randomize" [ drop randomize ] button* ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
population-label> over add-gadget population-label> add-gadget
"3 - Add 10" [ drop add-10-boids ] button* over add-gadget "3 - Add 10" [ drop add-10-boids ] button* add-gadget
"2 - Sub 10" [ drop sub-10-boids ] button* over add-gadget ] "2 - Sub 10" [ drop sub-10-boids ] button* add-gadget ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
cohesion-label> over add-gadget cohesion-label> add-gadget
"q - +0.1" [ drop inc-cohesion-weight ] button* over add-gadget "q - +0.1" [ drop inc-cohesion-weight ] button* add-gadget
"a - -0.1" [ drop dec-cohesion-weight ] button* over add-gadget ] "a - -0.1" [ drop dec-cohesion-weight ] button* add-gadget ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
alignment-label> over add-gadget alignment-label> add-gadget
"w - +0.1" [ drop inc-alignment-weight ] button* over add-gadget "w - +0.1" [ drop inc-alignment-weight ] button* add-gadget
"s - -0.1" [ drop dec-alignment-weight ] button* over add-gadget ] "s - -0.1" [ drop dec-alignment-weight ] button* add-gadget ]
[ <pile> 1 over set-pack-fill [ <pile> 1 over set-pack-fill
separation-label> over add-gadget separation-label> add-gadget
"e - +0.1" [ drop inc-separation-weight ] button* over add-gadget "e - +0.1" [ drop inc-separation-weight ] button* add-gadget
"d - -0.1" [ drop dec-separation-weight ] button* over add-gadget ] "d - -0.1" [ drop dec-separation-weight ] button* add-gadget ]
} [ call ] map [ [ gadget, ] each ] make-shelf } [ call ] map [ [ gadget, ] each ] make-shelf
1 over set-pack-fill 1 over set-pack-fill

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

@ -19,7 +19,7 @@ M: book model-changed
: new-book ( pages model class -- book ) : new-book ( pages model class -- book )
new-gadget new-gadget
swap >>model swap >>model
[ add-gadgets ] keep ; inline [ swap add-gadgets drop ] keep ; inline
: <book> ( pages model -- book ) : <book> ( pages model -- book )
book new-book ; book new-book ;

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

@ -10,7 +10,7 @@ TUPLE: border < gadget
{ align initial: { 1/2 1/2 } } ; { align initial: { 1/2 1/2 } } ;
: new-border ( child class -- border ) : new-border ( child class -- border )
new-gadget [ add-gadget ] keep ; inline new-gadget [ swap add-gadget drop ] keep ; inline
: <border> ( child gap -- border ) : <border> ( child gap -- border )
swap border new-border swap border new-border

16
extra/ui/gadgets/gadgets-tests.factor
View File

@ -9,9 +9,9 @@ io.streams.string math.geometry.rect ;
! c contains b contains a ! c contains b contains a
<gadget> "a" set <gadget> "a" set
<gadget> "b" set <gadget> "b" set
"a" get "b" get add-gadget "a" get "b" get swap add-gadget drop
<gadget> "c" set <gadget> "c" set
"b" get "c" get add-gadget "b" get "c" get swap add-gadget drop
! position a and b ! position a and b
{ 100 200 } "a" get set-rect-loc { 100 200 } "a" get set-rect-loc
@ -33,8 +33,8 @@ io.streams.string math.geometry.rect ;
<gadget> "g3" set <gadget> "g3" set
{ 100 200 } "g3" get set-rect-dim { 100 200 } "g3" get set-rect-dim
"g1" get "g2" get add-gadget "g1" get "g2" get swap add-gadget drop
"g2" get "g3" get add-gadget "g2" get "g3" get swap add-gadget drop
[ { 30 30 } ] [ "g1" get screen-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-loc ] unit-test
[ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test [ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
@ -49,11 +49,11 @@ io.streams.string math.geometry.rect ;
<gadget> "g1" set <gadget> "g1" set
{ 300 300 } "g1" get set-rect-dim { 300 300 } "g1" get set-rect-dim
<gadget> "g2" set <gadget> "g2" set
"g2" get "g1" get add-gadget "g2" get "g1" get swap add-gadget drop
{ 20 20 } "g2" get set-rect-loc { 20 20 } "g2" get set-rect-loc
{ 20 20 } "g2" get set-rect-dim { 20 20 } "g2" get set-rect-dim
<gadget> "g3" set <gadget> "g3" set
"g3" get "g1" get add-gadget "g3" get "g1" get swap add-gadget drop
{ 100 100 } "g3" get set-rect-loc { 100 100 } "g3" get set-rect-loc
{ 20 20 } "g3" get set-rect-dim { 20 20 } "g3" get set-rect-dim
@ -66,7 +66,7 @@ io.streams.string math.geometry.rect ;
[ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
<gadget> "g4" set <gadget> "g4" set
"g4" get "g2" get add-gadget "g4" get "g2" get swap add-gadget drop
{ 5 5 } "g4" get set-rect-loc { 5 5 } "g4" get set-rect-loc
{ 1 1 } "g4" get set-rect-dim { 1 1 } "g4" get set-rect-dim
@ -123,7 +123,7 @@ M: mock-gadget ungraft*
: add-some-children : add-some-children
3 [ 3 [
<mock-gadget> over <model> over set-gadget-model <mock-gadget> over <model> over set-gadget-model
dup "g" get add-gadget dup "g" get swap add-gadget drop
swap 1+ number>string set swap 1+ number>string set
] each ; ] each ;

31
extra/ui/gadgets/gadgets.factor
View File

@ -285,22 +285,27 @@ SYMBOL: in-layout?
not-in-layout not-in-layout
dup (clear-gadget) relayout ; dup (clear-gadget) relayout ;
: ((add-gadget)) ( gadget box -- ) : ((add-gadget)) ( parent child -- parent )
[ children>> ?push ] keep (>>children) ; over children>> ?push >>children ;
: (add-gadget) ( gadget box -- ) : (add-gadget) ( parent child -- parent )
over unparent dup unparent
dup pick (>>parent) over >>parent
[ ((add-gadget)) ] 2keep tuck ((add-gadget))
graft-state>> second [ graft ] [ drop ] if ; tuck graft-state>> second
[ graft ]
[ drop ]
if ;
: add-gadget ( gadget parent -- ) : add-gadget ( parent child -- parent )
not-in-layout not-in-layout
[ (add-gadget) ] keep relayout ; (add-gadget)
dup relayout ;
: add-gadgets ( seq parent -- )
: add-gadgets ( parent children -- parent )
not-in-layout not-in-layout
swap [ over (add-gadget) ] each relayout ; [ (add-gadget) ] each
dup relayout ;
: parents ( gadget -- seq ) : parents ( gadget -- seq )
[ parent>> ] follow ; [ parent>> ] follow ;
@ -352,7 +357,7 @@ M: f request-focus-on 2drop ;
: focus-path ( world -- seq ) : focus-path ( world -- seq )
[ focus>> ] follow ; [ focus>> ] follow ;
: gadget, ( gadget -- ) gadget get add-gadget ; : gadget, ( gadget -- ) gadget get swap add-gadget drop ;
: g ( -- gadget ) gadget get ; : g ( -- gadget ) gadget get ;

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

@ -12,7 +12,7 @@ grid
: new-grid ( children class -- grid ) : new-grid ( children class -- grid )
new-gadget new-gadget
[ (>>grid) ] [ >r concat r> add-gadgets ] [ nip ] 2tri ; [ (>>grid) ] [ >r concat r> swap add-gadgets drop ] [ nip ] 2tri ;
inline inline
: <grid> ( children -- grid ) : <grid> ( children -- grid )
@ -21,7 +21,7 @@ grid
: grid-child ( grid i j -- gadget ) rot grid>> nth nth ; : grid-child ( grid i j -- gadget ) rot grid>> nth nth ;
: grid-add ( gadget grid i j -- ) : grid-add ( gadget grid i j -- )
>r >r 2dup add-gadget r> r> >r >r 2dup swap add-gadget drop r> r>
3dup grid-child unparent rot grid>> nth set-nth ; 3dup grid-child unparent rot grid>> nth set-nth ;
: grid-remove ( grid i j -- ) : grid-remove ( grid i j -- )

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

@ -45,7 +45,7 @@ M: incremental pref-dim*
: add-incremental ( gadget incremental -- ) : add-incremental ( gadget incremental -- )
not-in-layout not-in-layout
2dup (add-gadget) 2dup swap (add-gadget) drop
over prefer-incremental over prefer-incremental
over layout-later over layout-later
2dup incremental-loc 2dup incremental-loc

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

@ -48,7 +48,7 @@ TUPLE: list < pack index presenter color hook ;
M: list model-changed M: list model-changed
nip nip
dup clear-gadget dup clear-gadget
dup <list-items> over add-gadgets dup <list-items> over swap add-gadgets drop
bound-index ; bound-index ;
: selected-rect ( list -- rect ) : selected-rect ( list -- rect )

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

@ -15,7 +15,7 @@ TUPLE: menu-glass < gadget ;
: <menu-glass> ( menu world -- glass ) : <menu-glass> ( menu world -- glass )
menu-glass new-gadget menu-glass new-gadget
>r over menu-loc over set-rect-loc r> >r over menu-loc over set-rect-loc r>
[ add-gadget ] keep ; [ swap add-gadget drop ] keep ;
M: menu-glass layout* gadget-child prefer ; M: menu-glass layout* gadget-child prefer ;
@ -26,7 +26,7 @@ M: menu-glass layout* gadget-child prefer ;
: show-glass ( gadget world -- ) : show-glass ( gadget world -- )
over hand-clicked set-global over hand-clicked set-global
[ hide-glass ] keep [ hide-glass ] keep
[ add-gadget ] 2keep [ swap add-gadget drop ] 2keep
set-world-glass ; set-world-glass ;
: show-menu ( gadget owner -- ) : show-menu ( gadget owner -- )

12
extra/ui/gadgets/panes/panes.factor
View File

@ -22,10 +22,10 @@ selection-color caret mark selecting? ;
drop ; drop ;
: add-output ( current pane -- ) : add-output ( current pane -- )
[ set-pane-output ] [ add-gadget ] 2bi ; [ set-pane-output ] [ swap add-gadget drop ] 2bi ;
: add-current ( current pane -- ) : add-current ( current pane -- )
[ set-pane-current ] [ add-gadget ] 2bi ; [ set-pane-current ] [ swap add-gadget drop ] 2bi ;
: prepare-line ( pane -- ) : prepare-line ( pane -- )
[ clear-selection ] [ clear-selection ]
@ -120,7 +120,7 @@ C: <pane-stream> pane-stream
GENERIC: write-gadget ( gadget stream -- ) GENERIC: write-gadget ( gadget stream -- )
M: pane-stream write-gadget M: pane-stream write-gadget
pane-stream-pane pane-current add-gadget ; pane-stream-pane pane-current swap add-gadget drop ;
M: style-stream write-gadget M: style-stream write-gadget
stream>> write-gadget ; stream>> write-gadget ;
@ -299,12 +299,12 @@ M: paragraph dispose drop ;
: gadget-write ( string gadget -- ) : gadget-write ( string gadget -- )
over empty? over empty?
[ 2drop ] [ >r <label> text-theme r> add-gadget ] if ; [ 2drop ] [ >r <label> text-theme r> swap add-gadget drop ] if ;
M: pack stream-write gadget-write ; M: pack stream-write gadget-write ;
: gadget-bl ( style stream -- ) : gadget-bl ( style stream -- )
>r " " <word-break-gadget> style-label r> add-gadget ; >r " " <word-break-gadget> style-label r> swap add-gadget drop ;
M: paragraph stream-write M: paragraph stream-write
swap " " split swap " " split
@ -322,7 +322,7 @@ M: paragraph stream-write1
: gadget-format ( string style stream -- ) : gadget-format ( string style stream -- )
pick empty? pick empty?
[ 3drop ] [ >r swap <styled-label> r> add-gadget ] if ; [ 3drop ] [ >r swap <styled-label> r> swap add-gadget drop ] if ;
M: pack stream-format M: pack stream-format
gadget-format ; gadget-format ;

2
extra/ui/gadgets/scrollers/scrollers-tests.factor
View File

@ -61,7 +61,7 @@ tools.test.ui math.geometry.rect ;
<gadget> { 600 400 } over set-rect-dim "g1" set <gadget> { 600 400 } over set-rect-dim "g1" set
<gadget> { 600 10 } over set-rect-dim "g2" set <gadget> { 600 10 } over set-rect-dim "g2" set
"g2" get "g1" get add-gadget "g2" get "g1" get swap add-gadget drop
"g1" get <scroller> "g1" get <scroller>
{ 300 300 } over set-rect-dim { 300 300 } over set-rect-dim

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

@ -140,7 +140,7 @@ M: elevator layout*
: elevator, ( orientation -- ) : elevator, ( orientation -- )
dup <elevator> g-> set-slider-elevator dup <elevator> g-> set-slider-elevator
swap <thumb> g-> set-slider-thumb over add-gadget swap <thumb> g-> set-slider-thumb add-gadget
@center frame, ; @center frame, ;
: <left-button> ( -- button ) : <left-button> ( -- button )

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

@ -16,7 +16,7 @@ DEFER: (del-page)
[ [ gadget-parent '[ , , , (del-page) ] "X" swap [ [ gadget-parent '[ , , , (del-page) ] "X" swap
<bevel-button> @right frame, ] 3keep <bevel-button> @right frame, ] 3keep
[ swapd <toggle-button> @center frame, ] dip ] make-frame [ swapd <toggle-button> @center frame, ] dip ] make-frame
swap add-gadget ; add-gadget drop ;
: redo-toggler ( tabbed -- ) : redo-toggler ( tabbed -- )
[ names>> ] [ model>> ] [ toggler>> ] tri [ names>> ] [ model>> ] [ toggler>> ] tri
@ -41,7 +41,7 @@ DEFER: (del-page)
[ [ model>> swap ] [ [ model>> swap ]
[ names>> length 1 - swap ] [ names>> length 1 - swap ]
[ toggler>> ] tri add-toggle ] [ toggler>> ] tri add-toggle ]
[ content>> add-gadget ] [ content>> swap add-gadget drop ]
[ refresh-book ] tri ; [ refresh-book ] tri ;
: del-page ( name tabbed -- ) : del-page ( name tabbed -- )

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

@ -47,7 +47,7 @@ M: track pref-dim*
rot gadget-orientation set-axis ; rot gadget-orientation set-axis ;
: track-add ( gadget track constraint -- ) : track-add ( gadget track constraint -- )
over track-sizes push add-gadget ; over track-sizes push swap add-gadget drop ;
: track, ( gadget constraint -- ) : track, ( gadget constraint -- )
gadget get swap track-add ; gadget get swap track-add ;

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

@ -18,7 +18,7 @@ TUPLE: viewport < gadget ;
viewport new-gadget viewport new-gadget
swap >>model swap >>model
t >>clipped? t >>clipped?
[ add-gadget ] keep ; [ swap add-gadget drop ] keep ;
M: viewport layout* M: viewport layout*
dup rect-dim viewport-gap 2 v*n v- dup rect-dim viewport-gap 2 v*n v-

8
extra/ui/gadgets/worlds/worlds-tests.factor
View File

@ -18,7 +18,7 @@ namespaces models kernel ;
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
"g1" get "g2" get add-gadget "g1" get "g2" get swap add-gadget drop
[ ] [ [ ] [
"g2" get <test-world> "w" set "g2" get <test-world> "w" set
@ -33,8 +33,8 @@ namespaces models kernel ;
<gadget> "g1" set <gadget> "g1" set
<gadget> "g2" set <gadget> "g2" set
<gadget> "g3" set <gadget> "g3" set
"g1" get "g3" get add-gadget "g1" get "g3" get swap add-gadget drop
"g2" get "g3" get add-gadget "g2" get "g3" get swap add-gadget drop
[ ] [ [ ] [
"g3" get <test-world> "w" set "g3" get <test-world> "w" set
@ -55,7 +55,7 @@ TUPLE: focus-test < gadget ;
: <focus-test> : <focus-test>
focus-test new-gadget focus-test new-gadget
<focusing> over add-gadget ; <focusing> over swap add-gadget drop ;
M: focus-test focusable-child* gadget-child ; M: focus-test focusable-child* gadget-child ;

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

@ -7,7 +7,7 @@ TUPLE: wrapper < gadget ;
: new-wrapper ( child class -- wrapper ) : new-wrapper ( child class -- wrapper )
new-gadget new-gadget
[ add-gadget ] keep ; inline [ swap add-gadget drop ] keep ; inline
: <wrapper> ( child -- border ) : <wrapper> ( child -- border )
wrapper new-wrapper ; wrapper new-wrapper ;

2
vm/quotations.c
View File

@ -386,7 +386,7 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset)
break; break;
} }
default: default:
COUNT(userenv[JIT_PUSH_LITERAL],i) COUNT(userenv[immediate_p(obj) ? JIT_PUSH_IMMEDIATE : JIT_PUSH_LITERAL],i)
break; break;
} }
} }