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

Clean up some usages of tuck, and add Joe's curried cleave/spread/apply combinators to kernel vocabulary

db4
Slava Pestov 2009-02-02 13:43:54 -06:00
parent 6cd835e567
commit 669548e62e
45 changed files with 187 additions and 147 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -70,7 +70,7 @@ IN: compiler.cfg.intrinsics.fixnum
ds-push ; ds-push ;
: emit-fixnum-comparison ( node cc -- ) : emit-fixnum-comparison ( node cc -- )
[ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi [ ^^compare ] [ ^^compare-imm ] bi-curry
emit-fixnum-op ; emit-fixnum-op ;
: emit-bignum>fixnum ( -- ) : emit-bignum>fixnum ( -- )

9
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -28,15 +28,14 @@ IN: compiler.cfg.intrinsics.slots
] [ drop emit-primitive ] if ; ] [ drop emit-primitive ] if ;
: (emit-set-slot) ( infos -- obj-reg ) : (emit-set-slot) ( infos -- obj-reg )
[ 3inputs [ tuck ] dip ^^offset>slot ] [ 3inputs ^^offset>slot ] [ second value-tag ] bi*
[ second value-tag ] pick [ ^^set-slot ] dip ;
bi* ^^set-slot ;
: (emit-set-slot-imm) ( infos -- obj-reg ) : (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop ds-drop
[ 2inputs tuck ] [ 2inputs ]
[ [ third literal>> ] [ second value-tag ] bi ] bi* [ [ third literal>> ] [ second value-tag ] bi ] bi*
##set-slot-imm ; pick [ ##set-slot-imm ] dip ;
: emit-set-slot ( node -- ) : emit-set-slot ( node -- )
dup node-input-infos dup node-input-infos

2
basis/compiler/cfg/linear-scan/allocation/allocation.factor
View File

@ -105,7 +105,7 @@ SYMBOL: spill-counts
#! If it has been spilled already, reuse spill location. #! If it has been spilled already, reuse spill location.
over reload-from>> over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless* [ over vreg>> reg-class>> next-spill-location ] unless*
tuck [ >>spill-to ] [ >>reload-from ] 2bi* ; [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after ) : split-and-spill ( new existing -- before after )
dup rot start>> split-interval dup rot start>> split-interval

2
basis/compiler/tree/dead-code/simple/simple.factor
View File

@ -76,7 +76,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
] ; ] ;
: drop-dead-outputs ( node -- #shuffle ) : drop-dead-outputs ( node -- #shuffle )
dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ; dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
: some-outputs-dead? ( #call -- ? ) : some-outputs-dead? ( #call -- ? )
out-d>> [ live-value? not ] any? ; out-d>> [ live-value? not ] any? ;

7
basis/documents/documents.factor
View File

@ -64,10 +64,9 @@ TUPLE: document < model locs undos redos inside-undo? ;
] if ; inline ] if ; inline
: start/end-on-line ( from to line# -- n1 n2 ) : start/end-on-line ( from to line# -- n1 n2 )
tuck
[ [ document get ] 2dip start-on-line ] [ [ document get ] 2dip start-on-line ]
[ [ document get ] 2dip end-on-line ] [ [ document get ] 2dip end-on-line ]
2bi* ; bi-curry bi* ;
: last-line# ( document -- line ) : last-line# ( document -- line )
value>> length 1- ; value>> length 1- ;
@ -101,7 +100,7 @@ CONSTANT: doc-start { 0 0 }
[ first2 swap ] dip nth swap ; [ first2 swap ] dip nth swap ;
: prepare-insert ( new-lines from to lines -- new-lines ) : prepare-insert ( new-lines from to lines -- new-lines )
tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi* [ loc-col/str head-slice ] [ loc-col/str tail-slice ] bi-curry bi*
pick append-last over prepend-first ; pick append-last over prepend-first ;
: (set-doc-range) ( doc-lines from to lines -- changed-lines ) : (set-doc-range) ( doc-lines from to lines -- changed-lines )
@ -162,7 +161,7 @@ PRIVATE>
over first 0 < [ over first 0 < [
2drop { 0 0 } 2drop { 0 0 }
] [ ] [
[ first2 swap tuck ] dip validate-col 2array [ first2 over ] dip validate-col 2array
] if ] if
] if ; ] if ;

4
basis/heaps/heaps.factor
View File

@ -82,8 +82,8 @@ M: heap heap-size ( heap -- n )
data>> first ; inline data>> first ; inline
: data-exchange ( m n heap -- ) : data-exchange ( m n heap -- )
[ tuck data-nth [ data-nth ] dip ] 3keep [ [ data-nth ] curry bi@ ]
tuck [ data-set-nth ] 2dip data-set-nth ; inline [ [ data-set-nth ] curry bi@ ] 3bi ; inline
GENERIC: heap-compare ( pair1 pair2 heap -- ? ) GENERIC: heap-compare ( pair1 pair2 heap -- ? )

4
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -26,8 +26,8 @@ tags global [ H{ } clone or ] change-at
XML-NS: chloe-name http://factorcode.org/chloe/1.0 XML-NS: chloe-name http://factorcode.org/chloe/1.0
: required-attr ( tag name -- value ) : required-attr ( tag name -- value )
tuck chloe-name attr [ nip ] [ chloe-name attr ] 2bi
[ nip ] [ " attribute is required" append throw ] if* ; [ ] [ " attribute is required" append throw ] ?if ;
: optional-attr ( tag name -- value ) : optional-attr ( tag name -- value )
chloe-name attr ; chloe-name attr ;

2
basis/io/streams/duplex/duplex.factor
View File

@ -27,7 +27,7 @@ M: duplex-stream dispose
] with-destructors ; ] with-destructors ;
: <encoder-duplex> ( stream-in stream-out encoding -- duplex ) : <encoder-duplex> ( stream-in stream-out encoding -- duplex )
tuck [ re-decode ] [ re-encode ] 2bi* <duplex-stream> ; [ re-decode ] [ re-encode ] bi-curry bi* <duplex-stream> ;
: with-stream* ( stream quot -- ) : with-stream* ( stream quot -- )
[ [ in>> ] [ out>> ] bi ] dip with-streams* ; inline [ [ in>> ] [ out>> ] bi ] dip with-streams* ; inline

2
basis/math/complex/complex.factor
View File

@ -38,7 +38,7 @@ M: complex * [ *re - ] [ *im + ] 2bi (rect>) ;
: complex/ ( x y -- r i m ) : complex/ ( x y -- r i m )
[ [ *re + ] [ *im - ] 2bi ] keep absq ; inline [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline
M: complex / complex/ tuck [ / ] 2bi@ (rect>) ; M: complex / complex/ [ / ] curry bi@ (rect>) ;
M: complex abs absq >float fsqrt ; M: complex abs absq >float fsqrt ;

2
basis/math/functions/functions.factor
View File

@ -53,7 +53,7 @@ M: integer ^n
[ factor-2s ] dip [ (^n) ] keep rot * shift ; [ factor-2s ] dip [ (^n) ] keep rot * shift ;
M: ratio ^n M: ratio ^n
[ >fraction ] dip tuck [ ^n ] 2bi@ / ; [ >fraction ] dip [ ^n ] curry bi@ / ;
M: float ^n M: float ^n
(^n) ; (^n) ;

4
basis/math/partial-dispatch/partial-dispatch.factor
View File

@ -104,10 +104,10 @@ M: word integer-op-input-classes
: define-integer-ops ( word fix-word big-word -- ) : define-integer-ops ( word fix-word big-word -- )
[ [
rot tuck rot
[ fixnum fixnum 3array "derived-from" set-word-prop ] [ fixnum fixnum 3array "derived-from" set-word-prop ]
[ bignum bignum 3array "derived-from" set-word-prop ] [ bignum bignum 3array "derived-from" set-word-prop ]
2bi* bi-curry bi*
] [ ] [
[ integer-op-triples ] 2dip [ integer-op-triples ] 2dip
[ define-integer-op-words ] [ define-integer-op-words ]

2
basis/math/ratios/ratios.factor
View File

@ -24,7 +24,7 @@ M: integer /
"Division by zero" throw "Division by zero" throw
] [ ] [
dup 0 < [ [ neg ] bi@ ] when dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck [ /i ] 2bi@ fraction> 2dup gcd nip [ /i ] curry bi@ fraction>
] if ; ] if ;
M: ratio hashcode* M: ratio hashcode*

2
basis/math/statistics/statistics.factor
View File

@ -22,7 +22,7 @@ IN: math.statistics
: minmax ( seq -- min max ) : minmax ( seq -- min max )
#! find the min and max of a seq in one pass #! find the min and max of a seq in one pass
[ 1/0. -1/0. ] dip [ tuck [ min ] [ max ] 2bi* ] each ; [ 1/0. -1/0. ] dip [ [ min ] [ max ] bi-curry bi* ] each ;
: range ( seq -- n ) : range ( seq -- n )
minmax swap - ; minmax swap - ;

4
basis/random/random.factor
View File

@ -15,12 +15,12 @@ GENERIC: random-32* ( tuple -- r )
GENERIC: random-bytes* ( n tuple -- byte-array ) GENERIC: random-bytes* ( n tuple -- byte-array )
M: object random-bytes* ( n tuple -- byte-array ) M: object random-bytes* ( n tuple -- byte-array )
[ [ <byte-vector> ] keep 4 /mod ] dip tuck [ [ <byte-vector> ] keep 4 /mod ] dip
[ pick '[ _ random-32* 4 >le _ push-all ] times ] [ pick '[ _ random-32* 4 >le _ push-all ] times ]
[ [
over zero? over zero?
[ 2drop ] [ random-32* 4 >le swap head over push-all ] if [ 2drop ] [ random-32* 4 >le swap head over push-all ] if
] 2bi* ; ] bi-curry bi* ;
M: object random-32* ( tuple -- r ) 4 random-bytes* le> ; M: object random-32* ( tuple -- r ) 4 random-bytes* le> ;

5
basis/tools/completion/completion.factor
View File

@ -65,9 +65,8 @@ IN: tools.completion
[ second >lower swap complete ] keep 2array ; [ second >lower swap complete ] keep 2array ;
: completions ( short candidates -- seq ) : completions ( short candidates -- seq )
[ '[ _ ] ] [ ] [ [ >lower ] dip [ completion ] with map rank-completions ]
[ '[ >lower _ [ completion ] with map rank-completions ] ] bi bi-curry if-empty ;
if-empty ;
: name-completions ( str seq -- seq' ) : name-completions ( str seq -- seq' )
[ dup name>> ] { } map>assoc completions ; [ dup name>> ] { } map>assoc completions ;

3
basis/tools/memory/memory.factor
View File

@ -52,9 +52,8 @@ IN: tools.memory
} spread ; } spread ;
: heap-stat-step ( obj counts sizes -- ) : heap-stat-step ( obj counts sizes -- )
[ over ] dip
[ [ class ] dip inc-at ] [ [ class ] dip inc-at ]
[ [ [ size ] [ class ] bi ] dip at+ ] 2bi* ; [ [ [ size ] [ class ] bi ] dip at+ ] bi-curry* bi ;
PRIVATE> PRIVATE>

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

@ -32,7 +32,7 @@ M: border baseline
gadget-child pref-dim ; gadget-child pref-dim ;
: scale ( a b s -- c ) : scale ( a b s -- c )
tuck { 1 1 } swap v- [ v* ] 2bi@ v+ ; [ v* ] [ { 1 1 } swap v- v* ] bi-curry bi* v+ ;
: border-dim ( border -- dim ) : border-dim ( border -- dim )
[ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ; [ border-major-dim ] [ border-minor-dim ] [ fill>> ] tri scale ;

19
basis/ui/gadgets/editors/editors.factor
View File

@ -2,12 +2,13 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays documents documents.elements kernel math USING: accessors arrays documents documents.elements kernel math
models models.filter namespaces locals fry make opengl opengl.gl models models.filter namespaces locals fry make opengl opengl.gl
sequences strings math.vectors sorting colors combinators assocs sequences strings math.vectors math.functions sorting colors
math.order fry calendar alarms continuations ui.clipboards ui.commands combinators assocs math.order fry calendar alarms continuations
ui.gadgets ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels ui.clipboards ui.commands ui.gadgets ui.gadgets.borders
ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.menus ui.gadgets.buttons ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.wrappers ui.render ui.text ui.gestures math.geometry.rect ui.gadgets.theme ui.gadgets.menus ui.gadgets.wrappers ui.render
splitting unicode.categories fonts ; ui.text ui.gestures math.geometry.rect splitting unicode.categories
fonts ;
IN: ui.gadgets.editors IN: ui.gadgets.editors
TUPLE: editor < gadget TUPLE: editor < gadget
@ -133,7 +134,7 @@ M: editor ungraft*
[ stop-blinking ] [ f >>focused? relayout-1 ] bi ; [ stop-blinking ] [ f >>focused? relayout-1 ] bi ;
: loc>x ( loc editor -- x ) : loc>x ( loc editor -- x )
[ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x ; [ first2 swap ] dip [ editor-line ] [ font>> ] bi swap offset>x round ;
: line>y ( lines# editor -- y ) : line>y ( lines# editor -- y )
line-height * ; line-height * ;
@ -222,7 +223,7 @@ M: editor ungraft*
: draw-selected-line ( start end n -- ) : draw-selected-line ( start end n -- )
[ start/end-on-line ] keep [ start/end-on-line ] keep
tuck [ swap 2array editor get loc>x ] 2bi@ [ swap 2array editor get loc>x ] curry bi@
(draw-selection) ; (draw-selection) ;
: draw-selection ( -- ) : draw-selection ( -- )
@ -347,7 +348,7 @@ M: editor gadget-text* editor-string % ;
dupd editor-select-next mark>caret ; dupd editor-select-next mark>caret ;
: editor-select ( from to editor -- ) : editor-select ( from to editor -- )
tuck [ mark>> set-model ] [ caret>> set-model ] 2bi* ; [ mark>> set-model ] [ caret>> set-model ] bi-curry bi* ;
: select-elt ( editor elt -- ) : select-elt ( editor elt -- )
[ [ [ editor-caret ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi [ [ [ editor-caret ] [ model>> ] bi ] dip prev/next-elt ] [ drop ] 2bi

2
basis/ui/gadgets/frames/frames.factor
View File

@ -36,7 +36,7 @@ TUPLE: frame < grid ;
[ [ first ] [ third ] bi v+ [v-] ] keep set-second ; [ [ first ] [ third ] bi v+ [v-] ] keep set-second ;
: fill-center ( dim horiz vert -- ) : fill-center ( dim horiz vert -- )
[ over ] dip [ (fill-center) ] 2bi@ ; [ (fill-center) ] bi-curry@ bi ;
M: frame layout* M: frame layout*
dup compute-grid dup compute-grid

27
basis/ui/gadgets/gadgets.factor
View File

@ -190,10 +190,18 @@ GENERIC: pref-dim* ( gadget -- dim )
M: gadget pref-dim* dim>> ; M: gadget pref-dim* dim>> ;
SYMBOL: +baseline+
GENERIC: baseline ( gadget -- y ) GENERIC: baseline ( gadget -- y )
M: gadget baseline pref-dim second ; M: gadget baseline pref-dim second ;
: baseline-align ( gadgets -- ys )
[ { } ] [
[ baseline ] map [ supremum ] keep
[ - ] with map
] if-empty ;
GENERIC: layout* ( gadget -- ) GENERIC: layout* ( gadget -- )
M: gadget layout* drop ; M: gadget layout* drop ;
@ -315,25 +323,24 @@ PRIVATE>
<PRIVATE <PRIVATE
: ((add-gadget)) ( parent child -- parent ) : (add-gadget) ( child parent -- )
over children>> ?push >>children ; {
[ drop unparent ]
: (add-gadget) ( parent child -- parent ) [ >>parent drop ]
dup unparent [ [ ?push ] change-children drop ]
over >>parent [ graft-state>> second [ graft ] [ drop ] if ]
tuck ((add-gadget)) } 2cleave ;
tuck graft-state>> second [ graft ] [ drop ] if ;
PRIVATE> PRIVATE>
: add-gadget ( parent child -- parent ) : add-gadget ( parent child -- parent )
not-in-layout not-in-layout
(add-gadget) over (add-gadget)
dup relayout ; dup relayout ;
: add-gadgets ( parent children -- parent ) : add-gadgets ( parent children -- parent )
not-in-layout not-in-layout
[ (add-gadget) ] each [ over (add-gadget) ] each
dup relayout ; dup relayout ;
: parents ( gadget -- seq ) : parents ( gadget -- seq )

7
basis/ui/gadgets/grids/grids.factor
View File

@ -8,7 +8,8 @@ IN: ui.gadgets.grids
TUPLE: grid < gadget TUPLE: grid < gadget
grid grid
{ gap initial: { 0 0 } } { gap initial: { 0 0 } }
{ fill? initial: t } ; { fill? initial: t }
align ;
: new-grid ( children class -- grid ) : new-grid ( children class -- grid )
new-gadget new-gadget
@ -49,7 +50,7 @@ grid
M: grid pref-dim* M: grid pref-dim*
[ gap>> ] [ compute-grid ] bi [ gap>> ] [ compute-grid ] bi
[ over ] dip [ gap-sum ] 2bi@ (pair-up) ; [ gap-sum ] bi-curry@ bi (pair-up) ;
: do-grid ( dims grid quot -- ) : do-grid ( dims grid quot -- )
[ grid>> ] dip '[ _ 2each ] 2each ; inline [ grid>> ] dip '[ _ 2each ] 2each ; inline
@ -58,7 +59,7 @@ M: grid pref-dim*
[ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ; [ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ;
: position-grid ( grid horiz vert -- ) : position-grid ( grid horiz vert -- )
pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip pick [ [ grid-positions ] bi-curry@ bi pair-up ] dip
[ (>>loc) ] do-grid ; [ (>>loc) ] do-grid ;
: resize-grid ( grid horiz vert -- ) : resize-grid ( grid horiz vert -- )

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

@ -37,7 +37,7 @@ M: incremental dim-changed drop ;
: add-incremental ( gadget incremental -- ) : add-incremental ( gadget incremental -- )
not-in-layout not-in-layout
2dup swap (add-gadget) drop 2dup (add-gadget)
t in-layout? [ t in-layout? [
{ {
[ drop prefer-incremental ] [ drop prefer-incremental ]

13
basis/ui/gadgets/panes/panes.factor
View File

@ -108,14 +108,12 @@ C: <pane-stream> pane-stream
[ prepare-line ] bi ; [ prepare-line ] bi ;
: pane-write ( seq pane -- ) : pane-write ( seq pane -- )
[ '[ _ pane-nl ] ] [ pane-nl ] [ current>> stream-write ]
[ '[ _ current>> stream-write ] ] bi bi-curry interleave ;
interleave ;
: pane-format ( seq style pane -- ) : pane-format ( seq style pane -- )
[ '[ _ drop _ pane-nl ] ] [ nip pane-nl ] [ current>> stream-format ]
[ '[ _ _ current>> stream-format ] ] 2bi bi-curry bi-curry interleave ;
interleave ;
GENERIC: write-gadget ( gadget stream -- ) GENERIC: write-gadget ( gadget stream -- )
@ -329,8 +327,7 @@ M: paragraph stream-format
gadget-format gadget-format
] [ ] [
[ " " split ] 2dip [ " " split ] 2dip
[ '[ _ _ gadget-bl ] ] [ gadget-bl ] [ gadget-format ] bi-curry bi-curry
[ '[ _ _ gadget-format ] ] 2bi
interleave interleave
] if ; ] if ;

21
basis/ui/gadgets/sliders/sliders.factor
View File

@ -129,16 +129,15 @@ M: elevator layout*
'[ _ swap find-slider slide-by-line ] <repeat-button> '[ _ swap find-slider slide-by-line ] <repeat-button>
swap >>orientation ; swap >>orientation ;
: elevator, ( gadget orientation -- gadget ) : add-elevator ( gadget orientation -- gadget )
tuck <elevator> >>elevator [ <elevator> >>elevator ] [ <thumb> >>thumb ] bi
swap <thumb> >>thumb dup [ elevator>> ] [ thumb>> ] bi add-gadget
dup elevator>> over thumb>> add-gadget
@center grid-add ; @center grid-add ;
: <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ; : <left-button> ( -- button ) { 0 1 } arrow-left -1 <slide-button> ;
: <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ; : <right-button> ( -- button ) { 0 1 } arrow-right 1 <slide-button> ;
: <up-button> ( -- button ) horizontal arrow-up -1 <slide-button> ; : <up-button> ( -- button ) horizontal arrow-up -1 <slide-button> ;
: <down-button> ( -- button ) horizontal arrow-down 1 <slide-button> ; : <down-button> ( -- button ) horizontal arrow-down 1 <slide-button> ;
: <slider> ( range orientation -- slider ) : <slider> ( range orientation -- slider )
slider new-frame slider new-frame
@ -149,16 +148,16 @@ M: elevator layout*
: <x-slider> ( range -- slider ) : <x-slider> ( range -- slider )
horizontal <slider> horizontal <slider>
<left-button> @left grid-add <left-button> @left grid-add
vertical elevator, vertical add-elevator
<right-button> @right grid-add ; <right-button> @right grid-add ;
: <y-slider> ( range -- slider ) : <y-slider> ( range -- slider )
vertical <slider> vertical <slider>
<up-button> @top grid-add <up-button> @top grid-add
horizontal elevator, horizontal add-elevator
<down-button> @bottom grid-add ; <down-button> @bottom grid-add ;
M: slider pref-dim* M: slider pref-dim*
dup call-next-method [ call-next-method ] [ orientation>> ] bi
swap orientation>> [ 40 v*n ] keep [ 40 v*n ] keep
set-axis ; set-axis ;

5
basis/ui/gadgets/tables/tables.factor
View File

@ -178,8 +178,8 @@ M: table draw-gadget*
{ {
[ draw-selected ] [ draw-selected ]
[ draw-columns ] [ draw-columns ]
[ draw-moused ]
[ draw-rows ] [ draw-rows ]
[ draw-moused ]
} cleave } cleave
] with-translation ] with-translation
] if ; ] if ;
@ -295,7 +295,8 @@ PRIVATE>
: show-table-menu ( table -- ) : show-table-menu ( table -- )
[ [
tuck [ nth-row drop ] [ renderer>> row-value ] [ hook>> ] tri [ nip ]
[ [ nth-row drop ] [ renderer>> row-value ] [ hook>> ] tri ] 2bi
show-operations-menu show-operations-menu
] [ drop ] if-mouse-row ; ] [ drop ] if-mouse-row ;

4
basis/ui/tools/listener/completion/completion.factor
View File

@ -158,8 +158,8 @@ CONSTANT: completion-popup-offset { -4 0 }
?if ; ?if ;
: completion-gesture ( gesture completion -- value/f operation/f ) : completion-gesture ( gesture completion -- value/f operation/f )
table>> selected-row [ tuck ] dip table>> selected-row
[ gesture>operation ] [ 2drop f ] if ; [ [ nip ] [ gesture>operation ] 2bi ] [ drop f ] if ;
M: completion-popup handle-gesture ( gesture completion -- ? ) M: completion-popup handle-gesture ( gesture completion -- ? )
2dup completion-gesture dup [ 2dup completion-gesture dup [

6
basis/validators/validators.factor
View File

@ -54,12 +54,12 @@ IN: validators
] if ; ] if ;
: v-regexp ( str what regexp -- str ) : v-regexp ( str what regexp -- str )
[ over ] dip matches? 3dup nip matches?
[ drop ] [ "invalid " prepend throw ] if ; [ 2drop ] [ drop "invalid " prepend throw ] if ;
: v-email ( str -- str ) : v-email ( str -- str )
#! From http://www.regular-expressions.info/email.html #! From http://www.regular-expressions.info/email.html
60 v-max-length 320 v-max-length
"e-mail" "e-mail"
R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i R' [A-Z0-9._%+-]+@[A-Z0-9.-]+\.[A-Z]{2,4}'i
v-regexp ; v-regexp ;

6
basis/windows/com/wrapper/wrapper.factor
View File

@ -87,9 +87,9 @@ unless
if ; if ;
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s ) : (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
[ '[ _ '[ @ com-unwrap ] [ swap 2array ] curry map ] ] [ '[ @ com-unwrap ] [ swap 2array ] curry map ]
[ '[ _ [ swap 2array ] curry map ] ] bi bi* [ [ swap 2array ] curry map ] bi-curry bi*
swap append ; prepend ;
: compile-alien-callback ( word return parameters abi quot -- word ) : compile-alien-callback ( word return parameters abi quot -- word )
'[ _ _ _ _ alien-callback ] '[ _ _ _ _ alien-callback ]

3
basis/xml/tests/xmltest.factor
View File

@ -26,8 +26,7 @@ MACRO: drop-input ( quot -- newquot )
infer in>> '[ _ ndrop ] ; infer in>> '[ _ ndrop ] ;
: fails? ( quot -- ? ) : fails? ( quot -- ? )
[ '[ _ drop-output f ] ] [ drop-output f ] [ nip drop-input t ] bi-curry recover ; inline
[ '[ drop _ drop-input t ] ] bi recover ; inline
: well-formed? ( uri -- answer ) : well-formed? ( uri -- answer )
[ file>xml ] fails? "not-wf" "valid" ? ; [ file>xml ] fails? "not-wf" "valid" ? ;

4
basis/xml/writer/writer-tests.factor
View File

@ -14,10 +14,10 @@ IN: xml.writer.tests
[ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test [ "ns:foo" ] [ T{ name { space "ns" } { main "foo" } } name>string ] unit-test
: reprints-as ( to from -- ) : reprints-as ( to from -- )
[ '[ _ ] ] [ '[ _ string>xml xml>string ] ] bi* unit-test ; [ ] [ string>xml xml>string ] bi-curry* unit-test ;
: pprint-reprints-as ( to from -- ) : pprint-reprints-as ( to from -- )
[ '[ _ ] ] [ '[ _ string>xml pprint-xml>string ] ] bi* unit-test ; [ ] [ string>xml pprint-xml>string ] bi-curry* unit-test ;
: reprints-same ( string -- ) dup reprints-as ; : reprints-same ( string -- ) dup reprints-as ;

2
core/assocs/assocs.factor
View File

@ -68,7 +68,7 @@ PRIVATE>
: assoc-partition ( assoc quot -- true-assoc false-assoc ) : assoc-partition ( assoc quot -- true-assoc false-assoc )
[ (assoc-each) partition ] [ drop ] 2bi [ (assoc-each) partition ] [ drop ] 2bi
tuck [ assoc-like ] 2bi@ ; inline [ assoc-like ] curry bi@ ; inline
: assoc-any? ( assoc quot -- ? ) : assoc-any? ( assoc quot -- ? )
assoc-find 2nip ; inline assoc-find 2nip ; inline

4
core/classes/tuple/tuple.factor
View File

@ -251,9 +251,9 @@ M: tuple-class update-class
3bi ; 3bi ;
: tuple-class-unchanged? ( class superclass slots -- ? ) : tuple-class-unchanged? ( class superclass slots -- ? )
[ over ] dip
[ [ superclass ] [ bootstrap-word ] bi* = ] [ [ superclass ] [ bootstrap-word ] bi* = ]
[ [ "slots" word-prop ] dip = ] 2bi* and ; [ [ "slots" word-prop ] dip = ]
bi-curry* bi and ;
: valid-superclass? ( class -- ? ) : valid-superclass? ( class -- ? )
[ tuple-class? ] [ tuple eq? ] bi or ; [ tuple-class? ] [ tuple eq? ] bi or ;

2
core/continuations/continuations-tests.factor
View File

@ -4,7 +4,7 @@ kernel.private accessors eval ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) : (callcc1-test)
swap 1- tuck swap ?push [ 1- dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ; (callcc1-test) ;

5
core/generic/math/math.factor
View File

@ -33,10 +33,11 @@ PREDICATE: math-class < class
: math-upgrade ( class1 class2 -- quot ) : math-upgrade ( class1 class2 -- quot )
[ math-class-max ] 2keep [ math-class-max ] 2keep
[ over ] dip (math-upgrade) [ [
(math-upgrade) (math-upgrade)
dup empty? [ [ dip ] curry [ ] like ] unless dup empty? [ [ dip ] curry [ ] like ] unless
] dip append ; ] [ (math-upgrade) ]
bi-curry* bi append ;
ERROR: no-math-method left right generic ; ERROR: no-math-method left right generic ;

3
core/io/encodings/encodings.factor
View File

@ -74,7 +74,8 @@ M: decoder stream-read1
} cond ; inline } cond ; inline
M: decoder stream-read M: decoder stream-read
tuck >decoder< [ decode-char ] 2curry (read) finish-read fix-read ; [ nip ] [ >decoder< [ decode-char ] 2curry (read) finish-read ] 2bi
fix-read ;
M: decoder stream-read-partial stream-read ; M: decoder stream-read-partial stream-read ;

23
core/kernel/kernel.factor
View File

@ -184,6 +184,29 @@ GENERIC: boa ( ... class -- tuple )
: prepose ( quot1 quot2 -- compose ) : prepose ( quot1 quot2 -- compose )
swap compose ; inline swap compose ; inline
! Curried cleavers
<PRIVATE
: schönfinkel ( quot -- quot' ) [ curry ] curry ; inline
: bi-schönfinkel ( p q -- p' q' ) [ schönfinkel ] bi@ ; inline
: tri-schönfinkel ( p q r -- p' q' r' ) [ schönfinkel ] tri@ ; inline
PRIVATE>
: bi-curry ( x p q -- p' q' ) bi-schönfinkel bi ; inline
: tri-curry ( x p q r -- p' q' r' ) tri-schönfinkel tri ; inline
: bi-curry* ( x y p q -- p' q' ) bi-schönfinkel bi* ; inline
: tri-curry* ( x y z p q r -- p' q' r' ) tri-schönfinkel tri* ; inline
: bi-curry@ ( x y q -- p' q' ) schönfinkel bi@ ; inline
: tri-curry@ ( x y z q -- p' q' r' ) schönfinkel tri@ ; inline
! Booleans ! Booleans
: not ( obj -- ? ) [ f ] [ t ] if ; inline : not ( obj -- ? ) [ f ] [ t ] if ; inline

10
core/lexer/lexer.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors namespaces math words strings USING: kernel sequences accessors namespaces math words strings
io vectors arrays math.parser combinators continuations ; io vectors arrays math.parser combinators continuations ;
@ -23,13 +23,11 @@ TUPLE: lexer text line line-text line-length column ;
lexer new-lexer ; lexer new-lexer ;
: skip ( i seq ? -- n ) : skip ( i seq ? -- n )
[ tuck ] dip over length
[ swap CHAR: \s eq? xor ] curry find-from drop [ [ swap CHAR: \s eq? xor ] curry find-from drop ] dip or ;
[ ] [ length ] ?if ;
: change-lexer-column ( lexer quot -- ) : change-lexer-column ( lexer quot -- )
swap [ [ column>> ] [ line-text>> ] bi ] prepose keep
[ [ column>> ] [ line-text>> ] bi rot call ] keep
(>>column) ; inline (>>column) ; inline
GENERIC: skip-blank ( lexer -- ) GENERIC: skip-blank ( lexer -- )

2
core/math/integers/integers.factor
View File

@ -93,7 +93,7 @@ M: bignum (log2) bignum-log2 ;
: pre-scale ( num den -- scale shifted-num scaled-den ) : pre-scale ( num den -- scale shifted-num scaled-den )
2dup [ log2 ] bi@ - 2dup [ log2 ] bi@ -
tuck [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] 2bi* [ neg 54 + shift ] [ [ scale-denonimator ] dip + ] bi-curry bi*
-rot ; inline -rot ; inline
! Second step: loop ! Second step: loop

2
core/math/math.factor
View File

@ -66,7 +66,7 @@ PRIVATE>
: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline : ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
: rem ( x y -- z ) abs tuck mod over + swap mod ; foldable : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
: 2^ ( n -- 2^n ) 1 swap shift ; inline : 2^ ( n -- 2^n ) 1 swap shift ; inline

38
core/sequences/sequences.factor
View File

@ -128,8 +128,8 @@ INSTANCE: iota immutable-sequence
[ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline [ first3-unsafe ] [ 3 swap nth-unsafe ] bi ; inline
: exchange-unsafe ( m n seq -- ) : exchange-unsafe ( m n seq -- )
[ tuck [ nth-unsafe ] 2bi@ ] [ [ nth-unsafe ] curry bi@ ]
[ tuck [ set-nth-unsafe ] 2bi@ ] 3bi ; inline [ [ set-nth-unsafe ] curry bi@ ] 3bi ; inline
: (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline : (head) ( seq n -- from to seq ) [ 0 ] 2dip swap ; inline
@ -205,7 +205,7 @@ TUPLE: slice
{ seq read-only } ; { seq read-only } ;
: collapse-slice ( m n slice -- m' n' seq ) : collapse-slice ( m n slice -- m' n' seq )
[ from>> ] [ seq>> ] bi [ tuck [ + ] 2bi@ ] dip ; inline [ from>> ] [ seq>> ] bi [ [ + ] curry bi@ ] dip ; inline
ERROR: slice-error from to seq reason ; ERROR: slice-error from to seq reason ;
@ -357,7 +357,7 @@ PRIVATE>
[ (each) ] dip collect ; inline [ (each) ] dip collect ; inline
: 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 ) : 2nth-unsafe ( n seq1 seq2 -- elt1 elt2 )
[ over ] dip [ nth-unsafe ] 2bi@ ; inline [ nth-unsafe ] bi-curry@ bi ; inline
: (2each) ( seq1 seq2 quot -- n quot' ) : (2each) ( seq1 seq2 quot -- n quot' )
[ [
@ -366,12 +366,12 @@ PRIVATE>
] dip compose ; inline ] dip compose ; inline
: 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 ) : 3nth-unsafe ( n seq1 seq2 seq3 -- elt1 elt2 elt3 )
[ over ] 2dip [ over ] dip [ nth-unsafe ] 2tri@ ; inline [ nth-unsafe ] tri-curry@ tri ; inline
: (3each) ( seq1 seq2 seq3 quot -- n quot' ) : (3each) ( seq1 seq2 seq3 quot -- n quot' )
[ [
[ [ length ] tri@ min min ] 3keep [ [ length ] tri@ min min ]
[ 3nth-unsafe ] 3curry [ [ 3nth-unsafe ] 3curry ] 3bi
] dip compose ; inline ] dip compose ; inline
: finish-find ( i seq -- i elt ) : finish-find ( i seq -- i elt )
@ -470,7 +470,7 @@ PRIVATE>
V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline V{ } clone V{ } clone [ [ push-either ] 3curry ] 2keep ; inline
: partition ( seq quot -- trueseq falseseq ) : partition ( seq quot -- trueseq falseseq )
over [ 2pusher [ each ] 2dip ] dip tuck [ like ] 2bi@ ; inline over [ 2pusher [ each ] 2dip ] dip [ like ] curry bi@ ; inline
: accumulator ( quot -- quot' vec ) : accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline V{ } clone [ [ push ] curry compose ] keep ; inline
@ -653,8 +653,14 @@ PRIVATE>
: delete-nth ( n seq -- ) : delete-nth ( n seq -- )
[ dup 1+ ] dip delete-slice ; [ dup 1+ ] dip delete-slice ;
: snip ( from to seq -- head tail )
[ swap head ] [ swap tail ] bi-curry bi* ; inline
: snip-slice ( from to seq -- head tail )
[ swap head-slice ] [ swap tail-slice ] bi-curry bi* ; inline
: replace-slice ( new from to seq -- seq' ) : replace-slice ( new from to seq -- seq' )
tuck [ swap head-slice ] [ swap tail-slice ] 2bi* surround ; snip-slice surround ;
: remove-nth ( n seq -- seq' ) : remove-nth ( n seq -- seq' )
[ [ { } ] dip dup 1+ ] dip replace-slice ; [ [ { } ] dip dup 1+ ] dip replace-slice ;
@ -663,14 +669,14 @@ PRIVATE>
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
: exchange ( m n seq -- ) : exchange ( m n seq -- )
pick over bounds-check 2drop 2dup bounds-check 2drop [ nip bounds-check 2drop ]
exchange-unsafe ; [ bounds-check 3drop ]
[ exchange-unsafe ]
3tri ;
: reverse-here ( seq -- ) : reverse-here ( seq -- )
dup length dup 2/ [ [ length 2/ ] [ length ] [ ] tri
[ 2dup ] dip [ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
tuck - 1- rot exchange-unsafe
] each 2drop ;
: reverse ( seq -- newseq ) : reverse ( seq -- newseq )
[ [
@ -787,7 +793,7 @@ PRIVATE>
: drop-prefix ( seq1 seq2 -- slice1 slice2 ) : drop-prefix ( seq1 seq2 -- slice1 slice2 )
2dup mismatch [ 2dup min-length ] unless* 2dup mismatch [ 2dup min-length ] unless*
tuck [ tail-slice ] 2bi@ ; [ tail-slice ] curry bi@ ;
: unclip ( seq -- rest first ) : unclip ( seq -- rest first )
[ rest ] [ first-unsafe ] bi ; [ rest ] [ first-unsafe ] bi ;

6
core/slots/slots-docs.factor
View File

@ -42,11 +42,11 @@ $nl
" \"alice@bigcorp.com\" >>from" " \"alice@bigcorp.com\" >>from"
"send-email" "send-email"
} }
"This is because " { $link swap } " is easier to understand than " { $link tuck } ":" "The above has less shuffling than the writer version:"
{ $code { $code
"<email>" "<email>"
" tuck (>>subject)" " [ (>>subject) ] keep"
" tuck (>>to)" " [ (>>to) ] keep"
" \"alice@bigcorp.com\" over (>>from)" " \"alice@bigcorp.com\" over (>>from)"
"send-email" "send-email"
} }

4
core/sorting/sorting.factor
View File

@ -137,9 +137,9 @@ TUPLE: merge
[ drop nip nth ] dip push [ drop nip nth ] dip push
] [ ] [
[ [
[ tuck [ nth-unsafe ] 2bi@ 2dup ] dip call +gt+ eq? [ [ nth-unsafe ] curry bi@ 2dup ] dip call +gt+ eq?
[ swap ] when [ swap ] when
] dip tuck [ push ] 2bi@ ] dip [ push ] curry bi@
] if ; inline ] if ; inline
: sort-pairs ( merge quot -- ) : sort-pairs ( merge quot -- )

5
core/source-files/source-files.factor
View File

@ -31,9 +31,8 @@ uses definitions ;
source-files get [ nip xref-source ] assoc-each ; source-files get [ nip xref-source ] assoc-each ;
: record-form ( quot source-file -- ) : record-form ( quot source-file -- )
tuck unxref-source [ quot-uses keys ] dip
quot-uses keys >>uses [ unxref-source ] [ (>>uses) ] [ xref-source ] tri ;
xref-source ;
: record-definitions ( file -- ) : record-definitions ( file -- )
new-definitions get >>definitions drop ; new-definitions get >>definitions drop ;

48
core/splitting/splitting.factor
View File

@ -4,35 +4,46 @@ USING: kernel math make strings arrays vectors sequences
sets math.order accessors ; sets math.order accessors ;
IN: splitting IN: splitting
<PRIVATE
: ?chomp ( seq begin tester chopper -- newseq ? )
[ [ 2dup ] dip call ] dip
[ [ length ] dip call t ] curry
[ drop f ] if ; inline
PRIVATE>
: ?head ( seq begin -- newseq ? ) : ?head ( seq begin -- newseq ? )
2dup head? [ length tail t ] [ drop f ] if ; [ head? ] [ tail ] ?chomp ;
: ?head-slice ( seq begin -- newseq ? ) : ?head-slice ( seq begin -- newseq ? )
2dup head? [ length tail-slice t ] [ drop f ] if ; [ head? ] [ tail-slice ] ?chomp ;
: ?tail ( seq end -- newseq ? ) : ?tail ( seq end -- newseq ? )
2dup tail? [ length head* t ] [ drop f ] if ; [ tail? ] [ head* ] ?chomp ;
: ?tail-slice ( seq end -- newseq ? ) : ?tail-slice ( seq end -- newseq ? )
2dup tail? [ length head-slice* t ] [ drop f ] if ; [ tail? ] [ head-slice* ] ?chomp ;
: (split1) ( seq subseq -- start end ? ) <PRIVATE
tuck swap start dup
[ swap [ drop ] [ length + ] 2bi t ] : (split1) ( seq subseq quot -- before after )
[ 2drop f f f ] [
if ; swap [
[ drop length ] [ start dup ] 2bi
[ [ nip ] [ + ] 2bi t ]
[ 2drop f f f ]
if
] keep swap
] dip [ 2nip f ] if ; inline
PRIVATE>
: split1 ( seq subseq -- before after ) : split1 ( seq subseq -- before after )
[ drop ] [ (split1) ] 2bi [ snip ] (split1) ;
[ [ over ] dip [ head ] [ tail ] 2bi* ]
[ 2drop f ]
if ;
: split1-slice ( seq subseq -- before-slice after-slice ) : split1-slice ( seq subseq -- before-slice after-slice )
[ drop ] [ (split1) ] 2bi [ snip-slice ] (split1) ;
[ [ over ] dip [ head-slice ] [ tail-slice ] 2bi* ]
[ 2drop f ]
if ;
: split1-last ( seq subseq -- before after ) : split1-last ( seq subseq -- before after )
[ <reversed> ] bi@ split1 [ reverse ] bi@ [ <reversed> ] bi@ split1 [ reverse ] bi@
@ -49,7 +60,8 @@ IN: splitting
: split, ( seq separators -- ) 0 rot (split) ; : split, ( seq separators -- ) 0 rot (split) ;
: split ( seq separators -- pieces ) [ split, ] { } make ; : split ( seq separators -- pieces )
[ split, ] { } make ;
: string-lines ( str -- seq ) : string-lines ( str -- seq )
dup "\r\n" intersects? [ dup "\r\n" intersects? [

3
core/words/words.factor
View File

@ -109,10 +109,9 @@ compiled-generic-crossref global [ H{ } assoc-like ] change-at
: compiled-xref ( word dependencies generic-dependencies -- ) : compiled-xref ( word dependencies generic-dependencies -- )
[ [ drop crossref? ] { } assoc-filter-as f like ] bi@ [ [ drop crossref? ] { } assoc-filter-as f like ] bi@
[ over ] dip
[ "compiled-uses" compiled-crossref (compiled-xref) ] [ "compiled-uses" compiled-crossref (compiled-xref) ]
[ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ] [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
2bi* ; bi-curry* bi ;
: (compiled-unxref) ( word word-prop variable -- ) : (compiled-unxref) ( word word-prop variable -- )
[ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ] [ [ [ dupd word-prop ] dip get remove-vertex* ] 2curry ]