From 61d579360dfa9dc7cfc0680a68ad7414202874a2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 5 Nov 2009 17:03:24 -0600 Subject: [PATCH] remove non-primitive-related uses of tuck from basis --- basis/core-text/core-text-tests.factor | 11 ++++---- basis/csv/csv-tests.factor | 5 ++-- basis/db/sqlite/sqlite.factor | 13 +++++----- basis/fry/fry-docs.factor | 1 - basis/game/input/input.factor | 3 +-- basis/images/jpeg/jpeg.factor | 2 +- basis/io/buffers/buffers-tests.factor | 2 +- basis/io/files/info/windows/windows.factor | 25 ++++++++++++------- basis/io/launcher/windows/windows.factor | 2 +- basis/lists/lazy/lazy.factor | 2 +- basis/math/combinatorics/combinatorics.factor | 6 ++--- basis/math/intervals/intervals-tests.factor | 4 +-- basis/persistent/vectors/vectors.factor | 4 +-- basis/regexp/dfa/dfa.factor | 2 +- basis/regexp/minimize/minimize.factor | 2 +- basis/suffix-arrays/suffix-arrays.factor | 3 +-- basis/tools/scaffold/scaffold.factor | 2 +- basis/ui/traverse/traverse.factor | 9 ++++--- basis/unix/groups/groups.factor | 2 +- basis/xmode/catalog/catalog.factor | 2 +- basis/xmode/marker/marker.factor | 10 ++++---- core/kernel/kernel-docs.factor | 2 -- 22 files changed, 60 insertions(+), 54 deletions(-) diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor index a5cf69fdee..b6b54df7c3 100644 --- a/basis/core-text/core-text-tests.factor +++ b/basis/core-text/core-text-tests.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: tools.test core-text core-text.fonts core-foundation core-foundation.dictionaries destructors arrays kernel generalizations -math accessors core-foundation.utilities combinators hashtables colors +locals math accessors core-foundation.utilities combinators hashtables colors colors.constants ; IN: core-text.tests @@ -18,10 +18,11 @@ IN: core-text.tests ] with-destructors ] unit-test -: test-typographic-bounds ( string font -- ? ) +:: test-typographic-bounds ( string font -- ? ) [ - test-font &CFRelease tuck COLOR: white &CFRelease - compute-line-metrics { + font test-font &CFRelease :> ctfont + string ctfont COLOR: white &CFRelease :> ctline + ctfont ctline compute-line-metrics { [ width>> float? ] [ ascent>> float? ] [ descent>> float? ] @@ -33,4 +34,4 @@ IN: core-text.tests [ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test -[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test \ No newline at end of file +[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 6ba8e2d5b8..829637b4aa 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -70,11 +70,12 @@ IN: csv.tests "can write csv too!" [ "foo1,bar1\nfoo2,bar2\n" ] -[ { { "foo1" "bar1" } { "foo2" "bar2" } } tuck write-csv >string ] named-unit-test +[ { { "foo1" "bar1" } { "foo2" "bar2" } } [ write-csv ] keep >string ] named-unit-test + "escapes quotes commas and newlines when writing" [ "\"fo\"\"o1\",bar1\n\"fo\no2\",\"b,ar2\"\n" ] -[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } tuck write-csv >string ] named-unit-test ! " +[ { { "fo\"o1" "bar1" } { "fo\no2" "b,ar2" } } [ write-csv ] keep >string ] named-unit-test ! " [ { { "writing" "some" "csv" "tests" } } ] [ diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor index ffcbec70d0..8d26d3b098 100755 --- a/basis/db/sqlite/sqlite.factor +++ b/basis/db/sqlite/sqlite.factor @@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db hashtables io.files kernel math math.parser namespaces prettyprint fry sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators -math.intervals io nmake accessors vectors math.ranges random +math.intervals io locals nmake accessors vectors math.ranges random math.bitwise db.queries destructors db.tuples.private interpolate io.streams.string make db.private sequences.deep db.errors.sqlite ; @@ -85,12 +85,11 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array ) nip [ key>> ] [ value>> ] [ type>> ] tri ; -M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) - tuck - [ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi - rot set-slot-named - [ [ key>> ] [ type>> ] bi ] dip - swap ; +M:: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array ) + generate-bind generator-singleton>> eval-generator :> obj + generate-bind slot-name>> :> name + obj name tuple set-slot-named + generate-bind key>> obj generate-bind type>> ; M: sqlite-statement bind-tuple ( tuple statement -- ) [ diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor index 9602933785..3401208858 100644 --- a/basis/fry/fry-docs.factor +++ b/basis/fry/fry-docs.factor @@ -59,7 +59,6 @@ $nl { { $link literalize } { $snippet ": literalize '[ _ ] ;" } } { { $link curry } { $snippet ": curry '[ _ @ ] ;" } } { { $link compose } { $snippet ": compose '[ @ @ ] ;" } } - { { $link bi@ } { $snippet ": bi@ tuck '[ _ @ _ @ ] call ;" } } } ; ARTICLE: "fry.philosophy" "Fried quotation philosophy" diff --git a/basis/game/input/input.factor b/basis/game/input/input.factor index 377a89a884..954602cf06 100755 --- a/basis/game/input/input.factor +++ b/basis/game/input/input.factor @@ -75,9 +75,8 @@ SYMBOLS: get-controllers [ product-id = ] with filter ; : find-controller-instance ( product-id instance-id -- controller/f ) get-controllers [ - tuck [ product-id = ] - [ instance-id = ] 2bi* and + [ instance-id = ] bi-curry bi* and ] with with find nip ; TUPLE: keyboard-state keys ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index e8af7144ad..e305c8477a 100644 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -295,7 +295,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; binary [ [ { HEX: FF } read-until - read1 tuck HEX: 00 = and + read1 [ HEX: 00 = and ] keep swap ] [ drop ] produce swap >marker { EOI } assert= diff --git a/basis/io/buffers/buffers-tests.factor b/basis/io/buffers/buffers-tests.factor index d366df7c54..93d2f5b2fc 100644 --- a/basis/io/buffers/buffers-tests.factor +++ b/basis/io/buffers/buffers-tests.factor @@ -8,7 +8,7 @@ strings accessors destructors ; [ length ] dip buffer-reset ; : string>buffer ( string -- buffer ) - dup length tuck buffer-set ; + dup length [ buffer-set ] keep ; : buffer-read-all ( buffer -- byte-array ) [ [ pos>> ] [ ptr>> ] bi ] diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 5ae21fcfee..6bd3f77ffa 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -151,12 +151,16 @@ PRIVATE> M: winnt file-system-info ( path -- file-system-info ) normalize-path root-directory (file-system-info) ; -: volume>paths ( string -- array ) - 16384 tuck dup length - 0 dup [ GetVolumePathNamesForVolumeName 0 = ] dip swap [ - win32-error-string throw +:: volume>paths ( string -- array ) + 16384 :> names-buf-length + names-buf-length :> names + 0 :> names-length + + string names names-buf-length names-length GetVolumePathNamesForVolumeName :> ret + ret 0 = [ + ret win32-error-string throw ] [ - *uint "ushort" heap-size * head + names names-length *uint "ushort" heap-size * head utf16n alien>string CHAR: \0 split ] if ; @@ -166,13 +170,16 @@ M: winnt file-system-info ( path -- file-system-info ) FindFirstVolume dup win32-error=0/f [ utf16n alien>string ] dip ; -: find-next-volume ( handle -- string/f ) - MAX_PATH 1 + [ tuck ] keep - FindNextVolume 0 = [ +:: find-next-volume ( handle -- string/f ) + MAX_PATH 1 + :> buf-length + buf-length :> buf + + handle buf buf-length FindNextVolume :> ret + ret 0 = [ GetLastError ERROR_NO_MORE_FILES = [ drop f ] [ win32-error-string throw ] if ] [ - utf16n alien>string + buf utf16n alien>string ] if ; : find-volumes ( -- array ) diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 6cae50bd9e..8a800115f6 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -132,7 +132,7 @@ M: windows run-process* ( process -- handle ) current-directory get absolute-path cd dup make-CreateProcess-args - tuck fill-redirection + [ fill-redirection ] keep dup call-CreateProcess lpProcessInformation>> ] with-destructors ; diff --git a/basis/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor index 7b386e9c81..57cacaa494 100644 --- a/basis/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -114,7 +114,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) + [ quot>> ] [ cons>> unswons ] bi over call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- ? ) diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index bc09f9fe0f..5c03e41870 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -96,9 +96,9 @@ C: combo initial-values [ over 0 > ] [ next-values ] produce [ 3drop ] dip ; -: combination-indices ( m combo -- seq ) - [ tuck dual-index combinadic ] keep - seq>> length 1 - swap [ - ] with map ; +:: combination-indices ( m combo -- seq ) + combo m combo dual-index combinadic + combo seq>> length 1 - swap [ - ] with map ; : apply-combination ( m combo -- seq ) [ combination-indices ] keep seq>> nths ; diff --git a/basis/math/intervals/intervals-tests.factor b/basis/math/intervals/intervals-tests.factor index 1ee4e1e100..a569b4af7b 100644 --- a/basis/math/intervals/intervals-tests.factor +++ b/basis/math/intervals/intervals-tests.factor @@ -79,7 +79,7 @@ IN: math.intervals.tests [ t ] [ 1 2 [a,b] dup empty-interval interval-union = ] unit-test -[ t ] [ empty-interval 1 2 [a,b] tuck interval-union = ] unit-test +[ t ] [ 1 2 [a,b] empty-interval over interval-union = ] unit-test [ t ] [ 0 1 (a,b) 0 1 [a,b] interval-union 0 1 [a,b] = @@ -250,7 +250,7 @@ IN: math.intervals.tests dup full-interval eq? [ drop 32 random-bits 31 2^ - ] [ - dup to>> first over from>> first tuck - random + + [ ] [ from>> first ] [ to>> first ] tri over - random + 2dup swap interval-contains? [ nip ] [ diff --git a/basis/persistent/vectors/vectors.factor b/basis/persistent/vectors/vectors.factor index 2527959f32..b02604e9bd 100644 --- a/basis/persistent/vectors/vectors.factor +++ b/basis/persistent/vectors/vectors.factor @@ -58,7 +58,7 @@ M: persistent-vector nth-unsafe [ 2array ] [ drop level>> 1 + ] 2bi node boa ; : new-child ( new-child node -- node' expansion/f ) - dup full? [ tuck level>> 1node ] [ node-add f ] if ; + dup full? [ [ level>> 1node ] keep swap ] [ node-add f ] if ; : new-last ( val seq -- seq' ) [ length 1 - ] keep new-nth ; @@ -70,7 +70,7 @@ M: persistent-vector nth-unsafe dup level>> 1 = [ new-child ] [ - tuck children>> last (ppush-new-tail) + [ nip ] 2keep children>> last (ppush-new-tail) [ swap new-child ] [ swap node-set-last f ] ?if ] if ; diff --git a/basis/regexp/dfa/dfa.factor b/basis/regexp/dfa/dfa.factor index 2de4e8b0e0..fa75232fd5 100644 --- a/basis/regexp/dfa/dfa.factor +++ b/basis/regexp/dfa/dfa.factor @@ -25,7 +25,7 @@ IN: regexp.dfa ] unless ; : epsilon-table ( states nfa -- table ) - [ H{ } clone tuck ] dip + [ [ H{ } clone ] dip over ] dip '[ _ _ t epsilon-loop ] each ; : find-epsilon-closure ( states nfa -- dfa-state ) diff --git a/basis/regexp/minimize/minimize.factor b/basis/regexp/minimize/minimize.factor index 1885144e6c..a6eb4f00a2 100644 --- a/basis/regexp/minimize/minimize.factor +++ b/basis/regexp/minimize/minimize.factor @@ -85,7 +85,7 @@ IN: regexp.minimize '[ _ delete-duplicates ] change-transitions ; : combine-state-transitions ( hash -- hash ) - H{ } clone tuck '[ + [ H{ } clone ] dip over '[ _ [ 2array ] change-at ] assoc-each [ swap ] assoc-map ; diff --git a/basis/suffix-arrays/suffix-arrays.factor b/basis/suffix-arrays/suffix-arrays.factor index 931cb36ea9..f486adcb32 100755 --- a/basis/suffix-arrays/suffix-arrays.factor +++ b/basis/suffix-arrays/suffix-arrays.factor @@ -22,8 +22,7 @@ IN: suffix-arrays : ( from/f to/f seq -- slice ) [ - tuck - [ drop 0 or ] [ length or ] 2bi* + [ drop 0 or ] [ length or ] bi-curry bi* [ min ] keep ] keep ; inline diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor index 089bad3158..936d388b01 100755 --- a/basis/tools/scaffold/scaffold.factor +++ b/basis/tools/scaffold/scaffold.factor @@ -98,7 +98,7 @@ M: bad-developer-name summary [ main-file-string ] dip utf8 set-file-contents ; : scaffold-main ( vocab-root vocab -- ) - tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [ + [ ".factor" vocab-root/vocab/suffix>path ] keep swap scaffolding? [ set-scaffold-main-file ] [ 2drop diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor index 11c2a48a2a..5a92a4cea2 100644 --- a/basis/ui/traverse/traverse.factor +++ b/basis/ui/traverse/traverse.factor @@ -20,8 +20,9 @@ TUPLE: node value children ; ] [ [ [ children>> swap first head-slice % ] - [ tuck traverse-step traverse-to-path ] - 2bi + [ nip ] + [ traverse-step traverse-to-path ] + 2tri ] make-node ] if ] if ; @@ -35,7 +36,9 @@ TUPLE: node value children ; ] [ [ [ traverse-step traverse-from-path ] - [ tuck children>> swap first 1 + tail-slice % ] 2bi + [ nip ] + [ children>> swap first 1 + tail-slice % ] + 2tri ] make-node ] if ] if ; diff --git a/basis/unix/groups/groups.factor b/basis/unix/groups/groups.factor index c4392c4c6d..02d9f37023 100644 --- a/basis/unix/groups/groups.factor +++ b/basis/unix/groups/groups.factor @@ -23,7 +23,7 @@ GENERIC: group-struct ( obj -- group/f ) gr_mem>> utf8 alien>strings ; : (group-struct) ( id -- group-struct id group-struct byte-array length void* ) - \ unix:group tuck 4096 + [ \ unix:group ] dip over 4096 [ ] keep f ; : check-group-struct ( group-struct ptr -- group-struct/f ) diff --git a/basis/xmode/catalog/catalog.factor b/basis/xmode/catalog/catalog.factor index 97de95a932..40b8e2191c 100644 --- a/basis/xmode/catalog/catalog.factor +++ b/basis/xmode/catalog/catalog.factor @@ -110,7 +110,7 @@ ERROR: mutually-recursive-rulesets ruleset ; dup [ glob-matches? ] [ 2drop f ] if ; : suitable-mode? ( file-name first-line mode -- ? ) - tuck first-line-glob>> ?glob-matches + [ nip ] 2keep first-line-glob>> ?glob-matches [ 2drop t ] [ file-name-glob>> ?glob-matches ] if ; : find-mode ( file-name first-line -- mode ) diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor index d3a4f1e9a2..6b8db76ac9 100755 --- a/basis/xmode/marker/marker.factor +++ b/basis/xmode/marker/marker.factor @@ -86,7 +86,7 @@ M: regexp text-matches? [ >string ] dip first-match dup [ to>> ] when ; : rule-start-matches? ( rule -- match-count/f ) - dup start>> tuck swap can-match-here? [ + [ start>> dup ] keep can-match-here? [ rest-of-line swap text>> text-matches? ] [ drop f @@ -96,7 +96,7 @@ M: regexp text-matches? dup mark-following-rule? [ dup start>> swap can-match-here? 0 and ] [ - dup end>> tuck swap can-match-here? [ + [ end>> dup ] keep can-match-here? [ rest-of-line swap text>> context get end>> or text-matches? @@ -170,7 +170,7 @@ M: seq-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck body-token>> next-token, + [ body-token>> next-token, ] keep delegate>> [ push-context ] when* ; UNION: abstract-span-rule span-rule eol-span-rule ; @@ -179,7 +179,7 @@ M: abstract-span-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep ! ... end subst ... dup context get (>>in-rule) delegate>> push-context ; @@ -190,7 +190,7 @@ M: span-rule handle-rule-end M: mark-following-rule handle-rule-start ?end-rule mark-token add-remaining-token - tuck rule-match-token* next-token, + [ rule-match-token* next-token, ] keep f context get (>>end) context get (>>in-rule) ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index f70d9d4214..7327285ffd 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -21,7 +21,6 @@ HELP: 2over $shuffle ; HELP: pick ( x y z -- x y z x ) $shuffle ; HELP: swap ( x y -- y x ) $shuffle ; -HELP: spin $complex-shuffle ; HELP: rot ( x y z -- y z x ) $complex-shuffle ; HELP: -rot ( x y z -- z x y ) $complex-shuffle ; HELP: dupd ( x y -- x x y ) $complex-shuffle ; @@ -828,7 +827,6 @@ $nl swapd rot -rot - spin } ; ARTICLE: "shuffle-words" "Shuffle words"