From 3c859a77bfe8fdeea191c4132768f7928aa4f0b1 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 18 Feb 2009 01:56:54 +0100 Subject: [PATCH 1/7] Simplify most --- core/kernel/kernel.factor | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 06fe289281..697000920a 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -185,8 +185,7 @@ PRIVATE> : either? ( x y quot -- ? ) bi@ or ; inline -: most ( x y quot -- z ) - [ 2dup ] dip call [ drop ] [ nip ] if ; inline +: most ( x y quot -- z ) 2keep ? ; inline ! Loops : loop ( pred: ( -- ? ) -- ) From 087d931c36ebdc60fafd0c02e77486ea95d289bb Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 18 Feb 2009 02:19:49 +0100 Subject: [PATCH 2/7] Remove the tail argument from do/until/while --- basis/bit-arrays/bit-arrays.factor | 2 +- .../tree/propagation/propagation-tests.factor | 2 +- basis/concurrency/mailboxes/mailboxes.factor | 2 +- basis/deques/deques.factor | 2 +- basis/formatting/formatting.factor | 2 +- basis/io/monitors/monitors-tests.factor | 4 ++-- basis/io/pools/pools.factor | 2 +- basis/io/thread/thread.factor | 2 +- basis/math/functions/functions.factor | 2 +- basis/math/primes/factors/factors.factor | 4 ++-- basis/math/primes/primes.factor | 2 +- basis/random/random.factor | 2 +- basis/stack-checker/stack-checker-tests.factor | 2 +- basis/threads/threads.factor | 2 +- basis/tools/walker/walker.factor | 6 +++--- basis/ui/event-loop/event-loop.factor | 2 +- basis/ui/tools/interactor/interactor-tests.factor | 2 +- basis/ui/ui.factor | 2 +- core/io/io.factor | 2 +- core/kernel/kernel-docs.factor | 12 +++--------- core/kernel/kernel.factor | 12 ++++++------ core/math/integers/integers.factor | 4 ++-- core/sequences/sequences.factor | 2 +- core/slots/slots.factor | 2 +- core/sorting/sorting.factor | 2 +- extra/adsoda/adsoda.factor | 2 +- extra/bubble-chamber/bubble-chamber.factor | 8 ++++---- extra/graph-theory/graph-theory.factor | 2 +- extra/irc/ui/ui.factor | 2 +- extra/otug-talk/otug-talk.factor | 2 +- extra/project-euler/012/012.factor | 2 +- extra/project-euler/014/014.factor | 2 +- extra/project-euler/100/100.factor | 2 +- unmaintained/combinators-lib/lib.factor | 7 ++----- 34 files changed, 50 insertions(+), 59 deletions(-) diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 3da22e09d6..e7dd6695a7 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -78,7 +78,7 @@ M: bit-array byte-length length 7 + -3 shift ; [ dup 0 = ] [ [ pick underlying>> pick set-alien-unsigned-1 ] keep [ 1+ ] [ -8 shift ] bi* - ] [ ] until 2drop + ] until 2drop ] if ; : bit-array>integer ( bit-array -- n ) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index b9a88de34a..f261b8747f 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -441,7 +441,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test -[ V{ real } ] [ [ [ dup 10 < ] [ ] [ ] while ] final-classes ] unit-test +[ V{ real } ] [ [ [ dup 10 < ] while ] final-classes ] unit-test [ V{ float } ] [ [ { float } declare 10 [ 2.3 * ] times ] final-classes diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 656fbbb591..6dcf3dc34f 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -57,7 +57,7 @@ M: mailbox dispose* threads>> notify-all ; f mailbox-get-all-timeout ; : while-mailbox-empty ( mailbox quot -- ) - [ '[ _ mailbox-empty? ] ] dip [ ] while ; inline + [ '[ _ mailbox-empty? ] ] dip while ; inline : mailbox-get-timeout? ( mailbox timeout pred -- obj ) [ block-unless-pred ] diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor index 73769cc4d2..1e1be404a7 100644 --- a/basis/deques/deques.factor +++ b/basis/deques/deques.factor @@ -36,6 +36,6 @@ GENERIC: deque-empty? ( deque -- ? ) : slurp-deque ( deque quot -- ) [ drop '[ _ deque-empty? not ] ] [ '[ _ pop-back @ ] ] - 2bi [ ] while ; inline + 2bi while ; inline MIXIN: deque diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor index 5a1e3650fe..ac0b0850b4 100644 --- a/basis/formatting/formatting.factor +++ b/basis/formatting/formatting.factor @@ -41,7 +41,7 @@ IN: formatting [ dup 10.0 >= [ 10.0 / [ 1+ ] dip ] [ 10.0 * [ 1- ] dip ] if - ] [ ] while + ] while ] keep 0 < [ neg ] when ; : exp>string ( exp base digits -- string ) diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index 8252b6ef72..576ac7ca30 100644 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -101,13 +101,13 @@ os { winnt linux macosx } member? [ ! Non-recursive [ ] [ "monitor-timeout-test" temp-file f "m" set ] unit-test [ ] [ 3 seconds "m" get set-timeout ] unit-test - [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail + [ [ t ] [ "m" get next-change drop ] while ] must-fail [ ] [ "m" get dispose ] unit-test ! Recursive [ ] [ "monitor-timeout-test" temp-file t "m" set ] unit-test [ ] [ 3 seconds "m" get set-timeout ] unit-test - [ [ t ] [ "m" get next-change drop ] [ ] while ] must-fail + [ [ t ] [ "m" get next-change drop ] while ] must-fail [ ] [ "m" get dispose ] unit-test ] with-monitors ] when diff --git a/basis/io/pools/pools.factor b/basis/io/pools/pools.factor index 2c1f8ea3c3..e03bdeabf9 100644 --- a/basis/io/pools/pools.factor +++ b/basis/io/pools/pools.factor @@ -35,7 +35,7 @@ GENERIC: make-connection ( pool -- conn ) : acquire-connection ( pool -- conn ) dup check-pool - [ dup connections>> empty? ] [ dup new-connection ] [ ] while + [ dup connections>> empty? ] [ dup new-connection ] while connections>> pop ; : (with-pooled-connection) ( conn pool quot -- ) diff --git a/basis/io/thread/thread.factor b/basis/io/thread/thread.factor index 7589d4918e..88db135f44 100644 --- a/basis/io/thread/thread.factor +++ b/basis/io/thread/thread.factor @@ -11,7 +11,7 @@ SYMBOL: io-thread-running? sleep-time io-multiplex yield ; : start-io-thread ( -- ) - [ [ io-thread-running? get-global ] [ io-thread ] [ ] while ] + [ [ io-thread-running? get-global ] [ io-thread ] while ] "I/O wait" spawn drop ; [ diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 85b4d711ac..605744b65f 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -39,7 +39,7 @@ M: real sqrt : factor-2s ( n -- r s ) #! factor an integer into 2^r * s dup 0 = [ 1 ] [ - 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while + 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while ] if ; inline : group-factors ( n -- seq ) [ 2 - [ 2dup sq < ] [ write-factor next-prime ] [ ] until + [ 2dup sq < ] [ write-factor next-prime ] until drop dup 2 < [ drop ] [ 1 2array , ] if ] { } make ; diff --git a/basis/math/primes/primes.factor b/basis/math/primes/primes.factor index 807ebf097b..688fdad713 100644 --- a/basis/math/primes/primes.factor +++ b/basis/math/primes/primes.factor @@ -21,7 +21,7 @@ PRIVATE> } cond ; foldable : next-prime ( n -- p ) - next-odd [ dup really-prime? ] [ 2 + ] [ ] until ; foldable + next-odd [ dup really-prime? ] [ 2 + ] until ; foldable : primes-between ( low high -- seq ) [ dup 3 max dup even? [ 1 + ] when ] dip diff --git a/basis/random/random.factor b/basis/random/random.factor index 17bcc8f1b1..26b328b291 100755 --- a/basis/random/random.factor +++ b/basis/random/random.factor @@ -55,7 +55,7 @@ PRIVATE> : randomize ( seq -- seq ) dup length [ dup 1 > ] [ [ random ] [ 1- ] bi [ pick exchange ] keep ] - [ ] while drop ; + while drop ; : delete-random ( seq -- elt ) [ length random-integer ] keep [ nth ] 2keep delete-nth ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index bc6eb9f092..6cfe80dbf6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -513,7 +513,7 @@ ERROR: custom-error ; ! Corner case [ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail -[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail +[ [ [ f dup ] while ] infer ] must-fail : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline diff --git a/basis/threads/threads.factor b/basis/threads/threads.factor index 305ef0cca3..e168653f1d 100644 --- a/basis/threads/threads.factor +++ b/basis/threads/threads.factor @@ -115,7 +115,7 @@ DEFER: stop sleep-queue [ dup expire-sleep? ] [ dup heap-pop drop expire-sleep ] - [ ] while + while drop ; : start ( namestack thread -- ) diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 8915d2d611..119a2e8587 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -205,7 +205,7 @@ SYMBOL: +stopped+ ] } case ] handle-synchronous - ] [ ] while ; + ] while ; : step-back-msg ( continuation -- continuation' ) walker-history tget @@ -233,7 +233,7 @@ SYMBOL: +stopped+ { step-back [ step-back-msg ] } } case f ] handle-synchronous - ] [ ] while ; + ] while ; : walker-loop ( -- ) +running+ set-status @@ -256,7 +256,7 @@ SYMBOL: +stopped+ [ walker-suspended ] } case ] handle-synchronous - ] [ ] until ; + ] until ; : associate-thread ( walker -- ) walker-thread tset diff --git a/basis/ui/event-loop/event-loop.factor b/basis/ui/event-loop/event-loop.factor index 7c08d802f5..26983e3b95 100644 --- a/basis/ui/event-loop/event-loop.factor +++ b/basis/ui/event-loop/event-loop.factor @@ -13,6 +13,6 @@ IN: ui.event-loop HOOK: do-events ui-backend ( -- ) -: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ; +: event-loop ( -- ) [ event-loop? ] [ do-events ] while ; : ui-wait ( -- ) 10 milliseconds sleep ; diff --git a/basis/ui/tools/interactor/interactor-tests.factor b/basis/ui/tools/interactor/interactor-tests.factor index 628570c3e3..101b7307dd 100644 --- a/basis/ui/tools/interactor/interactor-tests.factor +++ b/basis/ui/tools/interactor/interactor-tests.factor @@ -22,7 +22,7 @@ tools.test kernel calendar parser accessors calendar io ; ! This should not throw an exception [ ] [ "interactor" get evaluate-input ] unit-test - [ ] [ [ "interactor" get interactor-busy? ] [ yield ] [ ] while ] unit-test + [ ] [ [ "interactor" get interactor-busy? ] [ yield ] while ] unit-test [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 78f150987f..769dc9c64e 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -155,7 +155,7 @@ SYMBOL: ui-thread : update-ui-loop ( -- ) [ ui-running? ui-thread get-global self eq? and ] [ ui-notify-flag get lower-flag update-ui ] - [ ] while ; + while ; : start-ui-thread ( -- ) [ self ui-thread set-global update-ui-loop ] diff --git a/core/io/io.factor b/core/io/io.factor index 11a2a6d1a8..52ac23622a 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -70,7 +70,7 @@ SYMBOL: error-stream diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index b8191004db..fcc70cc8e5 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -637,15 +637,15 @@ HELP: 4dip } ; HELP: while -{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } +{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ; HELP: until -{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } +{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } } { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ; HELP: do -{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } } +{ $values { "pred" { $quotation "( -- ? )" } } { "body" "a quotation" } } { $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ; HELP: loop @@ -666,12 +666,6 @@ ARTICLE: "looping-combinators" "Looping combinators" "In most cases, loops should be written using high-level combinators (such as " { $link "sequences-combinators" } ") or tail recursion. However, sometimes, the best way to express intent is with a loop." { $subsection while } { $subsection until } -"The above two combinators take a " { $snippet "tail" } " quotation. Strictly speaking, the " { $snippet "tail" } " is not necessary, since the following are equivalent:" -{ $code - "[ P ] [ Q ] [ T ] while" - "[ P ] [ Q ] [ ] while T" -} -"However, depending on the stack effects of " { $snippet "pred" } " and " { $snippet "quot" } ", the " { $snippet "tail" } " quotation might need to be non-empty in order to balance out the stack effect of branches for stack effect inference." $nl "To execute one iteration of a loop, use the following word:" { $subsection do } diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 697000920a..cf4bf95db9 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -191,14 +191,14 @@ PRIVATE> : loop ( pred: ( -- ? ) -- ) [ call ] keep [ loop ] curry when ; inline recursive -: do ( pred body tail -- pred body tail ) - over 3dip ; inline +: do ( pred body -- pred body ) + dup 2dip ; inline -: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - [ pick 3dip [ do while ] 3curry ] keep if ; inline recursive +: while ( pred: ( -- ? ) body: ( -- ) -- ) + swap do compose [ loop ] curry when ; inline -: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) - [ [ not ] compose ] 2dip while ; inline +: until ( pred: ( -- ? ) body: ( -- ) -- ) + [ [ not ] compose ] dip while ; inline ! Object protocol GENERIC: hashcode* ( depth obj -- code ) diff --git a/core/math/integers/integers.factor b/core/math/integers/integers.factor index 6ed945216e..845fdc0fcf 100644 --- a/core/math/integers/integers.factor +++ b/core/math/integers/integers.factor @@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ; M: fixnum bit? neg shift 1 bitand 0 > ; : fixnum-log2 ( x -- n ) - 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] until drop ; + 0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ; M: fixnum (log2) fixnum-log2 ; @@ -103,7 +103,7 @@ M: bignum (log2) bignum-log2 ; : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) [ 2dup /i log2 53 > ] [ [ shift-mantissa ] dip ] - [ ] while /mod ; inline + while /mod ; inline ! Third step: post-scaling : unscaled-float ( mantissa -- n ) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 9e64cfa536..2983520620 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -488,7 +488,7 @@ PRIVATE> V{ } clone [ [ push ] curry compose ] keep ; inline : produce-as ( pred quot tail exemplar -- seq ) - [ swap accumulator [ swap while ] dip ] dip like ; inline + [ [ accumulator [ while ] dip ] dip dip ] dip like ; inline : produce ( pred quot tail -- seq ) { } produce-as ; inline diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 24ff1b0f8b..ea020c5c55 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -199,7 +199,7 @@ M: array make-slot swap peel-off-name peel-off-class - [ dup empty? ] [ peel-off-attributes ] [ ] until drop + [ dup empty? ] [ peel-off-attributes ] until drop check-initial-value ; M: slot-spec make-slot diff --git a/core/sorting/sorting.factor b/core/sorting/sorting.factor index 938bf17cd2..043505759e 100644 --- a/core/sorting/sorting.factor +++ b/core/sorting/sorting.factor @@ -126,7 +126,7 @@ TUPLE: merge : sort-loop ( merge quot -- ) [ 2 [ over seq>> length over > ] ] dip [ [ 1 shift 2dup ] dip sort-pass ] curry - [ ] while 2drop ; inline + while 2drop ; inline : each-pair ( seq quot -- ) [ [ length 1+ 2/ ] keep ] dip diff --git a/extra/adsoda/adsoda.factor b/extra/adsoda/adsoda.factor index 01e437bc7d..ec77501b8f 100755 --- a/extra/adsoda/adsoda.factor +++ b/extra/adsoda/adsoda.factor @@ -337,7 +337,7 @@ TUPLE: solid dimension silhouettes : compute-adjacencies ( solid -- solid ) dup dimension>> [ >= ] curry [ keep swap ] curry MAX-FACE-PER-CORNER swap - [ [ test-faces-combinaisons ] 2keep 1- ] [ ] while drop ; + [ [ test-faces-combinaisons ] 2keep 1- ] while drop ; : find-adjacencies ( solid -- solid ) erase-old-adjacencies diff --git a/extra/bubble-chamber/bubble-chamber.factor b/extra/bubble-chamber/bubble-chamber.factor index 4bddd4b632..713bb223e1 100644 --- a/extra/bubble-chamber/bubble-chamber.factor +++ b/extra/bubble-chamber/bubble-chamber.factor @@ -135,7 +135,7 @@ METHOD: collide ( -- ) 0 >>theta-d 0 >>theta-dd - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while drop ; @@ -201,7 +201,7 @@ METHOD: collide ( -- ) 0 >>theta-d 0 >>theta-dd - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while 0 1 0 1 rgba boa >>myc @@ -302,7 +302,7 @@ METHOD: collide ( -- ) 0 >>theta-d 0 >>theta-dd - [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] [ ] while + [ 0.001 theta-dd-small? ] [ -0.1 0.1 random-theta-dd ] while set-good-color set-anti-color @@ -355,7 +355,7 @@ METHOD: collide ( -- ) 0 >>theta-d 0 >>theta-dd - [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] [ ] while + [ 0.00001 theta-dd-small? ] [ -0.001 0.001 random-theta-dd ] while drop ; diff --git a/extra/graph-theory/graph-theory.factor b/extra/graph-theory/graph-theory.factor index 842f4d1f38..b14832dc03 100644 --- a/extra/graph-theory/graph-theory.factor +++ b/extra/graph-theory/graph-theory.factor @@ -78,7 +78,7 @@ PRIVATE> : full-depth-first ( graph pre post tail -- ? ) '[ [ visited? get [ nip not ] assoc-find ] [ drop _ _ (depth-first) @ ] - [ 2drop ] while ] swap search-wrap ; inline + while 2drop ] swap search-wrap ; inline : dag? ( graph -- ? ) V{ } clone swap [ 2dup swap push dupd diff --git a/extra/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 59e4cf6cb4..d788eb3c2c 100755 --- a/extra/irc/ui/ui.factor +++ b/extra/irc/ui/ui.factor @@ -152,7 +152,7 @@ M: object handle-inbox : display ( stream tab -- ) '[ _ [ [ t ] [ _ dup chat>> hear handle-inbox ] - [ ] while ] with-output-stream ] "ircv" spawn drop ; + while ] with-output-stream ] "ircv" spawn drop ; : ( tab -- tab pane ) diff --git a/extra/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor index b52749dbe1..716afc0dc2 100644 --- a/extra/otug-talk/otug-talk.factor +++ b/extra/otug-talk/otug-talk.factor @@ -223,7 +223,7 @@ M: png-gadget ungraft* ( gadget -- ) } { $slide "Modifiers" { $code ": bank ( n -- n )" " readln string>number +" " dup \"Balance: $\" write . ;" } - { $code "0 [ dup 0 > ] [ bank ] [ ] while" } + { $code "0 [ dup 0 > ] [ bank ] while" } } { $slide "Modifiers" { $code "0 [ dup 0 > ] [ bank ] [ ] do while" } diff --git a/extra/project-euler/012/012.factor b/extra/project-euler/012/012.factor index b25bfc90f1..ff482c6812 100644 --- a/extra/project-euler/012/012.factor +++ b/extra/project-euler/012/012.factor @@ -34,7 +34,7 @@ IN: project-euler.012 ! -------- : euler012 ( -- answer ) - 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] [ ] while nth-triangle ; + 8 [ dup nth-triangle tau* 500 < ] [ 1+ ] while nth-triangle ; ! [ euler012 ] 10 ave-time ! 6573 ms ave run time - 346.27 SD (10 trials) diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor index aa04784151..e93e3d11bc 100644 --- a/extra/project-euler/014/014.factor +++ b/extra/project-euler/014/014.factor @@ -43,7 +43,7 @@ IN: project-euler.014 PRIVATE> : collatz ( n -- seq ) - [ [ dup 1 > ] [ dup , next-collatz ] [ ] while , ] { } make ; + [ [ dup 1 > ] [ dup , next-collatz ] while , ] { } make ; : euler014 ( -- answer ) 1000000 [1,b] 0 [ collatz longest ] reduce first ; diff --git a/extra/project-euler/100/100.factor b/extra/project-euler/100/100.factor index 98dbba19fd..ec372add3b 100644 --- a/extra/project-euler/100/100.factor +++ b/extra/project-euler/100/100.factor @@ -26,7 +26,7 @@ IN: project-euler.100 : euler100 ( -- answer ) 1 1 [ dup dup 1- * 2 * 10 24 ^ <= ] - [ tuck 6 * swap - 2 - ] [ ] while nip ; + [ tuck 6 * swap - 2 - ] while nip ; ! TODO: solution needs generalization diff --git a/unmaintained/combinators-lib/lib.factor b/unmaintained/combinators-lib/lib.factor index 5e78d183b0..9b3abe3984 100755 --- a/unmaintained/combinators-lib/lib.factor +++ b/unmaintained/combinators-lib/lib.factor @@ -126,12 +126,9 @@ MACRO: multikeep ( word out-indexes -- ... ) r> [ drop \ r> , ] each ] [ ] make ; -: do-while ( pred body tail -- ) - [ tuck 2slip ] dip while ; inline - : generate ( generator predicate -- obj ) - '[ dup @ dup [ nip ] unless not ] - swap [ ] do-while ; + '[ dup @ dup [ nip ] unless ] + swap do until ; MACRO: predicates ( seq -- quot/f ) dup [ 1quotation [ drop ] prepend ] map From da2ebe21a651759c9b1e93beccecc2ec603281c2 Mon Sep 17 00:00:00 2001 From: Samuel Tardieu Date: Wed, 18 Feb 2009 03:00:16 +0100 Subject: [PATCH 3/7] Fix two overzealous [ ] removal in tests --- basis/compiler/tree/propagation/propagation-tests.factor | 2 +- basis/stack-checker/stack-checker-tests.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f261b8747f..52ae83eb12 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -441,7 +441,7 @@ TUPLE: mixed-mutable-immutable { x integer } { y sequence read-only } ; [ V{ real } ] [ [ recursive-test-3 ] final-classes ] unit-test -[ V{ real } ] [ [ [ dup 10 < ] while ] final-classes ] unit-test +[ V{ real } ] [ [ [ dup 10 < ] [ ] while ] final-classes ] unit-test [ V{ float } ] [ [ { float } declare 10 [ 2.3 * ] times ] final-classes diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 6cfe80dbf6..d90db8ab89 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -513,7 +513,7 @@ ERROR: custom-error ; ! Corner case [ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail -[ [ [ f dup ] while ] infer ] must-fail +[ [ [ f dup ] [ ] while ] infer ] must-fail : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline From 473095b6d58b6181b20d9304a5d889208d244642 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 28 Feb 2009 02:29:35 +0100 Subject: [PATCH 4/7] FUEL: Persistent listener history. --- misc/fuel/fuel-listener.el | 32 +++++++++++++++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index b8bf4d4b7f..1d23571a0a 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -59,6 +59,35 @@ buffer." :type 'boolean :group 'fuel-listener) +(defcustom fuel-listener-history-filename (expand-file-name "~/.fuel_history") + "File where listener input history is saved, so that it persists between sessions." + :type 'filename + :group 'fuel-listener) + +(defcustom fuel-listener-history-size comint-input-ring-size + "Maximum size of the saved listener input history." + :type 'integer + :group 'fuel-listener) + + +;;; Listener history: + +(defun fuel-listener--sentinel (proc event) + (when (string= event "finished\n") + (with-current-buffer (process-buffer proc) + (let ((comint-input-ring-file-name fuel-listener-history-filename)) + (comint-write-input-ring) + (when (buffer-name (current-buffer)) + (insert "\nBye bye. It's been nice listening to you!\n") + (insert "Press C-cz to bring me back.\n" )))))) + +(defun fuel-listener--history-setup () + (set (make-local-variable 'comint-input-ring-file-name) fuel-listener-history-filename) + (set (make-local-variable 'comint-input-ring-size) fuel-listener-history-size) + (add-hook 'kill-buffer-hook 'comint-write-input-ring nil t) + (comint-read-input-ring t) + (set-process-sentinel (get-buffer-process (current-buffer)) 'fuel-listener--sentinel)) + ;;; Fuel listener buffer/process: @@ -84,7 +113,8 @@ buffer." (pop-to-buffer (fuel-listener--buffer)) (make-comint-in-buffer "fuel listener" (current-buffer) factor nil "-run=listener" (format "-i=%s" image)) - (fuel-listener--wait-for-prompt 10000) + (fuel-listener--wait-for-prompt 60000) + (fuel-listener--history-setup) (fuel-con--setup-connection (current-buffer)))) (defun fuel-listener--connect-process (port) From 87d70e952328e266bf0a19ad202bd0e5d4143a9d Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Sat, 28 Feb 2009 02:56:38 +0100 Subject: [PATCH 5/7] FUEL: Autoloads for customization groups. --- misc/fuel/fu.el | 13 +++++++++++++ 1 file changed, 13 insertions(+) diff --git a/misc/fuel/fu.el b/misc/fuel/fu.el index e9217fbd03..01ec0d60e6 100644 --- a/misc/fuel/fu.el +++ b/misc/fuel/fu.el @@ -37,5 +37,18 @@ (autoload 'fuel-scaffold-help "fuel-scaffold.el" "Create a Factor vocabulary help file." t) +(mapc (lambda (group) + (custom-add-load group (symbol-name group)) + (custom-add-load 'fuel (symbol-name group))) + '(fuel fuel-faces + factor-mode + fuel-autodoc + fuel-stack + fuel-help + fuel-xref + fuel-listener + fuel-scaffold + fuel-debug + fuel-mode)) ;;; fu.el ends here From bb0e2a49ba0d0559b83c0b7c51bc636e00780679 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 28 Feb 2009 15:01:28 -0600 Subject: [PATCH 6/7] =?UTF-8?q?pr=C3=A9lude=20to=20a=20haiku?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- core/system/system.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/core/system/system.factor b/core/system/system.factor index 2d8ed1b657..8f587d28c2 100644 --- a/core/system/system.factor +++ b/core/system/system.factor @@ -25,9 +25,11 @@ SINGLETON: solaris SINGLETON: macosx SINGLETON: linux +SINGLETON: haiku + UNION: bsd freebsd netbsd openbsd macosx ; -UNION: unix bsd solaris linux ; +UNION: unix bsd solaris linux haiku ; : os ( -- class ) \ os get-global ; foldable @@ -51,6 +53,7 @@ UNION: unix bsd solaris linux ; { "solaris" solaris } { "macosx" macosx } { "linux" linux } + { "haiku" haiku } } at ; PRIVATE> From cd53c2bd37dbd2de342f69752e43a04b08a5d1f1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 28 Feb 2009 15:31:34 -0600 Subject: [PATCH 7/7] produce and produce-as: don't need third quotation either --- basis/bootstrap/image/image.factor | 2 +- basis/concurrency/mailboxes/mailboxes.factor | 2 +- basis/environment/winnt/winnt.factor | 3 +-- basis/heaps/heaps.factor | 2 +- basis/http/http.factor | 2 +- basis/io/directories/unix/unix.factor | 2 +- basis/io/directories/windows/windows.factor | 2 +- basis/io/files/info/windows/windows.factor | 4 +--- basis/math/combinatorics/combinatorics.factor | 2 +- basis/persistent/deques/deques.factor | 2 +- basis/persistent/heaps/heaps.factor | 2 +- basis/quoted-printable/quoted-printable.factor | 4 ++-- basis/regexp/regexp.factor | 2 +- basis/stack-checker/stack-checker-tests.factor | 2 +- basis/ui/windows/windows.factor | 6 +----- basis/unicode/breaks/breaks.factor | 3 +-- basis/unicode/case/case.factor | 2 +- basis/unix/groups/groups.factor | 2 +- basis/unix/users/users.factor | 2 +- basis/unix/utilities/utilities.factor | 2 +- basis/unix/utmpx/utmpx.factor | 2 +- core/classes/algebra/algebra.factor | 2 +- core/effects/parser/parser.factor | 2 +- core/io/io-docs.factor | 2 +- core/io/io.factor | 5 ++--- core/kernel/kernel-docs.factor | 3 +-- core/math/parser/parser.factor | 2 +- core/sequences/sequences-docs.factor | 17 ++++++----------- core/sequences/sequences.factor | 8 ++++---- extra/id3/id3.factor | 2 +- extra/iokit/iokit.factor | 4 +--- extra/math/text/utils/utils.factor | 2 +- extra/multi-methods/multi-methods.factor | 2 +- extra/project-euler/002/002.factor | 2 +- extra/project-euler/019/019.factor | 2 +- extra/project-euler/071/071.factor | 2 +- extra/project-euler/148/148.factor | 2 +- extra/project-euler/common/common.factor | 2 +- 38 files changed, 48 insertions(+), 65 deletions(-) diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor index 10cde266cc..5c76a0fcf8 100644 --- a/basis/bootstrap/image/image.factor +++ b/basis/bootstrap/image/image.factor @@ -240,7 +240,7 @@ GENERIC: ' ( obj -- ptr ) #! n is positive or zero. [ dup 0 > ] [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ] - [ ] produce nip ; + produce nip ; : emit-bignum ( n -- ) dup dup 0 < [ neg ] when bignum>seq diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 6dcf3dc34f..f6aec94b41 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -51,7 +51,7 @@ M: mailbox dispose* threads>> notify-all ; block-if-empty [ dup mailbox-empty? ] [ dup data>> pop-back ] - [ ] produce nip ; + produce nip ; : mailbox-get-all ( mailbox -- array ) f mailbox-get-all-timeout ; diff --git a/basis/environment/winnt/winnt.factor b/basis/environment/winnt/winnt.factor index 2ad3393aec..eb90a36ee7 100644 --- a/basis/environment/winnt/winnt.factor +++ b/basis/environment/winnt/winnt.factor @@ -27,7 +27,6 @@ M: winnt (os-envs) ( -- seq ) GetEnvironmentStrings [ [ utf16n decode-input - [ "\0" read-until drop dup empty? not ] - [ ] [ drop ] produce + [ "\0" read-until drop dup empty? not ] [ ] produce nip ] with-input-stream* ] [ FreeEnvironmentStrings win32-error=0/f ] bi ; diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor index aa1ebf7786..564d7db17f 100644 --- a/basis/heaps/heaps.factor +++ b/basis/heaps/heaps.factor @@ -190,7 +190,7 @@ M: heap heap-pop ( heap -- value key ) : heap-pop-all ( heap -- alist ) [ dup heap-empty? not ] [ dup heap-pop swap 2array ] - [ ] produce nip ; + produce nip ; : slurp-heap ( heap quot: ( elt -- ) -- ) over heap-empty? [ 2drop ] [ diff --git a/basis/http/http.factor b/basis/http/http.factor index d4acd282f8..a64a11690c 100755 --- a/basis/http/http.factor +++ b/basis/http/http.factor @@ -12,7 +12,7 @@ base64 ; IN: http : (read-header) ( -- alist ) - [ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ; + [ read-crlf dup f like ] [ parse-header-line ] produce nip ; : collect-headers ( assoc -- assoc' ) H{ } clone [ '[ _ push-at ] assoc-each ] keep ; diff --git a/basis/io/directories/unix/unix.factor b/basis/io/directories/unix/unix.factor index 89e091f919..395ce73d7c 100644 --- a/basis/io/directories/unix/unix.factor +++ b/basis/io/directories/unix/unix.factor @@ -61,5 +61,5 @@ M: unix (directory-entries) ( path -- seq ) [ '[ _ find-next-file dup ] [ >directory-entry ] - [ drop ] produce + produce nip ] with-unix-directory ; diff --git a/basis/io/directories/windows/windows.factor b/basis/io/directories/windows/windows.factor index a6dacc1841..7554baa944 100755 --- a/basis/io/directories/windows/windows.factor +++ b/basis/io/directories/windows/windows.factor @@ -61,7 +61,7 @@ M: windows (directory-entries) ( path -- seq ) '[ [ _ find-next-file dup ] [ >directory-entry ] - [ drop ] produce + produce nip over name>> "." = [ nip ] [ swap prefix ] if ] ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ; diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index cf826a59d3..fdff368491 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -159,9 +159,7 @@ M: winnt file-system-info ( path -- file-system-info ) find-first-volume [ '[ - [ _ find-next-volume dup ] - [ ] - [ drop ] produce + [ _ find-next-volume dup ] [ ] produce nip swap prefix ] ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ; diff --git a/basis/math/combinatorics/combinatorics.factor b/basis/math/combinatorics/combinatorics.factor index d5dff65c35..afdf4e378e 100644 --- a/basis/math/combinatorics/combinatorics.factor +++ b/basis/math/combinatorics/combinatorics.factor @@ -16,7 +16,7 @@ IN: math.combinatorics ! http://msdn2.microsoft.com/en-us/library/aa302371.aspx : factoradic ( n -- factoradic ) - 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] [ ] produce reverse 2nip ; + 0 [ over 0 > ] [ 1+ [ /mod ] keep swap ] produce reverse 2nip ; : (>permutation) ( seq n -- seq ) [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index 8f93ae1ab8..91f1dcf1f8 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -67,4 +67,4 @@ PRIVATE> [ push-back ] reduce ; : deque>sequence ( deque -- sequence ) - [ dup deque-empty? not ] [ pop-front swap ] [ ] produce nip ; + [ dup deque-empty? not ] [ pop-front swap ] produce nip ; diff --git a/basis/persistent/heaps/heaps.factor b/basis/persistent/heaps/heaps.factor index f6d38b5b25..38a7eb1313 100644 --- a/basis/persistent/heaps/heaps.factor +++ b/basis/persistent/heaps/heaps.factor @@ -98,6 +98,6 @@ M: branch pheap-push swap [ rot pheap-push ] assoc-each ; : pheap>alist ( heap -- alist ) - [ dup pheap-empty? not ] [ pheap-pop 2array ] [ ] produce nip ; + [ dup pheap-empty? not ] [ pheap-pop 2array ] produce nip ; : pheap>values ( heap -- seq ) pheap>alist keys ; diff --git a/basis/quoted-printable/quoted-printable.factor b/basis/quoted-printable/quoted-printable.factor index 3be1a07eab..e82789ccbf 100644 --- a/basis/quoted-printable/quoted-printable.factor +++ b/basis/quoted-printable/quoted-printable.factor @@ -32,7 +32,7 @@ IN: quoted-printable [ 1- cut-slice swap ] [ f swap ] if* concat ; : divide-lines ( strings -- strings ) - [ dup ] [ take-some ] [ ] produce nip ; + [ dup ] [ take-some ] produce nip ; PRIVATE> @@ -53,7 +53,7 @@ PRIVATE> ] when ; : read-quoted ( -- bytes ) - [ read1 dup ] [ read-char ] [ drop ] B{ } produce-as ; + [ read1 dup ] [ read-char ] B{ } produce-as nip ; PRIVATE> diff --git a/basis/regexp/regexp.factor b/basis/regexp/regexp.factor index 86f978373b..11d257b6b2 100644 --- a/basis/regexp/regexp.factor +++ b/basis/regexp/regexp.factor @@ -75,7 +75,7 @@ IN: regexp [ [ split1-slice nip ] keep ] [ 2drop f f ] if ; : all-matches ( string regexp -- seq ) - [ dup ] swap '[ _ next-match ] [ ] produce nip harvest ; + [ dup ] swap '[ _ next-match ] produce nip harvest ; : count-matches ( string regexp -- n ) all-matches length ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 4361052b63..6e7774aba1 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -512,7 +512,7 @@ ERROR: custom-error ; [ [ missing->r-check ] infer ] must-fail ! Corner case -[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail +[ [ [ f dup ] [ dup ] produce ] infer ] must-fail [ [ [ f dup ] [ ] while ] infer ] must-fail diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 9df694ee37..3b4bcd6e17 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -22,11 +22,7 @@ SINGLETON: windows-ui-backend [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ; : enum-clipboard ( -- seq ) - 0 - [ EnumClipboardFormats win32-error dup dup 0 > ] - [ ] - [ drop ] - produce nip ; + 0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ] produce 2nip ; : with-clipboard ( quot -- ) f OpenClipboard win32-error=0/f diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor index 2f8daef8b2..ddcb99b829 100644 --- a/basis/unicode/breaks/breaks.factor +++ b/basis/unicode/breaks/breaks.factor @@ -102,8 +102,7 @@ PRIVATE> pieces ( str quot: ( str -- i ) -- graphemes ) - [ dup empty? not ] swap '[ dup @ cut-slice swap ] - [ ] produce nip ; inline + [ dup empty? not ] swap '[ dup @ cut-slice swap ] produce nip ; inline PRIVATE> diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 3ac98cd57f..c75582dacd 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -18,7 +18,7 @@ SYMBOL: locale ! Just casing locale, or overall? group ] [ drop ] produce ; + [ getgrent dup ] [ group-struct>group ] produce nip ; : ( -- assoc ) all-groups [ [ id>> ] keep ] H{ } map>assoc ; diff --git a/basis/unix/users/users.factor b/basis/unix/users/users.factor index da38972955..a523f0818b 100644 --- a/basis/unix/users/users.factor +++ b/basis/unix/users/users.factor @@ -36,7 +36,7 @@ PRIVATE> : all-users ( -- seq ) [ - [ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce + [ getpwent dup ] [ passwd>new-passwd ] produce nip ] with-pwent ; SYMBOL: user-cache diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index 29b137e3de..e1d26eab66 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -14,7 +14,7 @@ IN: unix.utilities : alien>strings ( alien encoding -- strings ) [ [ dup more? ] ] dip '[ [ advance ] [ *void* _ alien>string ] bi ] - [ ] produce nip ; + produce nip ; : strings>alien ( strings encoding -- array ) '[ _ malloc-string ] void*-array{ } map-as f suffix ; diff --git a/basis/unix/utmpx/utmpx.factor b/basis/unix/utmpx/utmpx.factor index 9f12bc599b..6e72f7d114 100644 --- a/basis/unix/utmpx/utmpx.factor +++ b/basis/unix/utmpx/utmpx.factor @@ -57,7 +57,7 @@ M: unix utmpx>utmpx-record ( utmpx -- utmpx-record ) [ [ getutxent dup ] [ utmpx>utmpx-record ] - [ drop ] produce + produce nip ] with-utmpx ; os { diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 825cd67a4d..c774ef1c1d 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -210,7 +210,7 @@ M: anonymous-complement (classes-intersect?) [ [ name>> ] compare ] sort >vector [ dup empty? not ] [ dup largest-class [ over delete-nth ] dip ] - [ ] produce nip ; + produce nip ; : min-class ( class seq -- class/f ) over [ classes-intersect? ] curry filter diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 6b7e953b6c..a009db76b1 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -21,7 +21,7 @@ ERROR: bad-effect ; ] if ; : parse-effect-tokens ( end -- tokens ) - [ parse-effect-token dup ] curry [ ] [ drop ] produce ; + [ parse-effect-token dup ] curry [ ] produce nip ; : parse-effect ( end -- effect ) parse-effect-tokens { "--" } split1 dup diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index 5d8aa6a88f..489cac6703 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -224,7 +224,7 @@ $io-error ; ARTICLE: "stream-protocol" "Stream protocol" "The stream protocol consists of a large number of generic words, many of which are optional." $nl -"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "." +"Stream protocol words are rarely called directly, since code which only works with one stream at a time should be written to use " { $link "stdio" } " instead, wrapping I/O operations such as " { $link read } " and " { $link write } " in " { $link with-input-stream } " and " { $link with-output-stream } "." $nl "All streams must implement the " { $link dispose } " word in addition to the stream protocol." $nl diff --git a/core/io/io.factor b/core/io/io.factor index 52ac23622a..cb68b1c4fe 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -65,7 +65,7 @@ SYMBOL: error-stream : bl ( -- ) " " write ; : lines ( stream -- seq ) - [ [ readln dup ] [ ] [ drop ] produce ] with-input-stream ; + [ [ readln dup ] [ ] produce nip ] with-input-stream ; : contents ( stream -- seq ) [ - [ 65536 read-partial dup ] - [ ] [ drop ] produce concat f like + [ 65536 read-partial dup ] [ ] produce nip concat f like ] with-input-stream ; : each-block ( quot: ( block -- ) -- ) diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index c2719c056a..800bc86b66 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -667,12 +667,11 @@ ARTICLE: "looping-combinators" "Looping combinators" "In most cases, loops should be written using high-level combinators (such as " { $link "sequences-combinators" } ") or tail recursion. However, sometimes, the best way to express intent is with a loop." { $subsection while } { $subsection until } -$nl "To execute one iteration of a loop, use the following word:" { $subsection do } "This word is intended as a modifier. The normal " { $link while } " loop never executes the body if the predicate returns first on the first iteration. To ensure the body executes at least once, use " { $link do } ":" { $code - "[ P ] [ Q ] [ T ] do while" + "[ P ] [ Q ] do while" } "A simpler looping combinator which executes a single quotation until it returns " { $link f } ":" { $subsection loop } ; diff --git a/core/math/parser/parser.factor b/core/math/parser/parser.factor index ac6c5e9790..0d8f0c0b08 100644 --- a/core/math/parser/parser.factor +++ b/core/math/parser/parser.factor @@ -96,7 +96,7 @@ PRIVATE> : positive>base ( num radix -- str ) dup 1 <= [ "Invalid radix" throw ] when - [ dup 0 > ] swap [ /mod >digit ] curry [ ] "" produce-as nip + [ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip dup reverse-here ; inline PRIVATE> diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index c12761ab38..67084e256f 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -915,24 +915,19 @@ HELP: supremum { $errors "Throws an error if the sequence is empty." } ; HELP: produce -{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "seq" "a sequence" } } +{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "seq" "a sequence" } } { $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence at the end." } { $examples "The following example divides a number by two until we reach zero, and accumulates intermediate results:" - { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] produce nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" } - "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:" - { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" } + { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] produce nip ." "{ 668 334 167 83 41 20 10 5 2 1 0 }" } + "The following example collects random numbers as long as they are greater than 1:" + { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] produce nip ." "{ 8 2 2 9 }" } } ; HELP: produce-as -{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "tail" "a quotation" } { "exemplar" sequence } { "seq" "a sequence" } } +{ $values { "pred" { $quotation "( -- ? )" } } { "quot" { $quotation "( -- obj )" } } { "exemplar" sequence } { "seq" "a sequence" } } { $description "Calls " { $snippet "pred" } " repeatedly. If the predicate yields " { $link f } ", stops, otherwise, calls " { $snippet "quot" } " to yield a value. Values are accumulated and returned in a sequence of type " { $snippet "exemplar" } " at the end." } -{ $examples - "The following example divides a number by two until we reach zero, and accumulates intermediate results:" - { $example "USING: kernel math prettyprint sequences ;" "1337 [ dup 0 > ] [ 2/ dup ] [ ] V{ } produce-as nip ." "V{ 668 334 167 83 41 20 10 5 2 1 0 }" } - "The " { $snippet "tail" } " quotation is used when the predicate produces more than one output value. In this case, we have to drop this value even if the predicate fails in order for stack inference to calculate a stack effect for the " { $link produce } " call:" - { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] [ drop ] B{ } produce-as ." "B{ 8 2 2 9 }" } -} ; +{ $examples "See " { $link produce } " for examples." } ; HELP: sigma { $values { "seq" sequence } { "quot" quotation } { "n" number } } diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 2983520620..fba7aa3b03 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -487,14 +487,14 @@ PRIVATE> : accumulator ( quot -- quot' vec ) V{ } clone [ [ push ] curry compose ] keep ; inline -: produce-as ( pred quot tail exemplar -- seq ) - [ [ accumulator [ while ] dip ] dip dip ] dip like ; inline +: produce-as ( pred quot exemplar -- seq ) + [ accumulator [ while ] dip ] dip like ; inline -: produce ( pred quot tail -- seq ) +: produce ( pred quot -- seq ) { } produce-as ; inline : follow ( obj quot -- seq ) - [ dup ] swap [ keep ] curry [ ] produce nip ; inline + [ dup ] swap [ keep ] curry produce nip ; inline : prepare-index ( seq quot -- seq n quot ) [ dup length ] dip ; inline diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index d1397285d7..f01c400338 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -115,7 +115,7 @@ TUPLE: id3v1-info title artist album year comment genre ; : read-frames ( mmap -- frames ) [ dup read-frame dup ] [ [ remove-frame ] keep ] - [ drop ] produce nip ; + produce 2nip ; ! header stuff diff --git a/extra/iokit/iokit.factor b/extra/iokit/iokit.factor index 3fb14e8ec5..12eb6d6e92 100755 --- a/extra/iokit/iokit.factor +++ b/extra/iokit/iokit.factor @@ -166,9 +166,7 @@ M: mach-error error. IOObjectRelease mach-error ; : io-objects-from-iterator* ( i -- i array ) - [ dup IOIteratorNext dup MACH_PORT_NULL = not ] - [ ] - [ drop ] produce ; + [ dup IOIteratorNext dup MACH_PORT_NULL = not ] [ ] produce nip ; : io-objects-from-iterator ( i -- array ) io-objects-from-iterator* [ release-io-object ] dip ; diff --git a/extra/math/text/utils/utils.factor b/extra/math/text/utils/utils.factor index 73326de273..422a79a1f3 100644 --- a/extra/math/text/utils/utils.factor +++ b/extra/math/text/utils/utils.factor @@ -4,4 +4,4 @@ USING: kernel math sequences ; IN: math.text.utils : 3digit-groups ( n -- seq ) - [ dup 0 > ] [ 1000 /mod ] [ ] produce nip ; + [ dup 0 > ] [ 1000 /mod ] produce nip ; diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 5ad1d944d3..3370ab7f86 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -82,7 +82,7 @@ SYMBOL: total : topological-sort ( seq quot -- newseq ) [ >vector [ dup empty? not ] ] dip [ dupd maximal-element [ over delete-nth ] dip ] curry - [ ] produce nip ; inline + produce nip ; inline : classes< ( seq1 seq2 -- lt/eq/gt ) [ diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index 9c462b6b2e..136ebbb6da 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -41,7 +41,7 @@ PRIVATE> ! ------------------- : fib-upto* ( n -- seq ) - 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce [ 3drop ] dip + 0 1 [ pick over >= ] [ tuck + dup ] produce [ 3drop ] dip but-last-slice { 0 1 } prepend ; : euler002a ( -- answer ) diff --git a/extra/project-euler/019/019.factor b/extra/project-euler/019/019.factor index 16a7139f51..4b750ac180 100644 --- a/extra/project-euler/019/019.factor +++ b/extra/project-euler/019/019.factor @@ -53,7 +53,7 @@ IN: project-euler.019 : first-days ( end-date start-date -- days ) [ 2dup after=? ] [ dup 1 months time+ swap day-of-week ] - [ ] produce 2nip ; + produce 2nip ; PRIVATE> diff --git a/extra/project-euler/071/071.factor b/extra/project-euler/071/071.factor index feecd997fa..69d9eb1a03 100644 --- a/extra/project-euler/071/071.factor +++ b/extra/project-euler/071/071.factor @@ -40,7 +40,7 @@ IN: project-euler.071 PRIVATE> : euler071 ( -- answer ) - 2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] [ ] produce + 2/5 [ dup denominator 1000000 <= ] [ 3/7 mediant dup ] produce nip penultimate numerator ; ! [ euler071 ] 100 ave-time diff --git a/extra/project-euler/148/148.factor b/extra/project-euler/148/148.factor index 533874fa67..5aa0299dda 100644 --- a/extra/project-euler/148/148.factor +++ b/extra/project-euler/148/148.factor @@ -35,7 +35,7 @@ IN: project-euler.148 dup 1+ * 2/ ; inline : >base7 ( x -- y ) - [ dup 0 > ] [ 7 /mod ] [ ] produce nip ; + [ dup 0 > ] [ 7 /mod ] produce nip ; : (use-digit) ( prev x index -- next ) [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ; diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 1a57a91e5e..ac8986b3ff 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -72,7 +72,7 @@ PRIVATE> ] if ; : number>digits ( n -- seq ) - [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ; + [ dup 0 = not ] [ 10 /mod ] produce reverse nip ; : nth-triangle ( n -- n ) dup 1+ * 2 / ;