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

: spin swap rot ;

db4
Slava Pestov 2007-12-29 11:36:20 -05:00
parent 74fb0ed298
commit e58cbb2cda
20 changed files with 176 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
core/bit-arrays/bit-arrays.factor Normal file → Executable file
View File

@ -20,7 +20,7 @@ IN: bit-arrays
: (set-bits) ( bit-array n -- ) : (set-bits) ( bit-array n -- )
over length bits>cells -rot [ over length bits>cells -rot [
swap rot 4 * set-alien-unsigned-4 spin 4 * set-alien-unsigned-4
] 2curry each ; inline ] 2curry each ; inline
PRIVATE> PRIVATE>

2
core/combinators/combinators.factor
View File

@ -63,7 +63,7 @@ M: sequence hashcode*
next-power-of-2 swap [ nip clone ] curry map ; next-power-of-2 swap [ nip clone ] curry map ;
: distribute-buckets ( assoc initial quot -- buckets ) : distribute-buckets ( assoc initial quot -- buckets )
swap rot [ length <buckets> ] keep spin [ length <buckets> ] keep
[ >r 2dup r> dup first roll call (distribute-buckets) ] each [ >r 2dup r> dup first roll call (distribute-buckets) ] each
nip ; inline nip ; inline

14
core/kernel/kernel-docs.factor
View File

@ -26,6 +26,7 @@ $nl
{ $subsection swapd } { $subsection swapd }
{ $subsection rot } { $subsection rot }
{ $subsection -rot } { $subsection -rot }
{ $subsection spin }
{ $subsection roll } { $subsection roll }
{ $subsection -roll } { $subsection -roll }
"Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:" "Sometimes an additional storage area is needed to hold objects. The " { $emphasis "retain stack" } " is an auxilliary stack for this purpose. Objects can be moved between the data and retain stacks using the following two words:"
@ -37,7 +38,9 @@ $nl
{ $code { $code
": foo ( m ? n -- m+n/n )" ": foo ( m ? n -- m+n/n )"
" >r [ r> + ] [ drop r> ] if ; ! This is OK" " >r [ r> + ] [ drop r> ] if ; ! This is OK"
} ; }
"An alternative to using " { $link >r } " and " { $link r> } " is the following:"
{ $subsection dip } ;
ARTICLE: "basic-combinators" "Basic combinators" ARTICLE: "basic-combinators" "Basic combinators"
"The following pair of words invoke words and quotations reflectively:" "The following pair of words invoke words and quotations reflectively:"
@ -159,6 +162,7 @@ HELP: tuck ( x y -- y x y ) $shuffle ;
HELP: over ( x y -- x y x ) $shuffle ; HELP: over ( x y -- x y x ) $shuffle ;
HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ;
HELP: swap ( x y -- y x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ;
HELP: spin $shuffle ;
HELP: roll $shuffle ; HELP: roll $shuffle ;
HELP: -roll $shuffle ; HELP: -roll $shuffle ;
@ -541,6 +545,14 @@ HELP: 3compose
"However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations." "However, " { $link 3compose } " runs in constant time, and the compiler is able to compile code which calls composed quotations."
} ; } ;
HELP: dip
{ $values { "obj" object } { "quot" quotation } }
{ $description "Calls " { $snippet "quot" } " with " { $snippet "obj" } " hidden on the retain stack." }
{ $notes "The following are equivalent:"
{ $code ">r foo bar r>" }
{ $code "[ foo bar ] dip" }
} ;
HELP: while HELP: while
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } { $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." } { $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }

4
core/kernel/kernel.factor
View File

@ -6,6 +6,8 @@ IN: kernel
: version ( -- str ) "0.92" ; foldable : version ( -- str ) "0.92" ; foldable
! Stack stuff ! Stack stuff
: spin ( x y z -- z y x ) swap rot ; inline
: roll ( x y z t -- y z t x ) >r rot r> swap ; inline : roll ( x y z t -- y z t x ) >r rot r> swap ; inline
: -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline : -roll ( x y z t -- t x y z ) swap >r -rot r> ; inline
@ -49,7 +51,7 @@ DEFER: if
: 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline : 3slip ( quot x y z -- x y z ) >r >r >r call r> r> r> ; inline
: dip ( obj callable -- obj ) swap slip ; inline : dip ( obj quot -- obj ) swap slip ; inline
: keep ( x quot -- x ) over slip ; inline : keep ( x quot -- x ) over slip ; inline

6
core/sequences/sequences.factor
View File

@ -115,7 +115,7 @@ INSTANCE: integer immutable-sequence
[ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck
>r >r set-nth-unsafe r> r> set-nth-unsafe ; inline >r >r set-nth-unsafe r> r> set-nth-unsafe ; inline
: (head) ( seq n -- from to seq ) 0 swap rot ; inline : (head) ( seq n -- from to seq ) 0 spin ; inline
: (tail) ( seq n -- from to seq ) over length rot ; inline : (tail) ( seq n -- from to seq ) over length rot ; inline
@ -270,7 +270,7 @@ PRIVATE>
: tail* ( seq n -- tailseq ) from-end tail ; : tail* ( seq n -- tailseq ) from-end tail ;
: copy ( src i dst -- ) : copy ( src i dst -- )
pick length >r 3dup check-copy swap rot 0 r> pick length >r 3dup check-copy spin 0 r>
(copy) drop ; inline (copy) drop ; inline
M: sequence clone-like M: sequence clone-like
@ -579,7 +579,7 @@ M: sequence <=>
: join ( seq glue -- newseq ) : join ( seq glue -- newseq )
[ [
2dup joined-length over new-resizable -rot swap 2dup joined-length over new-resizable spin
[ dup pick push-all ] [ pick push-all ] interleave drop [ dup pick push-all ] [ pick push-all ] interleave drop
] keep like ; ] keep like ;

2
core/words/words.factor
View File

@ -94,8 +94,6 @@ M: compound redefined* ( word -- )
<PRIVATE <PRIVATE
: changed-word ( word -- ) dup changed-words get set-at ;
: define ( word def -- ) : define ( word def -- )
over unxref over unxref
over redefined over redefined

2
extra/cocoa/pasteboard/pasteboard.factor Normal file → Executable file
View File

@ -24,7 +24,7 @@ IN: cocoa.pasteboard
: pasteboard-error ( error -- f ) : pasteboard-error ( error -- f )
"Pasteboard does not hold a string" <NSString> "Pasteboard does not hold a string" <NSString>
0 swap rot set-void*-nth f ; 0 spin set-void*-nth f ;
: ?pasteboard-string ( pboard error -- str/f ) : ?pasteboard-string ( pboard error -- str/f )
over pasteboard-string? [ over pasteboard-string? [

2
extra/combinators/lib/lib.factor Normal file → Executable file
View File

@ -120,7 +120,7 @@ MACRO: ifte ( quot quot quot -- )
: preserving ( predicate -- quot ) : preserving ( predicate -- quot )
dup infer effect-in dup infer effect-in
dup 1+ swap rot dup 1+ spin
[ , , nkeep , nrot ] [ , , nkeep , nrot ]
bake ; bake ;

3
extra/delegate/delegate.factor Normal file → Executable file
View File

@ -27,9 +27,6 @@ M: tuple-class group-words
dup [ slot-spec-reader ] map dup [ slot-spec-reader ] map
swap [ slot-spec-writer ] map append ; swap [ slot-spec-writer ] map append ;
: spin ( x y z -- z y x )
swap rot ;
: define-consult-method ( word class quot -- ) : define-consult-method ( word class quot -- )
pick add <method> spin define-method ; pick add <method> spin define-method ;

2
extra/hashtables/lib/lib.factor Normal file → Executable file
View File

@ -9,7 +9,7 @@ IN: hashtables.lib
! set-hash with alternative stack effects ! set-hash with alternative stack effects
: put-hash* ( table key value -- ) swap rot set-at ; : put-hash* ( table key value -- ) spin set-at ;
: put-hash ( table key value -- table ) swap pick set-at ; : put-hash ( table key value -- table ) swap pick set-at ;

2
extra/jamshred/tunnel/tunnel.factor Normal file → Executable file
View File

@ -89,7 +89,7 @@ TUPLE: segment number color radius ;
rot dup length swap <slice> find-nearest-segment ; rot dup length swap <slice> find-nearest-segment ;
: nearest-segment-backward ( segments oint start -- segment ) : nearest-segment-backward ( segments oint start -- segment )
swapd 1+ 0 swap rot <slice> <reversed> find-nearest-segment ; swapd 1+ 0 spin <slice> <reversed> find-nearest-segment ;
: nearest-segment ( segments oint start-segment -- segment ) : nearest-segment ( segments oint start-segment -- segment )
#! find the segment nearest to 'oint', and return it. #! find the segment nearest to 'oint', and return it.

4
extra/koszul/koszul.factor Normal file → Executable file
View File

@ -199,7 +199,7 @@ DEFER: (d)
: bigraded-ker/im-d ( bigraded-basis -- seq ) : bigraded-ker/im-d ( bigraded-basis -- seq )
dup length [ dup length [
over first length [ over first length [
>r 2dup r> swap rot (bigraded-ker/im-d) >r 2dup r> spin (bigraded-ker/im-d)
] map 2nip ] map 2nip
] curry* map ; ] curry* map ;
@ -277,7 +277,7 @@ DEFER: (d)
: bigraded-triples ( grid -- triples ) : bigraded-triples ( grid -- triples )
dup length [ dup length [
over first length [ over first length [
>r 2dup r> swap rot bigraded-triple >r 2dup r> spin bigraded-triple
] map 2nip ] map 2nip
] curry* map ; ] curry* map ;

2
extra/math/matrices/elimination/elimination.factor Normal file → Executable file
View File

@ -84,7 +84,7 @@ SYMBOL: matrix
: basis-vector ( row col# -- ) : basis-vector ( row col# -- )
>r clone r> >r clone r>
[ swap nth neg recip ] 2keep [ swap nth neg recip ] 2keep
[ 0 swap rot set-nth ] 2keep [ 0 spin set-nth ] 2keep
>r n*v r> >r n*v r>
matrix get set-nth ; matrix get set-nth ;

2
extra/prolog/prolog.factor Normal file → Executable file
View File

@ -79,6 +79,6 @@ SYMBOL: plchoice
] if ; ] if ;
: binding-resolve ( binds name pat -- binds ) : binding-resolve ( binds name pat -- binds )
tuck lookup-rule dup backtrace? swap rot add-bindings ; tuck lookup-rule dup backtrace? spin add-bindings ;
: is ( binds val var -- binds ) rot [ set-at ] keep ; : is ( binds val var -- binds ) rot [ set-at ] keep ;

2
extra/space-invaders/space-invaders.factor Normal file → Executable file
View File

@ -293,7 +293,7 @@ M: invaders-gadget draw-gadget* ( gadget -- )
: plot-bitmap-pixel ( bitmap point color -- ) : plot-bitmap-pixel ( bitmap point color -- )
#! point is a {x y}. color is a {r g b}. #! point is a {x y}. color is a {r g b}.
swap rot set-bitmap-pixel ; spin set-bitmap-pixel ;
: within ( n a b -- bool ) : within ( n a b -- bool )
#! n >= a and n <= b #! n >= a and n <= b

4
extra/ui/gadgets/grid-lines/grid-lines.factor Normal file → Executable file
View File

@ -14,8 +14,8 @@ SYMBOL: grid-dim
: grid-line-from/to ( orientation point -- from to ) : grid-line-from/to ( orientation point -- from to )
half-gap v- half-gap v-
[ half-gap swap rot set-axis ] 2keep [ half-gap spin set-axis ] 2keep
grid-dim get swap rot set-axis ; grid-dim get spin set-axis ;
: draw-grid-lines ( gaps orientation -- ) : draw-grid-lines ( gaps orientation -- )
grid get rot grid-positions grid get rect-dim add [ grid get rot grid-positions grid get rect-dim add [

4
extra/unicode/unicode.factor Normal file → Executable file
View File

@ -100,7 +100,7 @@ IN: unicode
[ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ;
: replace ( seq old new -- newseq ) : replace ( seq old new -- newseq )
swap rot [ 2dup = [ drop over ] when ] map 2nip ; spin [ 2dup = [ drop over ] when ] map 2nip ;
: process-names ( data -- names-hash ) : process-names ( data -- names-hash )
1 swap (process-data) 1 swap (process-data)
@ -382,7 +382,7 @@ SYMBOL: locale ! Just casing locale, or overall?
] if ; inline ] if ; inline
: insert ( seq quot elt n -- ) : insert ( seq quot elt n -- )
swap rot >r -rot [ swap set-nth ] 2keep r> (insert) ; inline spin >r -rot [ swap set-nth ] 2keep r> (insert) ; inline
: insertion-sort ( seq quot -- ) : insertion-sort ( seq quot -- )
! quot is a transformation on elements ! quot is a transformation on elements

2
extra/units/units.factor Normal file → Executable file
View File

@ -69,7 +69,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ;
: d-sq ( d -- d ) dup d* ; : d-sq ( d -- d ) dup d* ;
: d-recip ( d -- d' ) : d-recip ( d -- d' )
>dimensioned< swap rot recip dimension-op> ; >dimensioned< spin recip dimension-op> ;
: d/ ( d d -- d ) d-recip d* ; : d/ ( d d -- d ) d-recip d* ;

2
extra/x/widgets/wm/root/root.factor Normal file → Executable file
View File

@ -74,7 +74,7 @@ dup XKeyEvent-state swap event>keyname 2array ;
[ $keymap swap resolve-key-event call ] [ $keymap swap resolve-key-event call ]
"grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [ "grab-key" !( wm-root modifiers keyname -- wm-root modifiers keyname ) [
3dup name>keysym keysym-to-keycode swap rot 3dup name>keysym keysym-to-keycode spin
False GrabModeAsync GrabModeAsync grab-key ] False GrabModeAsync GrabModeAsync grab-key ]
"set-key-action" !( wm-root modifiers keyname action -- wm-root ) [ "set-key-action" !( wm-root modifiers keyname action -- wm-root ) [

2
extra/xml/utilities/utilities.factor Normal file → Executable file
View File

@ -91,7 +91,7 @@ M: xml xml-map
GENERIC# xml-find 1 ( quot tag -- tag ) inline GENERIC# xml-find 1 ( quot tag -- tag ) inline
M: tag xml-find M: tag xml-find
[ call ] 2keep swap rot [ [ call ] 2keep spin [
f swap f swap
[ nip over >r swap xml-find r> swap dup ] find [ nip over >r swap xml-find r> swap dup ] find
2drop ! leaves result of quot 2drop ! leaves result of quot