diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor old mode 100644 new mode 100755 index 185ca0c2d2..d1eb7802ef --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -20,7 +20,7 @@ IN: bit-arrays : (set-bits) ( bit-array n -- ) over length bits>cells -rot [ - swap rot 4 * set-alien-unsigned-4 + spin 4 * set-alien-unsigned-4 ] 2curry each ; inline PRIVATE> diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index 2c418768c6..6f39925bd0 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -63,7 +63,7 @@ M: sequence hashcode* next-power-of-2 swap [ nip clone ] curry map ; : distribute-buckets ( assoc initial quot -- buckets ) - swap rot [ length ] keep + spin [ length ] keep [ >r 2dup r> dup first roll call (distribute-buckets) ] each nip ; inline diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index af6acd004b..ae30edc7b8 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -26,6 +26,7 @@ $nl { $subsection swapd } { $subsection rot } { $subsection -rot } +{ $subsection spin } { $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:" @@ -37,7 +38,9 @@ $nl { $code ": foo ( m ? n -- m+n/n )" " >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" "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: pick ( x y z -- x y z x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ; +HELP: spin $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." } ; +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 { $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." } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 6fe0a9588c..625c31eba1 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -6,6 +6,8 @@ IN: kernel : version ( -- str ) "0.92" ; foldable ! 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 -- 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 -: dip ( obj callable -- obj ) swap slip ; inline +: dip ( obj quot -- obj ) swap slip ; inline : keep ( x quot -- x ) over slip ; inline diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index de10e5c2e4..b5955d0197 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -115,7 +115,7 @@ INSTANCE: integer immutable-sequence [ tuck nth-unsafe >r nth-unsafe r> ] 3keep tuck >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 @@ -270,7 +270,7 @@ PRIVATE> : tail* ( seq n -- tailseq ) from-end tail ; : 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 M: sequence clone-like @@ -579,7 +579,7 @@ M: sequence <=> : 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 ] keep like ; diff --git a/core/words/words.factor b/core/words/words.factor index baec10a821..23dba982bb 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -94,8 +94,6 @@ M: compound redefined* ( word -- ) - 0 swap rot set-void*-nth f ; + 0 spin set-void*-nth f ; : ?pasteboard-string ( pboard error -- str/f ) over pasteboard-string? [ diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor old mode 100644 new mode 100755 index 047887bcc8..39a04571f7 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -120,7 +120,7 @@ MACRO: ifte ( quot quot quot -- ) : preserving ( predicate -- quot ) dup infer effect-in - dup 1+ swap rot + dup 1+ spin [ , , nkeep , nrot ] bake ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor old mode 100644 new mode 100755 index 5614296305..44da847d9e --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,9 +27,6 @@ M: tuple-class group-words dup [ slot-spec-reader ] map swap [ slot-spec-writer ] map append ; -: spin ( x y z -- z y x ) - swap rot ; - : define-consult-method ( word class quot -- ) pick add spin define-method ; diff --git a/extra/hashtables/lib/lib.factor b/extra/hashtables/lib/lib.factor old mode 100644 new mode 100755 index 1bcd139d9c..9b3932a3a4 --- a/extra/hashtables/lib/lib.factor +++ b/extra/hashtables/lib/lib.factor @@ -9,7 +9,7 @@ IN: hashtables.lib ! 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 ; diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor old mode 100644 new mode 100755 index 149170eb53..4d60a65a4a --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -89,7 +89,7 @@ TUPLE: segment number color radius ; rot dup length swap find-nearest-segment ; : nearest-segment-backward ( segments oint start -- segment ) - swapd 1+ 0 swap rot find-nearest-segment ; + swapd 1+ 0 spin find-nearest-segment ; : nearest-segment ( segments oint start-segment -- segment ) #! find the segment nearest to 'oint', and return it. diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor old mode 100644 new mode 100755 index eb15336788..7a97578a9c --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -199,7 +199,7 @@ DEFER: (d) : bigraded-ker/im-d ( bigraded-basis -- seq ) dup length [ over first length [ - >r 2dup r> swap rot (bigraded-ker/im-d) + >r 2dup r> spin (bigraded-ker/im-d) ] map 2nip ] curry* map ; @@ -277,7 +277,7 @@ DEFER: (d) : bigraded-triples ( grid -- triples ) dup length [ over first length [ - >r 2dup r> swap rot bigraded-triple + >r 2dup r> spin bigraded-triple ] map 2nip ] curry* map ; diff --git a/extra/math/matrices/elimination/elimination.factor b/extra/math/matrices/elimination/elimination.factor old mode 100644 new mode 100755 index b11ef5ba6b..73f6dd7e96 --- a/extra/math/matrices/elimination/elimination.factor +++ b/extra/math/matrices/elimination/elimination.factor @@ -84,7 +84,7 @@ SYMBOL: matrix : basis-vector ( row col# -- ) >r clone r> [ swap nth neg recip ] 2keep - [ 0 swap rot set-nth ] 2keep + [ 0 spin set-nth ] 2keep >r n*v r> matrix get set-nth ; diff --git a/extra/prolog/prolog.factor b/extra/prolog/prolog.factor old mode 100644 new mode 100755 index 0a6a513b97..580bfaf52e --- a/extra/prolog/prolog.factor +++ b/extra/prolog/prolog.factor @@ -79,6 +79,6 @@ SYMBOL: plchoice ] if ; : 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 ; diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor old mode 100644 new mode 100755 index 3f695a4f60..aa76f8ec3f --- a/extra/space-invaders/space-invaders.factor +++ b/extra/space-invaders/space-invaders.factor @@ -293,7 +293,7 @@ M: invaders-gadget draw-gadget* ( gadget -- ) : plot-bitmap-pixel ( bitmap point color -- ) #! 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 ) #! n >= a and n <= b diff --git a/extra/ui/gadgets/grid-lines/grid-lines.factor b/extra/ui/gadgets/grid-lines/grid-lines.factor old mode 100644 new mode 100755 index f055ab0df0..8a38737f41 --- a/extra/ui/gadgets/grid-lines/grid-lines.factor +++ b/extra/ui/gadgets/grid-lines/grid-lines.factor @@ -14,8 +14,8 @@ SYMBOL: grid-dim : grid-line-from/to ( orientation point -- from to ) half-gap v- - [ half-gap swap rot set-axis ] 2keep - grid-dim get swap rot set-axis ; + [ half-gap spin set-axis ] 2keep + grid-dim get spin set-axis ; : draw-grid-lines ( gaps orientation -- ) grid get rot grid-positions grid get rect-dim add [ diff --git a/extra/unicode/unicode.factor b/extra/unicode/unicode.factor old mode 100644 new mode 100755 index bac768b84c..609b57d4b2 --- a/extra/unicode/unicode.factor +++ b/extra/unicode/unicode.factor @@ -100,7 +100,7 @@ IN: unicode [ dup CHAR: A CHAR: Z between? [ HEX: 20 + ] when ] map ; : 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 ) 1 swap (process-data) @@ -382,7 +382,7 @@ SYMBOL: locale ! Just casing locale, or overall? ] if ; inline : 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 -- ) ! quot is a transformation on elements diff --git a/extra/units/units.factor b/extra/units/units.factor old mode 100644 new mode 100755 index 95f4ed8ef3..f7aad72545 --- a/extra/units/units.factor +++ b/extra/units/units.factor @@ -69,7 +69,7 @@ M: dimensions-not-equal summary drop "Dimensions do not match" ; : d-sq ( d -- d ) dup d* ; : d-recip ( d -- d' ) - >dimensioned< swap rot recip dimension-op> ; + >dimensioned< spin recip dimension-op> ; : d/ ( d d -- d ) d-recip d* ; diff --git a/extra/x/widgets/wm/root/root.factor b/extra/x/widgets/wm/root/root.factor old mode 100644 new mode 100755 index 0ce91d5ebf..f5352a0f07 --- a/extra/x/widgets/wm/root/root.factor +++ b/extra/x/widgets/wm/root/root.factor @@ -74,7 +74,7 @@ dup XKeyEvent-state swap event>keyname 2array ; [ $keymap swap resolve-key-event call ] "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 ] "set-key-action" !( wm-root modifiers keyname action -- wm-root ) [ diff --git a/extra/xml/utilities/utilities.factor b/extra/xml/utilities/utilities.factor old mode 100644 new mode 100755 index 303de4295e..e64b9591a5 --- a/extra/xml/utilities/utilities.factor +++ b/extra/xml/utilities/utilities.factor @@ -1,140 +1,140 @@ -! Copyright (C) 2005, 2006 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces sequences words io assocs -quotations strings parser arrays xml.data xml.writer debugger -splitting ; -IN: xml.utilities - -! * System for words specialized on tag names - -TUPLE: process-missing process tag ; -M: process-missing error. - "Tag <" write - dup process-missing-tag print-name - "> not implemented on process process " write - process-missing-process word-name print ; - -: run-process ( tag word -- ) - 2dup "xtable" word-prop - >r dup name-tag r> at* [ 2nip call ] [ - drop \ process-missing construct-boa throw - ] if ; - -: PROCESS: - CREATE - dup H{ } clone "xtable" set-word-prop - dup [ run-process ] curry define-compound ; parsing - -: TAG: - scan scan-word - parse-definition - swap "xtable" word-prop - rot "/" split [ >r 2dup r> swap set-at ] each 2drop ; - parsing - - -! * Common utility functions - -: build-tag* ( items name -- tag ) - "" swap "" - swap >r { } r> ; - -: build-tag ( item name -- tag ) - >r 1array r> build-tag* ; - -: build-xml ( tag -- xml ) - T{ prolog f "1.0" "iso-8859-1" f } { } rot { } ; - -: children>string ( tag -- string ) - tag-children - dup [ string? ] all? - [ "XML tag unexpectedly contains non-text children" throw ] unless - concat ; - -: children-tags ( tag -- sequence ) - tag-children [ tag? ] subset ; - -: first-child-tag ( tag -- tag ) - tag-children [ tag? ] find nip ; - -! * Utilities for searching through XML documents -! These all work from the outside in, top to bottom. - -: with-delegate ( object quot -- object ) - over clone >r >r delegate r> call r> - [ set-delegate ] keep ; inline - -GENERIC# xml-each 1 ( quot tag -- ) inline -M: tag xml-each - [ call ] 2keep - swap tag-children [ swap xml-each ] curry* each ; -M: object xml-each - call ; -M: xml xml-each - >r delegate r> xml-each ; - -GENERIC# xml-map 1 ( quot tag -- tag ) inline -M: tag xml-map - swap clone over >r swap call r> - swap [ tag-children [ swap xml-map ] curry* map ] keep - [ set-tag-children ] keep ; -M: object xml-map - call ; -M: xml xml-map - swap [ swap xml-map ] with-delegate ; - -: xml-subset ( quot tag -- seq ) ! quot: tag -- ? - V{ } clone rot [ - swap >r [ swap call ] 2keep rot r> - swap [ [ push ] keep ] [ nip ] if - ] xml-each nip ; - -GENERIC# xml-find 1 ( quot tag -- tag ) inline -M: tag xml-find - [ call ] 2keep swap rot [ - f swap - [ nip over >r swap xml-find r> swap dup ] find - 2drop ! leaves result of quot - ] unless nip ; -M: object xml-find - keep f ? ; -M: xml xml-find - >r delegate r> xml-find ; - -GENERIC# xml-inject 1 ( quot tag -- ) inline -M: tag xml-inject - swap [ - swap [ call ] keep - [ xml-inject ] keep - ] change-each ; -M: object xml-inject 2drop ; -M: xml xml-inject >r delegate >r xml-inject ; - -! * Accessing part of an XML document - -: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) - swap [ - dup tag? - [ "id" swap at over = ] - [ drop f ] if - ] xml-find nip ; - -: (get-tag) ( name elem -- ? ) - dup tag? [ names-match? ] [ 2drop f ] if ; - -: tag-named* ( tag name/string -- matching-tag ) - assure-name swap [ dupd (get-tag) ] xml-find nip ; - -: tags-named* ( tag name/string -- tags-seq ) - assure-name swap [ dupd (get-tag) ] xml-subset nip ; - -: tag-named ( tag name/string -- matching-tag ) - ! like get-name-tag but only looks at direct children, - ! not all the children down the tree. - assure-name swap [ (get-tag) ] curry* find nip ; - -: tags-named ( tag name/string -- tags-seq ) - assure-name swap [ (get-tag) ] curry* subset ; - -: assert-tag ( name name -- ) - names-match? [ "Unexpected XML tag found" throw ] unless ; +! Copyright (C) 2005, 2006 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences words io assocs +quotations strings parser arrays xml.data xml.writer debugger +splitting ; +IN: xml.utilities + +! * System for words specialized on tag names + +TUPLE: process-missing process tag ; +M: process-missing error. + "Tag <" write + dup process-missing-tag print-name + "> not implemented on process process " write + process-missing-process word-name print ; + +: run-process ( tag word -- ) + 2dup "xtable" word-prop + >r dup name-tag r> at* [ 2nip call ] [ + drop \ process-missing construct-boa throw + ] if ; + +: PROCESS: + CREATE + dup H{ } clone "xtable" set-word-prop + dup [ run-process ] curry define-compound ; parsing + +: TAG: + scan scan-word + parse-definition + swap "xtable" word-prop + rot "/" split [ >r 2dup r> swap set-at ] each 2drop ; + parsing + + +! * Common utility functions + +: build-tag* ( items name -- tag ) + "" swap "" + swap >r { } r> ; + +: build-tag ( item name -- tag ) + >r 1array r> build-tag* ; + +: build-xml ( tag -- xml ) + T{ prolog f "1.0" "iso-8859-1" f } { } rot { } ; + +: children>string ( tag -- string ) + tag-children + dup [ string? ] all? + [ "XML tag unexpectedly contains non-text children" throw ] unless + concat ; + +: children-tags ( tag -- sequence ) + tag-children [ tag? ] subset ; + +: first-child-tag ( tag -- tag ) + tag-children [ tag? ] find nip ; + +! * Utilities for searching through XML documents +! These all work from the outside in, top to bottom. + +: with-delegate ( object quot -- object ) + over clone >r >r delegate r> call r> + [ set-delegate ] keep ; inline + +GENERIC# xml-each 1 ( quot tag -- ) inline +M: tag xml-each + [ call ] 2keep + swap tag-children [ swap xml-each ] curry* each ; +M: object xml-each + call ; +M: xml xml-each + >r delegate r> xml-each ; + +GENERIC# xml-map 1 ( quot tag -- tag ) inline +M: tag xml-map + swap clone over >r swap call r> + swap [ tag-children [ swap xml-map ] curry* map ] keep + [ set-tag-children ] keep ; +M: object xml-map + call ; +M: xml xml-map + swap [ swap xml-map ] with-delegate ; + +: xml-subset ( quot tag -- seq ) ! quot: tag -- ? + V{ } clone rot [ + swap >r [ swap call ] 2keep rot r> + swap [ [ push ] keep ] [ nip ] if + ] xml-each nip ; + +GENERIC# xml-find 1 ( quot tag -- tag ) inline +M: tag xml-find + [ call ] 2keep spin [ + f swap + [ nip over >r swap xml-find r> swap dup ] find + 2drop ! leaves result of quot + ] unless nip ; +M: object xml-find + keep f ? ; +M: xml xml-find + >r delegate r> xml-find ; + +GENERIC# xml-inject 1 ( quot tag -- ) inline +M: tag xml-inject + swap [ + swap [ call ] keep + [ xml-inject ] keep + ] change-each ; +M: object xml-inject 2drop ; +M: xml xml-inject >r delegate >r xml-inject ; + +! * Accessing part of an XML document + +: get-id ( tag id -- elem ) ! elem=tag.getElementById(id) + swap [ + dup tag? + [ "id" swap at over = ] + [ drop f ] if + ] xml-find nip ; + +: (get-tag) ( name elem -- ? ) + dup tag? [ names-match? ] [ 2drop f ] if ; + +: tag-named* ( tag name/string -- matching-tag ) + assure-name swap [ dupd (get-tag) ] xml-find nip ; + +: tags-named* ( tag name/string -- tags-seq ) + assure-name swap [ dupd (get-tag) ] xml-subset nip ; + +: tag-named ( tag name/string -- matching-tag ) + ! like get-name-tag but only looks at direct children, + ! not all the children down the tree. + assure-name swap [ (get-tag) ] curry* find nip ; + +: tags-named ( tag name/string -- tags-seq ) + assure-name swap [ (get-tag) ] curry* subset ; + +: assert-tag ( name name -- ) + names-match? [ "Unexpected XML tag found" throw ] unless ;