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/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/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index b9a88de34a..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/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index 656fbbb591..f6aec94b41 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -51,13 +51,13 @@ 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 ; : 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/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/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/heaps/heaps.factor b/basis/heaps/heaps.factor index 37882f8a57..65cb6541f4 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/hints/hints.factor b/basis/hints/hints.factor index b6af773ce5..4093666eb7 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -96,8 +96,6 @@ M: object specializer-declaration class ; { string string } "specializer" set-word-prop -\ find-last-sep { string sbuf } "specializer" set-word-prop - \ >string { sbuf } "specializer" set-word-prop \ >array { { vector } } "specializer" set-word-prop 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/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/streams/byte-array/byte-array.factor b/basis/io/streams/byte-array/byte-array.factor index 9d89c3d814..b877e97cf1 100644 --- a/basis/io/streams/byte-array/byte-array.factor +++ b/basis/io/streams/byte-array/byte-array.factor @@ -1,5 +1,8 @@ +! Copyright (C) 2008, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: byte-arrays byte-vectors kernel io.encodings io.streams.string -sequences io namespaces io.encodings.private accessors ; +sequences io namespaces io.encodings.private accessors sequences.private +io.streams.sequence destructors ; IN: io.streams.byte-array : ( encoding -- stream ) @@ -9,8 +12,16 @@ IN: io.streams.byte-array [ ] dip [ output-stream get ] compose with-output-stream* dup encoder? [ stream>> ] when >byte-array ; inline +TUPLE: byte-reader { underlying byte-array read-only } { i array-capacity } ; + +M: byte-reader stream-read-partial stream-read ; +M: byte-reader stream-read sequence-read ; +M: byte-reader stream-read1 sequence-read1 ; +M: byte-reader stream-read-until sequence-read-until ; +M: byte-reader dispose drop ; + : ( byte-array encoding -- stream ) - [ >byte-vector dup reverse-here ] dip ; + [ B{ } like 0 byte-reader boa ] dip ; : with-byte-reader ( byte-array encoding quot -- ) [ ] dip with-input-stream* ; inline diff --git a/basis/io/streams/string/string-tests.factor b/basis/io/streams/string/string-tests.factor index a6502046c8..967c0d4613 100644 --- a/basis/io/streams/string/string-tests.factor +++ b/basis/io/streams/string/string-tests.factor @@ -15,12 +15,12 @@ unit-test [ "xyzzy" ] [ [ "xyzzy" write ] with-string-writer ] unit-test -[ "a" ] [ 1 SBUF" cba" stream-read ] unit-test -[ "ab" ] [ 2 SBUF" cba" stream-read ] unit-test -[ "abc" ] [ 3 SBUF" cba" stream-read ] unit-test -[ "abc" ] [ 4 SBUF" cba" stream-read ] unit-test +[ "a" ] [ 1 "abc" stream-read ] unit-test +[ "ab" ] [ 2 "abc" stream-read ] unit-test +[ "abc" ] [ 3 "abc" stream-read ] unit-test +[ "abc" ] [ 4 "abc" stream-read ] unit-test [ "abc" f ] [ - 3 SBUF" cba" [ stream-read ] keep stream-read1 + 3 "abc" [ stream-read ] keep stream-read1 ] unit-test [ diff --git a/basis/io/streams/string/string.factor b/basis/io/streams/string/string.factor index 4582490726..73bf5f5efe 100644 --- a/basis/io/streams/string/string.factor +++ b/basis/io/streams/string/string.factor @@ -1,18 +1,12 @@ -! Copyright (C) 2003, 2009 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors io kernel math namespaces sequences sbufs -strings generic splitting continuations destructors -io.streams.plain io.encodings math.order growable ; +strings generic splitting continuations destructors sequences.private +io.streams.plain io.encodings math.order growable io.streams.sequence ; IN: io.streams.string > like ; - -: growable-read-until ( growable n -- str ) - >fixnum dupd tail-slice swap harden-as dup reverse-here ; - SINGLETON: null-encoding M: null-encoding decode-char drop stream-read1 ; @@ -32,34 +26,18 @@ M: growable stream-flush drop ; swap [ output-stream get ] compose with-output-stream* >string ; inline -M: growable stream-read1 [ f ] [ pop ] if-empty ; +! New implementation -: find-last-sep ( seq seps -- n ) - swap [ memq? ] curry find-last drop ; +TUPLE: string-reader { underlying string read-only } { i array-capacity } ; -M: growable stream-read-until - [ find-last-sep ] keep over [ - [ swap 1+ growable-read-until ] 2keep [ nth ] 2keep - set-length - ] [ - [ swap drop 0 growable-read-until f like f ] keep - delete-all - ] if ; - -M: growable stream-read - [ - drop f - ] [ - [ length swap - 0 max ] keep - [ swap growable-read-until ] 2keep - set-length - ] if-empty ; - -M: growable stream-read-partial - stream-read ; +M: string-reader stream-read-partial stream-read ; +M: string-reader stream-read sequence-read ; +M: string-reader stream-read1 sequence-read1 ; +M: string-reader stream-read-until sequence-read-until ; +M: string-reader dispose drop ; : ( str -- stream ) - >sbuf dup reverse-here null-encoding ; + 0 string-reader boa null-encoding ; : with-string-reader ( str quot -- ) [ ] dip with-input-stream ; inline 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/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/math/functions/functions.factor b/basis/math/functions/functions.factor index 65c13f29fc..a87b3995d7 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -29,7 +29,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/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/random/random.factor b/basis/random/random.factor index c277ef8dbc..ebde3802b4 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/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 fadfadd885..6e7774aba1 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -512,9 +512,9 @@ 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 +[ [ [ 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 8556167009..3f4267df15 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 2ce19220a5..f0d9a084b1 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/ui.factor b/basis/ui/ui.factor index 3391154234..42885aecb7 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -146,7 +146,7 @@ PRIVATE> : 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/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 11a2a6d1a8..cb68b1c4fe 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -65,12 +65,12 @@ SYMBOL: error-stream : bl ( -- ) " " write ; : lines ( stream -- seq ) - [ [ readln dup ] [ ] [ drop ] produce ] with-input-stream ; + [ [ readln dup ] [ ] produce nip ] with-input-stream ; @@ -79,8 +79,7 @@ PRIVATE> : 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/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor new file mode 100644 index 0000000000..bbb3576c05 --- /dev/null +++ b/core/io/streams/sequence/sequence.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: sequences io kernel accessors math math.order ; +IN: io.streams.sequence + +SLOT: underlying +SLOT: i + +: >sequence-stream< ( stream -- i underlying ) + [ i>> ] [ underlying>> ] bi ; inline + +: next ( stream -- ) + [ 1+ ] change-i drop ; + +: sequence-read1 ( stream -- elt/f ) + [ >sequence-stream< ?nth ] + [ next ] bi ; inline + +: add-length ( n stream -- i+n ) + [ i>> + ] [ underlying>> length ] bi min ; + +: (sequence-read) ( n stream -- seq/f ) + [ add-length ] keep + [ [ swap dup ] change-i drop ] + [ underlying>> ] bi + subseq ; inline + +: sequence-read ( n stream -- seq/f ) + dup >sequence-stream< bounds-check? + [ (sequence-read) ] [ 2drop f ] if ; inline + +: find-sep ( seps stream -- sep/f n ) + swap [ >sequence-stream< ] dip + [ memq? ] curry find-from swap ; inline + +: sequence-read-until ( separators stream -- seq sep/f ) + [ find-sep ] keep + [ sequence-read ] [ next ] bi swap ; inline diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 427e5d17e3..9c5d6f56ea 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -765,15 +765,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 @@ -794,18 +794,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 } -"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 } "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/kernel/kernel.factor b/core/kernel/kernel.factor index 06fe289281..cf4bf95db9 100644 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -185,21 +185,20 @@ 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: ( -- ? ) -- ) [ 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 64ada4c052..e88caa7703 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/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 43d8ed9a32..8c5622d64a 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -913,24 +913,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 44cc2595a9..992f822507 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -481,14 +481,14 @@ PRIVATE> : accumulator ( quot -- quot' vec ) V{ } clone [ [ push ] curry compose ] keep ; inline -: produce-as ( pred quot tail exemplar -- seq ) - [ swap accumulator [ swap while ] 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/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 ef9ada9591..30ecb70ed9 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/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> 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/id3/id3-tests.factor b/extra/id3/id3-tests.factor index eabbf00ad7..aefbec8550 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -20,7 +20,7 @@ IN: id3.tests "2009" "COMMENT" "Bluegrass" -] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test +] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test [ "Anthem of the Trinity" @@ -29,7 +29,7 @@ IN: id3.tests f f "Classical" -] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test +] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test [ "Stormy Weather" @@ -38,5 +38,5 @@ IN: id3.tests f "eng, AG# 08E1C12E" "Big Band" -] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test +] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor index a4adeedaa5..f01c400338 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -4,140 +4,39 @@ USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays io.encodings.string io.encodings.utf16 assocs math.parser -combinators.short-circuit fry namespaces multiline -combinators.smart splitting io.encodings.ascii ; +combinators.short-circuit fry namespaces combinators.smart +splitting io.encodings.ascii arrays ; IN: id3 ( -- object ) id3-info new ; +: ( -- object ) id3v1-info new ; : ( header frames -- object ) [ [ frame-id>> ] keep ] H{ } map>assoc @@ -186,25 +85,12 @@ TUPLE: id3-info title artist album year comment genre ; : filter-text-data ( data -- filtered ) [ printable? ] filter ; inline -! frame details stuff - : valid-frame-id? ( id -- ? ) [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline -: read-frame-id ( mmap -- id ) - 4 head-slice ; inline - -: read-frame-size ( mmap -- size ) - [ 4 8 ] dip subseq ; inline - -: read-frame-flags ( mmap -- flags ) - [ 8 10 ] dip subseq ; inline - : read-frame-data ( frame mmap -- frame data ) [ 10 over size>> 10 + ] dip filter-text-data ; inline -! read whole frames - : decode-text ( string -- string' ) dup 2 short head { { HEX: ff HEX: fe } { HEX: fe HEX: ff } } member? @@ -213,14 +99,14 @@ TUPLE: id3-info title artist album year comment genre ; : (read-frame) ( mmap -- frame ) [ ] dip { - [ read-frame-id decode-text >>frame-id ] - [ read-frame-flags >byte-array >>flags ] - [ read-frame-size >28bitword >>size ] + [ 4 head-slice decode-text >>frame-id ] + [ [ 4 8 ] dip subseq >28bitword >>size ] + [ [ 8 10 ] dip subseq >byte-array >>flags ] [ read-frame-data decode-text >>data ] } cleave ; : read-frame ( mmap -- frame/f ) - dup read-frame-id valid-frame-id? + dup 4 head-slice valid-frame-id? [ (read-frame) ] [ drop f ] if ; : remove-frame ( mmap frame -- mmap ) @@ -229,58 +115,36 @@ TUPLE: id3-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 -: read-header-supported-version? ( mmap -- ? ) - 3 tail-slice first { 3 4 } member? ; inline - -: read-header-flags ( mmap -- flags ) 5 swap nth ; inline - -: read-header-size ( mmap -- size ) - [ 6 10 ] dip >28bitword ; inline - -: read-v2-header ( mmap -- id3header ) +: read-v2-header ( seq -- id3header ) [
] dip { - [ read-header-supported-version? >>version ] - [ read-header-flags >>flags ] - [ read-header-size >>size ] + [ [ 3 5 ] dip >array >>version ] + [ [ 5 ] dip nth >>flags ] + [ [ 6 10 ] dip >28bitword >>size ] } cleave ; inline -: drop-header ( mmap -- seq1 seq2 ) - [ 10 tail-slice ] [ ] bi ; inline - : read-v2-tag-data ( seq -- id3v2-info ) - drop-header read-v2-header - swap read-frames ; inline + 10 cut-slice + [ read-v2-header ] + [ read-frames ] bi* ; inline ! v1 information : skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline -: read-title ( seq -- title ) 30 head-slice ; inline - -: read-artist ( seq -- title ) [ 30 60 ] dip subseq ; inline - -: read-album ( seq -- album ) [ 60 90 ] dip subseq ; inline - -: read-year ( seq -- year ) [ 90 94 ] dip subseq ; inline - -: read-comment ( seq -- comment ) [ 94 124 ] dip subseq ; inline - -: read-genre ( seq -- genre ) [ 124 ] dip nth ; inline - : (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip + [ ] dip { - [ read-title decode-text filter-text-data >>title ] - [ read-artist decode-text filter-text-data >>artist ] - [ read-album decode-text filter-text-data >>album ] - [ read-year decode-text filter-text-data >>year ] - [ read-comment decode-text filter-text-data >>comment ] - [ read-genre number>string >>genre ] + [ 30 head-slice decode-text filter-text-data >>title ] + [ [ 30 60 ] dip subseq decode-text filter-text-data >>artist ] + [ [ 60 90 ] dip subseq decode-text filter-text-data >>album ] + [ [ 90 94 ] dip subseq decode-text filter-text-data >>year ] + [ [ 94 124 ] dip subseq decode-text filter-text-data >>comment ] + [ [ 124 ] dip nth number>string >>genre ] } cleave ; inline : read-v1-tag-data ( seq -- mp3-file ) diff --git a/extra/iokit/iokit.factor b/extra/iokit/iokit.factor index f5ede8f8ec..f7ea81c0c2 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/irc/ui/ui.factor b/extra/irc/ui/ui.factor index 791639d260..f360273fda 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/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/otug-talk/otug-talk.factor b/extra/otug-talk/otug-talk.factor index ef5782dda7..16ee2b740b 100644 --- a/extra/otug-talk/otug-talk.factor +++ b/extra/otug-talk/otug-talk.factor @@ -223,7 +223,7 @@ CONSTANT: otug-slides } { $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/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/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/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/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/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 / ; 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