From e5ed7447eddd6e33e7537ed12ebec50207b37870 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 3 Dec 2008 08:46:16 -0600 Subject: [PATCH] Removing more >r/r> usages --- .../tree/cleanup/cleanup-tests.factor | 14 ++++----- .../tree/dead-code/dead-code-tests.factor | 4 +-- .../normalization/normalization-tests.factor | 4 +-- .../tree/propagation/propagation-tests.factor | 2 +- basis/cpu/x86/x86.factor | 6 ++-- basis/debugger/debugger-docs.factor | 4 +-- basis/help/markup/markup.factor | 2 +- basis/help/syntax/syntax.factor | 7 +++-- basis/html/elements/elements.factor | 2 +- basis/html/streams/streams.factor | 8 ++--- basis/interval-maps/interval-maps.factor | 2 +- basis/logging/analysis/analysis.factor | 8 ++--- basis/match/match.factor | 2 +- basis/math/geometry/rect/rect.factor | 4 +-- basis/models/history/history.factor | 2 +- basis/models/models.factor | 2 +- basis/multiline/multiline.factor | 2 +- basis/openssl/libssl/libssl.factor | 6 ++-- basis/peg/parsers/parsers.factor | 6 ++-- basis/peg/peg.factor | 10 +++---- basis/prettyprint/backend/backend.factor | 23 +++++++------- basis/prettyprint/prettyprint-tests.factor | 30 +------------------ basis/prettyprint/sections/sections.factor | 4 +-- basis/sequences/next/next.factor | 16 +++++----- basis/shuffle/shuffle-tests.factor | 1 + basis/shuffle/shuffle.factor | 2 +- basis/stack-checker/errors/errors-docs.factor | 3 +- basis/stack-checker/errors/errors.factor | 2 +- basis/threads/threads.factor | 18 +++++------ basis/tools/completion/completion.factor | 6 ++-- basis/tools/deploy/config/config.factor | 2 +- basis/tools/deploy/deploy-tests.factor | 7 ++--- basis/tools/memory/memory.factor | 11 +++---- basis/tools/profiler/profiler.factor | 2 +- basis/tools/test/test.factor | 16 +++++----- basis/tools/time/time.factor | 4 +-- basis/tools/vocabs/browser/browser.factor | 6 ++-- basis/tools/vocabs/vocabs.factor | 2 +- basis/unicode/case/case.factor | 2 +- basis/unicode/data/data.factor | 2 +- basis/unicode/normalize/normalize.factor | 15 ++++++---- 41 files changed, 120 insertions(+), 151 deletions(-) diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index 4a6198db37..71c6fb5675 100644 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -71,7 +71,7 @@ M: object xyz ; 2over fixnum>= [ 3drop ] [ - [ swap >r call 1 fixnum+fast r> ] keep (fx-repeat) + [ swap [ call 1 fixnum+fast ] dip ] keep (fx-repeat) ] if ; inline recursive : fx-repeat ( n quot -- ) @@ -87,10 +87,10 @@ M: object xyz ; 2over dup xyz drop >= [ 3drop ] [ - [ swap >r call 1+ r> ] keep (i-repeat) + [ swap [ call 1+ ] dip ] keep (i-repeat) ] if ; inline recursive -: i-repeat >r { integer } declare r> 0 -rot (i-repeat) ; inline +: i-repeat [ { integer } declare ] dip 0 -rot (i-repeat) ; inline [ t ] [ [ [ dup xyz drop ] i-repeat ] \ xyz inlined? @@ -194,7 +194,7 @@ M: fixnum annotate-entry-test-1 drop ; 2dup >= [ 2drop ] [ - >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2) + [ dup annotate-entry-test-1 1+ ] dip (annotate-entry-test-2) ] if ; inline recursive : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline @@ -448,7 +448,7 @@ cell-bits 32 = [ ] unit-test [ ] [ - [ [ >r "A" throw r> ] [ "B" throw ] if ] + [ [ [ "A" throw ] dip ] [ "B" throw ] if ] cleaned-up-tree drop ] unit-test @@ -463,7 +463,7 @@ cell-bits 32 = [ : buffalo-wings ( i seq -- ) 2dup < [ 2dup chicken-fingers - >r 1+ r> buffalo-wings + [ 1+ ] dip buffalo-wings ] [ 2drop ] if ; inline recursive @@ -482,7 +482,7 @@ cell-bits 32 = [ : ribs ( i seq -- ) 2dup < [ steak - >r 1+ r> ribs + [ 1+ ] dip ribs ] [ 2drop ] if ; inline recursive diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor index 7b15fdf856..b64e30d8f9 100644 --- a/basis/compiler/tree/dead-code/dead-code-tests.factor +++ b/basis/compiler/tree/dead-code/dead-code-tests.factor @@ -75,9 +75,9 @@ IN: compiler.tree.dead-code.tests remove-dead-code "no-check" get [ dup check-nodes ] unless nodes>quot ; -[ [ drop 1 ] ] [ [ >r 1 r> drop ] optimize-quot ] unit-test +[ [ drop 1 ] ] [ [ [ 1 ] dip drop ] optimize-quot ] unit-test -[ [ read drop 1 2 ] ] [ [ read >r 1 2 r> drop ] optimize-quot ] unit-test +[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test [ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test diff --git a/basis/compiler/tree/normalization/normalization-tests.factor b/basis/compiler/tree/normalization/normalization-tests.factor index c4a97fcc92..5ac3c57abe 100644 --- a/basis/compiler/tree/normalization/normalization-tests.factor +++ b/basis/compiler/tree/normalization/normalization-tests.factor @@ -34,8 +34,8 @@ sequences accessors tools.test kernel math ; [ ] [ [ [ 1 ] [ 2 ] if + * ] test-normalization ] unit-test DEFER: bbb -: aaa ( x -- ) dup [ dup >r bbb r> aaa ] [ drop ] if ; inline recursive -: bbb ( x -- ) >r drop 0 r> aaa ; inline recursive +: aaa ( x -- ) dup [ dup [ bbb ] dip aaa ] [ drop ] if ; inline recursive +: bbb ( x -- ) [ drop 0 ] dip aaa ; inline recursive [ ] [ [ bbb ] test-normalization ] unit-test diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 06412209ca..2c4769abe0 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -435,7 +435,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; ] unit-test : recursive-test-4 ( i n -- ) - 2dup < [ >r 1+ r> recursive-test-4 ] [ 2drop ] if ; inline recursive + 2dup < [ [ 1+ ] dip recursive-test-4 ] [ 2drop ] if ; inline recursive [ ] [ [ recursive-test-4 ] final-info drop ] unit-test diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index b7dffb849e..3dbcd2eabf 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -561,7 +561,7 @@ M: x86 %reload-float ( dst n -- ) spill-float@ MOVSD ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ; -M: int-regs %save-param-reg drop >r param@ r> MOV ; +M: int-regs %save-param-reg drop [ param@ ] dip MOV ; M: int-regs %load-param-reg drop swap param@ MOV ; GENERIC: MOVSS/D ( dst src reg-class -- ) @@ -569,8 +569,8 @@ GENERIC: MOVSS/D ( dst src reg-class -- ) M: single-float-regs MOVSS/D drop MOVSS ; M: double-float-regs MOVSS/D drop MOVSD ; -M: float-regs %save-param-reg >r >r param@ r> r> MOVSS/D ; -M: float-regs %load-param-reg >r swap param@ r> MOVSS/D ; +M: float-regs %save-param-reg [ param@ ] 2dip MOVSS/D ; +M: float-regs %load-param-reg [ swap param@ ] dip MOVSS/D ; GENERIC: push-return-reg ( reg-class -- ) GENERIC: load-return-reg ( n reg-class -- ) diff --git a/basis/debugger/debugger-docs.factor b/basis/debugger/debugger-docs.factor index fe00d011c3..30c9fd37ab 100644 --- a/basis/debugger/debugger-docs.factor +++ b/basis/debugger/debugger-docs.factor @@ -131,11 +131,11 @@ HELP: datastack-overflow. { $notes "This error usually indicates a run-away recursion, however if you legitimately need a data stack larger than the default, see " { $link "runtime-cli-args" } "." } ; HELP: retainstack-underflow. -{ $error-description "Thrown by the Factor VM if " { $link r> } " is called while the retain stack is empty." } +{ $error-description "Thrown by the Factor VM if an attempt is made to access the retain stack in an invalid manner. This bug should never come up in practice and indicates a bug in Factor." } { $notes "You can use the stack effect tool to statically check stack effects of quotations. See " { $link "inference" } "." } ; HELP: retainstack-overflow. -{ $error-description "Thrown by the Factor VM if " { $link >r } " is called when the retain stack is full." } +{ $error-description "Thrown by the Factor VM if " { $link dip } " is called when the retain stack is full." } { $notes "This error usually indicates a run-away recursion, however if you legitimately need a retain stack larger than the default, see " { $link "runtime-cli-args" } "." } ; HELP: memory-error. diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index 318169c0a0..a7501dc242 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -97,7 +97,7 @@ ALIAS: $slot $snippet [ snippet-style get [ last-element off - >r ($code-style) r> with-nesting + [ ($code-style) ] dip with-nesting ] with-style ] ($block) ; inline diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor index 42d5ba1781..9a372174ba 100644 --- a/basis/help/syntax/syntax.factor +++ b/basis/help/syntax/syntax.factor @@ -11,9 +11,10 @@ IN: help.syntax \ ; parse-until >array swap set-word-help ; parsing : ARTICLE: - location >r - \ ; parse-until >array [ first2 ] keep 2 tail
- over add-article >link r> remember-definition ; parsing + location [ + \ ; parse-until >array [ first2 ] keep 2 tail
+ over add-article >link + ] dip remember-definition ; parsing : ABOUT: in get vocab diff --git a/basis/html/elements/elements.factor b/basis/html/elements/elements.factor index 0ee6955e29..fa92f18d34 100644 --- a/basis/html/elements/elements.factor +++ b/basis/html/elements/elements.factor @@ -24,7 +24,7 @@ SYMBOL: html : html-word ( name def effect -- ) #! Define 'word creating' word to allow #! dynamically creating words. - >r >r elements-vocab create r> r> define-declared ; + [ elements-vocab create ] 2dip define-declared ; : ( str -- ) "<" swap ">" 3append ; diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index fa81a69bb4..709b65761e 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -77,7 +77,7 @@ TUPLE: html-sub-stream < html-stream style parent ; "font-family: " % % "; " % ; : apply-style ( style key quot -- style gadget ) - >r over at r> when* ; inline + [ over at ] dip when* ; inline : make-css ( style quot -- str ) "" make nip ; inline @@ -163,13 +163,13 @@ M: html-stream stream-flush stream>> stream-flush ; M: html-stream stream-write1 - >r 1string r> stream-write ; + [ 1string ] dip stream-write ; M: html-stream stream-write - not-a-div >r escape-string r> stream>> stream-write ; + not-a-div [ escape-string ] dip stream>> stream-write ; M: html-stream stream-format - >r html over at [ >r escape-string r> ] unless r> + [ html over at [ [ escape-string ] dip ] unless ] dip format-html-span ; M: html-stream stream-nl diff --git a/basis/interval-maps/interval-maps.factor b/basis/interval-maps/interval-maps.factor index 99da00ceab..34e43ddc75 100644 --- a/basis/interval-maps/interval-maps.factor +++ b/basis/interval-maps/interval-maps.factor @@ -15,7 +15,7 @@ TUPLE: interval-map array ; first2 between? ; : all-intervals ( sequence -- intervals ) - [ >r dup number? [ dup 2array ] when r> ] { } assoc-map-as ; + [ [ dup number? [ dup 2array ] when ] dip ] { } assoc-map-as ; : disjoint? ( node1 node2 -- ? ) [ second ] [ first ] bi* < ; diff --git a/basis/logging/analysis/analysis.factor b/basis/logging/analysis/analysis.factor index 1e1e31c501..d84e49f784 100644 --- a/basis/logging/analysis/analysis.factor +++ b/basis/logging/analysis/analysis.factor @@ -38,8 +38,8 @@ SYMBOL: message-histogram : histogram. ( assoc quot -- ) standard-table-style [ - >r >alist sort-values r> [ - [ >r swap r> with-cell pprint-cell ] with-row + [ >alist sort-values ] dip [ + [ swapd with-cell pprint-cell ] with-row ] curry assoc-each ] tabular-output ; @@ -69,7 +69,7 @@ SYMBOL: message-histogram errors. ; : analyze-log ( lines word-names -- ) - >r parse-log r> analyze-entries analysis. ; + [ parse-log ] dip analyze-entries analysis. ; : analyze-log-file ( service word-names -- ) - >r parse-log-file r> analyze-entries analysis. ; + [ parse-log-file ] dip analyze-entries analysis. ; diff --git a/basis/match/match.factor b/basis/match/match.factor index c546555d07..7d393dadc9 100644 --- a/basis/match/match.factor +++ b/basis/match/match.factor @@ -73,7 +73,7 @@ MACRO: match-cond ( assoc -- ) 2dup [ length ] bi@ < [ 2drop f f ] [ 2dup length head over match - [ nip swap ?1-tail ] [ >r rest r> (match-first) ] if* + [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if* ] if ; : match-first ( seq pattern-seq -- bindings ) diff --git a/basis/math/geometry/rect/rect.factor b/basis/math/geometry/rect/rect.factor index dd634f4a3b..a7cefceae8 100644 --- a/basis/math/geometry/rect/rect.factor +++ b/basis/math/geometry/rect/rect.factor @@ -37,7 +37,7 @@ M: rect rect-dim dim>> ; over rect-loc v+ swap rect-dim ; : (rect-intersect) ( rect rect -- array array ) - 2rect-extent vmin >r vmax r> ; + 2rect-extent [ vmax ] [ vmin ] 2bi* ; : rect-intersect ( rect1 rect2 -- newrect ) (rect-intersect) ; @@ -46,7 +46,7 @@ M: rect rect-dim dim>> ; (rect-intersect) [v-] { 0 0 } = ; : (rect-union) ( rect rect -- array array ) - 2rect-extent vmax >r vmin r> ; + 2rect-extent [ vmin ] [ vmax ] 2bi* ; : rect-union ( rect1 rect2 -- newrect ) (rect-union) ; diff --git a/basis/models/history/history.factor b/basis/models/history/history.factor index caf6f39d5c..90d6b594ff 100644 --- a/basis/models/history/history.factor +++ b/basis/models/history/history.factor @@ -18,7 +18,7 @@ TUPLE: history < model back forward ; : go-back/forward ( history to from -- ) [ 2drop ] - [ >r dupd (add-history) r> pop swap set-model ] if-empty ; + [ [ dupd (add-history) ] dip pop swap set-model ] if-empty ; : go-back ( history -- ) dup [ forward>> ] [ back>> ] bi go-back/forward ; diff --git a/basis/models/models.factor b/basis/models/models.factor index 45519f7021..5da564b9d0 100644 --- a/basis/models/models.factor +++ b/basis/models/models.factor @@ -91,7 +91,7 @@ M: model update-model drop ; ] if ; : ((change-model)) ( model quot -- newvalue model ) - over >r >r value>> r> call r> ; inline + over [ [ value>> ] dip call ] dip ; inline : change-model ( model quot -- ) ((change-model)) set-model ; inline diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor index ecbe9e668f..64d4b1a041 100644 --- a/basis/multiline/multiline.factor +++ b/basis/multiline/multiline.factor @@ -28,7 +28,7 @@ PRIVATE> : (parse-multiline-string) ( start-index end-text -- end-index ) lexer get line-text>> [ 2dup start - [ rot dupd >r >r swap subseq % r> r> length + ] [ + [ rot dupd [ swap subseq % ] 2dip length + ] [ rot tail % "\n" % 0 lexer get next-line swap (parse-multiline-string) ] if* diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index f1dc21f993..30501a6105 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -234,13 +234,13 @@ FUNCTION: void SSL_CTX_set_tmp_rsa_callback ( SSL_CTX* ctx, void* rsa ) ; FUNCTION: void* BIO_f_ssl ( ) ; : SSL_CTX_set_tmp_rsa ( ctx rsa -- n ) - >r SSL_CTRL_SET_TMP_RSA 0 r> SSL_CTX_ctrl ; + [ SSL_CTRL_SET_TMP_RSA 0 ] dip SSL_CTX_ctrl ; : SSL_CTX_set_tmp_dh ( ctx dh -- n ) - >r SSL_CTRL_SET_TMP_DH 0 r> SSL_CTX_ctrl ; + [ SSL_CTRL_SET_TMP_DH 0 ] dip SSL_CTX_ctrl ; : SSL_CTX_set_session_cache_mode ( ctx mode -- n ) - >r SSL_CTRL_SET_SESS_CACHE_MODE r> f SSL_CTX_ctrl ; + [ SSL_CTRL_SET_SESS_CACHE_MODE ] dip f SSL_CTX_ctrl ; : SSL_SESS_CACHE_OFF HEX: 0000 ; inline : SSL_SESS_CACHE_CLIENT HEX: 0001 ; inline diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor index af1b4aec04..7434ca6a7a 100644 --- a/basis/peg/parsers/parsers.factor +++ b/basis/peg/parsers/parsers.factor @@ -24,7 +24,7 @@ M: just-parser (compile) ( parser -- quot ) : 1token ( ch -- parser ) 1string token ; : (list-of) ( items separator repeat1? -- parser ) - >r over 2seq r> [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq + [ over 2seq ] dip [ repeat1 ] [ repeat0 ] if [ concat ] action 2seq [ unclip 1vector swap first append ] action ; : list-of ( items separator -- parser ) @@ -60,11 +60,11 @@ PRIVATE> [ flatten-vectors ] action ; : from-m-to-n ( parser m n -- parser' ) - >r [ exactly-n ] 2keep r> swap - at-most-n 2seq + [ [ exactly-n ] 2keep ] dip swap - at-most-n 2seq [ flatten-vectors ] action ; : pack ( begin body end -- parser ) - >r >r hide r> r> hide 3seq [ first ] action ; + [ hide ] 2dip hide 3seq [ first ] action ; : surrounded-by ( parser begin end -- parser' ) [ token ] bi@ swapd pack ; diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor index 2dabf1edf7..1fb5909bcf 100644 --- a/basis/peg/peg.factor +++ b/basis/peg/peg.factor @@ -146,8 +146,8 @@ TUPLE: peg-head rule-id involved-set eval-set ; pos set dup involved-set>> clone >>eval-set drop ; : (grow-lr) ( h p r: ( -- result ) m -- ) - >r >r [ setup-growth ] 2keep r> r> - >r dup eval-rule r> swap + [ [ setup-growth ] 2keep ] 2dip + [ dup eval-rule ] dip swap dup pick stop-growth? [ 5 ndrop ] [ @@ -156,8 +156,8 @@ TUPLE: peg-head rule-id involved-set eval-set ; ] if ; inline recursive : grow-lr ( h p r m -- ast ) - >r >r [ heads set-at ] 2keep r> r> - pick over >r >r (grow-lr) r> r> + [ [ heads set-at ] 2keep ] 2dip + pick over [ (grow-lr) ] 2dip swap heads delete-at dup pos>> pos set ans>> ; inline @@ -352,7 +352,7 @@ TUPLE: token-parser symbol ; [ ?head-slice ] keep swap [ f f add-error ] [ - >r drop pos get "token '" r> append "'" append 1vector add-error f + [ drop pos get "token '" ] dip append "'" append 1vector add-error f ] if ; M: token-parser (compile) ( peg -- quot ) diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index f1fd749666..7a5b16a3c2 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -21,9 +21,6 @@ M: effect pprint* effect>string "(" swap ")" 3append text ; : ?end-group ( word -- ) ?effect-height 0 < [ end-group ] when ; -\ >r hard "break-before" set-word-prop -\ r> hard "break-after" set-word-prop - ! Atoms : word-style ( word -- style ) dup "word-style" word-prop >hashtable [ @@ -93,7 +90,7 @@ M: f pprint* drop \ f pprint-word ; ] H{ } make-assoc ; : unparse-string ( str prefix suffix -- str ) - [ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ; + [ [ % do-string-limit [ unparse-ch ] each ] dip % ] "" make ; : pprint-string ( obj str prefix suffix -- ) unparse-string swap string-style styled-text ; @@ -156,13 +153,13 @@ M: tuple pprint* : do-length-limit ( seq -- trimmed n/f ) length-limit get dup [ over length over [-] - dup zero? [ 2drop f ] [ >r head r> ] if + dup zero? [ 2drop f ] [ [ head ] dip ] if ] when ; : pprint-elements ( seq -- ) - do-length-limit >r - [ pprint* ] each - r> [ "~" swap number>string " more~" 3append text ] when* ; + do-length-limit + [ [ pprint* ] each ] dip + [ "~" swap number>string " more~" 3append text ] when* ; GENERIC: pprint-delims ( obj -- start end ) @@ -206,10 +203,12 @@ M: tuple pprint-narrow? drop t ; : pprint-object ( obj -- ) [ r pprint-word - dup pprint-narrow? pprint-sequence pprint-elements - block> r> pprint-word block> + dup pprint-delims [ + pprint-word + dup pprint-narrow? pprint-sequence pprint-elements + block> + ] dip pprint-word block> ] check-recursion ; M: object pprint* pprint-object ; diff --git a/basis/prettyprint/prettyprint-tests.factor b/basis/prettyprint/prettyprint-tests.factor index 96698fc18f..648c707967 100644 --- a/basis/prettyprint/prettyprint-tests.factor +++ b/basis/prettyprint/prettyprint-tests.factor @@ -135,20 +135,6 @@ M: object method-layout ; [ \ method-layout see-methods ] with-string-writer "\n" split ] unit-test -: retain-stack-test - { - "USING: io kernel sequences words ;" - "IN: prettyprint.tests" - ": retain-stack-layout ( x -- )" - " dup stream-readln stream-readln" - " >r [ define ] map r>" - " define ;" - } ; - -[ t ] [ - "retain-stack-layout" retain-stack-test check-see -] unit-test - : soft-break-test { "USING: kernel math sequences strings ;" @@ -164,19 +150,6 @@ M: object method-layout ; "soft-break-layout" soft-break-test check-see ] unit-test -: another-retain-layout-test - { - "USING: kernel sequences ;" - "IN: prettyprint.tests" - ": another-retain-layout ( seq1 seq2 quot -- newseq )" - " -rot 2dup dupd min-length [ each drop roll ] map" - " >r 3drop r> ; inline" - } ; - -[ t ] [ - "another-retain-layout" another-retain-layout-test check-see -] unit-test - DEFER: parse-error-file : another-soft-break-test @@ -219,8 +192,7 @@ DEFER: parse-error-file "USING: kernel sequences ;" "IN: prettyprint.tests" ": final-soft-break-layout ( class dim -- view )" - " >r \"alloc\" send 0 0 r>" - " first2 " + " [ \"alloc\" send 0 0 ] dip first2 " " \"initWithFrame:pixelFormat:\" send" " dup 1 \"setPostsBoundsChangedNotifications:\" send" " dup 1 \"setPostsFrameChangedNotifications:\" send ;" diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor index a629ca6fff..102d005f39 100644 --- a/basis/prettyprint/sections/sections.factor +++ b/basis/prettyprint/sections/sections.factor @@ -42,7 +42,7 @@ TUPLE: pprinter last-newline line-count indent ; : text-fits? ( len -- ? ) margin get dup zero? - [ 2drop t ] [ >r pprinter get indent>> + r> <= ] if ; + [ 2drop t ] [ [ pprinter get indent>> + ] dip <= ] if ; ! break only if position margin 2 / > SYMBOL: soft @@ -189,7 +189,7 @@ M: block short-section ( block -- ) : empty-block? ( block -- ? ) sections>> empty? ; : if-nonempty ( block quot -- ) - >r dup empty-block? [ drop ] r> if ; inline + [ dup empty-block? [ drop ] ] dip if ; inline : (r dup length swap r> ; inline +: iterate-seq [ dup length swap ] dip ; inline : (map-next) ( i seq quot -- ) ! this uses O(n) more bounds checks than is really necessary - >r [ >r 1+ r> ?nth ] 2keep nth-unsafe r> call ; inline + [ [ [ 1+ ] dip ?nth ] 2keep nth-unsafe ] dip call ; inline PRIVATE> -: each-next ( seq quot -- ) - ! quot: next-elt elt -- +: each-next ( seq quot: ( next-elt elt -- ) -- ) iterate-seq [ (map-next) ] 2curry each-integer ; inline -: map-next ( seq quot -- newseq ) - ! quot: next-elt elt -- newelt - over dup length swap new-sequence >r - iterate-seq [ (map-next) ] 2curry - r> [ collect ] keep ; inline +: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq ) + over dup length swap new-sequence [ + iterate-seq [ (map-next) ] 2curry + ] dip [ collect ] keep ; inline diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index b5168b903c..f190544e19 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -2,3 +2,4 @@ USING: shuffle tools.test ; [ 8 ] [ 5 6 7 8 3nip ] unit-test [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test +[ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index 9a0dfe0e88..b195e4abf9 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -4,7 +4,7 @@ USING: kernel generalizations ; IN: shuffle -: 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline +: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline : nipd ( a b c -- b c ) rot drop ; inline diff --git a/basis/stack-checker/errors/errors-docs.factor b/basis/stack-checker/errors/errors-docs.factor index f4d7c80e13..d4a074031d 100644 --- a/basis/stack-checker/errors/errors-docs.factor +++ b/basis/stack-checker/errors/errors-docs.factor @@ -115,7 +115,6 @@ ARTICLE: "inference-errors" "Inference warnings and errors" { $subsection inconsistent-recursive-call-error } "Retain stack usage errors:" { $subsection too-many->r } -{ $subsection too-many-r> } -"See " { $link "shuffle-words" } " for retain stack usage conventions. This error can only occur if your code calls " { $link >r } " and " { $link r> } " directly. The " { $link dip } " combinator is safer to use because there is no way to leave the retain stack in an unbalanced state." ; +{ $subsection too-many-r> } ; ABOUT: "inference-errors" diff --git a/basis/stack-checker/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 31ae0a6789..5b6b3c0893 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -13,7 +13,7 @@ M: inference-error compiler-error-type type>> ; M: inference-error error-help error>> error-help ; : (inference-error) ( ... class type -- * ) - >r boa r> + [ boa ] dip recursive-state get word>> \ inference-error boa throw ; inline diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 4332bbbcf5..1e04ad88c2 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -4,7 +4,7 @@ USING: arrays hashtables heaps kernel kernel.private math namespaces sequences vectors continuations continuations.private dlists assocs system combinators init boxes accessors -math.order deques strings quotations ; +math.order deques strings quotations fry ; IN: threads SYMBOL: initial-thread @@ -101,7 +101,7 @@ DEFER: stop r check-registered dup r> sleep-queue heap-push* + [ check-registered dup ] dip sleep-queue heap-push* >>sleep-entry drop ; : expire-sleep? ( heap -- ? ) @@ -164,10 +164,8 @@ PRIVATE> : suspend ( quot state -- obj ) [ - >r - >r self swap call - r> self (>>state) - r> self continuation>> >box + [ [ self swap call ] dip self (>>state) ] dip + self continuation>> >box next ] callcc1 2nip ; inline @@ -176,7 +174,7 @@ PRIVATE> GENERIC: sleep-until ( time/f -- ) M: integer sleep-until - [ schedule-sleep ] curry "sleep" suspend drop ; + '[ _ schedule-sleep ] "sleep" suspend drop ; M: f sleep-until drop [ drop ] "interrupt" suspend drop ; @@ -200,11 +198,11 @@ M: real sleep [ (spawn) ] keep ; : spawn-server ( quot name -- thread ) - >r [ loop ] curry r> spawn ; + [ '[ _ loop ] ] dip spawn ; : in-thread ( quot -- ) - >r datastack r> - [ >r set-datastack r> call ] 2curry + [ datastack ] dip + '[ _ set-datastack _ call ] "Thread" spawn drop ; GENERIC: error-in-thread ( error thread -- ) diff --git a/basis/tools/completion/completion.factor b/basis/tools/completion/completion.factor index 2306ff53a8..084b97970d 100644 --- a/basis/tools/completion/completion.factor +++ b/basis/tools/completion/completion.factor @@ -33,8 +33,8 @@ IN: tools.completion { { [ over zero? ] [ 2drop 10 ] } { [ 2dup length 1- number= ] [ 2drop 4 ] } - { [ 2dup >r 1- r> nth Letter? not ] [ 2drop 10 ] } - { [ 2dup >r 1+ r> nth Letter? not ] [ 2drop 4 ] } + { [ 2dup [ 1- ] dip nth Letter? not ] [ 2drop 10 ] } + { [ 2dup [ 1+ ] dip nth Letter? not ] [ 2drop 4 ] } [ 2drop 1 ] } cond ; @@ -67,7 +67,7 @@ IN: tools.completion over empty? [ nip [ first ] map ] [ - >r >lower r> [ completion ] with map + [ >lower ] dip [ completion ] with map rank-completions ] if ; diff --git a/basis/tools/deploy/config/config.factor b/basis/tools/deploy/config/config.factor index c78e0a32ba..84bfab682b 100644 --- a/basis/tools/deploy/config/config.factor +++ b/basis/tools/deploy/config/config.factor @@ -76,7 +76,7 @@ SYMBOL: deploy-image parse-fresh [ first assoc-union ] unless-empty ; : set-deploy-config ( assoc vocab -- ) - >r unparse-use string-lines r> + [ unparse-use string-lines ] dip dup deploy-config-path set-vocab-file-contents ; : set-deploy-flag ( value key vocab -- ) diff --git a/basis/tools/deploy/deploy-tests.factor b/basis/tools/deploy/deploy-tests.factor index a44f7e1f89..e3fd9b9a7c 100644 --- a/basis/tools/deploy/deploy-tests.factor +++ b/basis/tools/deploy/deploy-tests.factor @@ -7,13 +7,12 @@ urls math.parser ; : shake-and-bake ( vocab -- ) [ "test.image" temp-file delete-file ] ignore-errors "resource:" [ - >r vm - "test.image" temp-file - r> dup deploy-config make-deploy-image + [ vm "test.image" temp-file ] dip + dup deploy-config make-deploy-image ] with-directory ; : small-enough? ( n -- ? ) - >r "test.image" temp-file file-info size>> r> cell 4 / * <= ; + [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ; [ ] [ "hello-world" shake-and-bake ] unit-test diff --git a/basis/tools/memory/memory.factor b/basis/tools/memory/memory.factor index f61694da78..70f9a10a51 100644 --- a/basis/tools/memory/memory.factor +++ b/basis/tools/memory/memory.factor @@ -3,7 +3,7 @@ USING: kernel sequences vectors arrays generic assocs io math namespaces parser prettyprint strings io.styles vectors words system sorting splitting grouping math.parser classes memory -combinators ; +combinators fry ; IN: tools.memory @@ -71,7 +72,7 @@ PRIVATE> : heap-stats ( -- counts sizes ) H{ } clone H{ } clone - [ >r 2dup r> heap-stat-step ] each-object ; + 2dup '[ _ _ heap-stat-step ] each-object ; : heap-stats. ( -- ) heap-stats dup keys natural-sort standard-table-style [ diff --git a/basis/tools/profiler/profiler.factor b/basis/tools/profiler/profiler.factor index b7f7ae97a6..f21e8498eb 100644 --- a/basis/tools/profiler/profiler.factor +++ b/basis/tools/profiler/profiler.factor @@ -34,7 +34,7 @@ M: method-body (profile.) : counter. ( obj n -- ) [ - >r [ (profile.) ] with-cell r> + [ [ (profile.) ] with-cell ] dip [ number>string write ] with-cell ] with-row ; diff --git a/basis/tools/test/test.factor b/basis/tools/test/test.factor index 73b261bf13..080db86338 100644 --- a/basis/tools/test/test.factor +++ b/basis/tools/test/test.factor @@ -3,7 +3,7 @@ USING: accessors namespaces arrays prettyprint sequences kernel vectors quotations words parser assocs combinators continuations debugger io io.styles io.files vocabs vocabs.loader source-files -compiler.units summary stack-checker effects tools.vocabs ; +compiler.units summary stack-checker effects tools.vocabs fry ; IN: tools.test SYMBOL: failures @@ -26,24 +26,22 @@ SYMBOL: this-test ] if ; : unit-test ( output input -- ) - [ 2array ] 2keep [ - { } swap with-datastack swap >array assert= - ] 2curry (unit-test) ; + [ 2array ] 2keep '[ + _ { } _ with-datastack swap >array assert= + ] (unit-test) ; : short-effect ( effect -- pair ) [ in>> length ] [ out>> length ] bi 2array ; : must-infer-as ( effect quot -- ) - >r 1quotation r> [ infer short-effect ] curry unit-test ; + [ 1quotation ] dip '[ _ infer short-effect ] unit-test ; : must-infer ( word/quot -- ) dup word? [ 1quotation ] when - [ infer drop ] curry [ ] swap unit-test ; + '[ _ infer drop ] [ ] swap unit-test ; : must-fail-with ( quot pred -- ) - >r [ f ] compose r> - [ recover ] 2curry - [ t ] swap unit-test ; + [ '[ @ f ] ] dip '[ _ _ recover ] [ t ] swap unit-test ; : must-fail ( quot -- ) [ drop t ] must-fail-with ; diff --git a/basis/tools/time/time.factor b/basis/tools/time/time.factor index 1672017fc4..58fc531623 100644 --- a/basis/tools/time/time.factor +++ b/basis/tools/time/time.factor @@ -5,7 +5,7 @@ namespaces system sequences splitting grouping assocs strings ; IN: tools.time : benchmark ( quot -- runtime ) - micros >r call micros r> - ; inline + micros [ call micros ] dip - ; inline : time. ( data -- ) unclip @@ -37,4 +37,4 @@ IN: tools.time ] bi* ; : time ( quot -- ) - gc-reset micros >r call gc-stats micros r> - prefix time. ; inline + gc-reset micros [ call gc-stats micros ] dip - prefix time. ; inline diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor index cfc541d9bc..4cd5653ab4 100644 --- a/basis/tools/vocabs/browser/browser.factor +++ b/basis/tools/vocabs/browser/browser.factor @@ -250,9 +250,9 @@ C: vocab-author : keyed-vocabs ( str quot -- seq ) all-vocabs [ - swap >r - [ >r 2dup r> swap call member? ] filter - r> swap + swap [ + [ [ 2dup ] dip swap call member? ] filter + ] dip swap ] assoc-map 2nip ; inline : tagged ( tag -- assoc ) diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index d926b67078..ef0c74d7c8 100644 --- a/basis/tools/vocabs/vocabs.factor +++ b/basis/tools/vocabs/vocabs.factor @@ -203,7 +203,7 @@ M: vocab summary M: vocab-link summary vocab-summary ; : set-vocab-summary ( string vocab -- ) - >r 1array r> + [ 1array ] dip dup vocab-summary-path set-vocab-file-contents ; diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 3def7b5f48..932f72960a 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -5,7 +5,7 @@ unicode.normalize math unicode.categories combinators assocs strings splitting kernel accessors ; IN: unicode.case -: at-default ( key assoc -- value/key ) over >r at r> or ; +: at-default ( key assoc -- value/key ) [ at ] [ drop ] 2bi or ; : ch>lower ( ch -- lower ) simple-lower at-default ; : ch>upper ( ch -- upper ) simple-upper at-default ; diff --git a/basis/unicode/data/data.factor b/basis/unicode/data/data.factor index 31d0be799f..80cf40fbf1 100644 --- a/basis/unicode/data/data.factor +++ b/basis/unicode/data/data.factor @@ -49,7 +49,7 @@ VALUE: properties : (process-data) ( index data -- newdata ) filter-comments [ [ nth ] keep first swap ] with { } map>assoc - [ >r hex> r> ] assoc-map ; + [ [ hex> ] dip ] assoc-map ; : process-data ( index data -- hash ) (process-data) [ hex> ] assoc-map [ nip ] assoc-filter >hashtable ; diff --git a/basis/unicode/normalize/normalize.factor b/basis/unicode/normalize/normalize.factor index 8d6f6e888a..35bdda67f0 100644 --- a/basis/unicode/normalize/normalize.factor +++ b/basis/unicode/normalize/normalize.factor @@ -27,14 +27,17 @@ IN: unicode.normalize : hangul>jamo ( hangul -- jamo-string ) hangul-base - final-count /mod final-base + - >r medial-count /mod medial-base + - >r initial-base + r> r> + [ + medial-count /mod medial-base + + [ initial-base + ] dip + ] dip dup final-base = [ drop 2array ] [ 3array ] if ; : jamo>hangul ( initial medial final -- hangul ) - >r >r initial-base - medial-count * - r> medial-base - + final-count * - r> final-base - + hangul-base + ; + [ + [ initial-base - medial-count * ] dip + medial-base - + final-count * + ] dip final-base - + hangul-base + ; ! Normalization -- Decomposition @@ -45,7 +48,7 @@ IN: unicode.normalize : reorder-next ( string i -- new-i done? ) over [ non-starter? ] find-from drop [ reorder-slice - >r dup [ combining-class ] insertion-sort to>> r> + [ dup [ combining-class ] insertion-sort to>> ] dip ] [ length t ] if* ; : reorder-loop ( string start -- ) -- 2.34.1