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/editors/editpadlite/editpadlite.factor b/basis/editors/editpadlite/editpadlite.factor index d487ca776f..043ef7ef27 100644 --- a/basis/editors/editpadlite/editpadlite.factor +++ b/basis/editors/editpadlite/editpadlite.factor @@ -5,7 +5,7 @@ IN: editors.editpadlite : editpadlite-path ( -- path ) \ editpadlite-path get-global [ - "JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files + "JGsoft" [ >lower "editpadlite.exe" tail? ] find-in-program-files [ "editpadlite.exe" ] unless* ] unless* ; diff --git a/basis/editors/editpadpro/editpadpro.factor b/basis/editors/editpadpro/editpadpro.factor index 09bfd69de8..571c20fd6a 100644 --- a/basis/editors/editpadpro/editpadpro.factor +++ b/basis/editors/editpadpro/editpadpro.factor @@ -5,7 +5,7 @@ IN: editors.editpadpro : editpadpro-path ( -- path ) \ editpadpro-path get-global [ - "JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files + "JGsoft" [ >lower "editpadpro.exe" tail? ] find-in-program-files [ "editpadpro.exe" ] unless* ] unless* ; diff --git a/basis/editors/editplus/editplus.factor b/basis/editors/editplus/editplus.factor index affbcd4eb6..a3150dc961 100644 --- a/basis/editors/editplus/editplus.factor +++ b/basis/editors/editplus/editplus.factor @@ -5,7 +5,7 @@ IN: editors.editplus : editplus-path ( -- path ) \ editplus-path get-global [ - "EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files + "EditPlus 2" [ "editplus.exe" tail? ] find-in-program-files [ "editplus.exe" ] unless* ] unless* ; diff --git a/basis/editors/emacs/windows/windows.factor b/basis/editors/emacs/windows/windows.factor index e18c39ed60..91d6e878e4 100755 --- a/basis/editors/emacs/windows/windows.factor +++ b/basis/editors/emacs/windows/windows.factor @@ -6,7 +6,7 @@ IN: editors.emacs.windows M: windows default-emacsclient { - [ "Emacs" t [ "emacsclientw.exe" tail? ] find-in-program-files ] - [ "Emacs" t [ "emacsclient.exe" tail? ] find-in-program-files ] + [ "Emacs" [ "emacsclientw.exe" tail? ] find-in-program-files ] + [ "Emacs" [ "emacsclient.exe" tail? ] find-in-program-files ] [ "emacsclient.exe" ] } 0|| ; diff --git a/basis/editors/emeditor/emeditor.factor b/basis/editors/emeditor/emeditor.factor index 52c52bbb8b..3380f5c974 100644 --- a/basis/editors/emeditor/emeditor.factor +++ b/basis/editors/emeditor/emeditor.factor @@ -5,7 +5,7 @@ IN: editors.emeditor : emeditor-path ( -- path ) \ emeditor-path get-global [ - "EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files + "EmEditor" [ "EmEditor.exe" tail? ] find-in-program-files [ "EmEditor.exe" ] unless* ] unless* ; diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor index 37c8d1b572..8b76b3b473 100755 --- a/basis/editors/etexteditor/etexteditor.factor +++ b/basis/editors/etexteditor/etexteditor.factor @@ -6,7 +6,7 @@ IN: editors.etexteditor : etexteditor-path ( -- str ) \ etexteditor-path get-global [ - "e" t [ "e.exe" tail? ] find-in-program-files + "e" [ "e.exe" tail? ] find-in-program-files [ "e" ] unless* ] unless* ; diff --git a/basis/editors/gvim/windows/windows.factor b/basis/editors/gvim/windows/windows.factor index 4edc13b90c..3fe228a403 100644 --- a/basis/editors/gvim/windows/windows.factor +++ b/basis/editors/gvim/windows/windows.factor @@ -5,6 +5,6 @@ IN: editors.gvim.windows M: windows gvim-path \ gvim-path get-global [ - "vim" t [ "gvim.exe" tail? ] find-in-program-files + "vim" [ "gvim.exe" tail? ] find-in-program-files [ "gvim.exe" ] unless* ] unless* ; diff --git a/basis/editors/notepadpp/notepadpp.factor b/basis/editors/notepadpp/notepadpp.factor index 1c856bd761..7b0f2bb72a 100644 --- a/basis/editors/notepadpp/notepadpp.factor +++ b/basis/editors/notepadpp/notepadpp.factor @@ -4,7 +4,7 @@ IN: editors.notepadpp : notepadpp-path ( -- path ) \ notepadpp-path get-global [ - "notepad++" t [ "notepad++.exe" tail? ] find-in-program-files + "notepad++" [ "notepad++.exe" tail? ] find-in-program-files [ "notepad++.exe" ] unless* ] unless* ; diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index fc7e9e319e..7e8a540b73 100644 --- a/basis/editors/scite/scite.factor +++ b/basis/editors/scite/scite.factor @@ -7,11 +7,11 @@ IN: editors.scite : scite-path ( -- path ) \ scite-path get-global [ - "Scintilla Text Editor" t + "Scintilla Text Editor" [ >lower "scite.exe" tail? ] find-in-program-files [ - "SciTE Source Code Editor" t + "SciTE Source Code Editor" [ >lower "scite.exe" tail? ] find-in-program-files ] unless* [ "scite.exe" ] unless* diff --git a/basis/editors/ted-notepad/ted-notepad.factor b/basis/editors/ted-notepad/ted-notepad.factor index 301e82225c..6f954febe8 100644 --- a/basis/editors/ted-notepad/ted-notepad.factor +++ b/basis/editors/ted-notepad/ted-notepad.factor @@ -4,7 +4,7 @@ IN: editors.ted-notepad : ted-notepad-path ( -- path ) \ ted-notepad-path get-global [ - "TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files + "TED Notepad" [ "TedNPad.exe" tail? ] find-in-program-files [ "TedNPad.exe" ] unless* ] unless* ; diff --git a/basis/editors/textpad/textpad.factor b/basis/editors/textpad/textpad.factor index ca9d5c486a..925f75400f 100644 --- a/basis/editors/textpad/textpad.factor +++ b/basis/editors/textpad/textpad.factor @@ -5,7 +5,7 @@ IN: editors.textpad : textpad-path ( -- path ) \ textpad-path get-global [ - "TextPad 5" t [ "TextPad.exe" tail? ] find-in-program-files + "TextPad 5" [ "TextPad.exe" tail? ] find-in-program-files [ "TextPad.exe" ] unless* ] unless* ; diff --git a/basis/editors/ultraedit/ultraedit.factor b/basis/editors/ultraedit/ultraedit.factor index b5bc229743..3069d78925 100644 --- a/basis/editors/ultraedit/ultraedit.factor +++ b/basis/editors/ultraedit/ultraedit.factor @@ -4,7 +4,7 @@ IN: editors.ultraedit : ultraedit-path ( -- path ) \ ultraedit-path get-global [ - "IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files + "IDM Computer Solutions" [ "uedit32.exe" tail? ] find-in-program-files [ "uedit32.exe" ] unless* ] unless* ; diff --git a/basis/editors/wordpad/wordpad.factor b/basis/editors/wordpad/wordpad.factor index ef670d5d28..103b69ba4c 100644 --- a/basis/editors/wordpad/wordpad.factor +++ b/basis/editors/wordpad/wordpad.factor @@ -4,7 +4,7 @@ IN: editors.wordpad : wordpad-path ( -- path ) \ wordpad-path get [ - "Windows NT\\Accessories" t + "Windows NT\\Accessories" [ "wordpad.exe" tail? ] find-in-program-files ] unless* ; 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 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/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/search/search-docs.factor b/basis/io/directories/search/search-docs.factor index 99135b7953..818899606d 100644 --- a/basis/io/directories/search/search-docs.factor +++ b/basis/io/directories/search/search-docs.factor @@ -38,7 +38,7 @@ HELP: find-in-directories HELP: find-all-files { $values - { "path" "a pathname string" } { "bfs?" "a boolean, breadth-first or depth-first" } { "quot" quotation } + { "path" "a pathname string" } { "quot" quotation } { "paths/f" "a sequence of pathname strings or f" } } { $description "Finds all files in the input directory matching the predicate quotation in a breadth-first or depth-first traversal." } ; diff --git a/basis/io/directories/search/search-tests.factor b/basis/io/directories/search/search-tests.factor index a8b8bf9215..ba1b9cdbe1 100644 --- a/basis/io/directories/search/search-tests.factor +++ b/basis/io/directories/search/search-tests.factor @@ -5,6 +5,6 @@ IN: io.directories.search.tests [ t ] [ [ 10 [ "io.paths.test" "gogogo" make-unique-file ] replicate - current-temporary-directory get t [ ] find-all-files + current-temporary-directory get [ ] find-all-files ] with-unique-directory drop [ natural-sort ] bi@ = ] unit-test diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor index b56fb7b6a3..ee8fd129a7 100755 --- a/basis/io/directories/search/search.factor +++ b/basis/io/directories/search/search.factor @@ -51,7 +51,8 @@ PRIVATE> [ keep and ] curry iterate-directory ] [ drop f ] recover ; inline -: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths/f ) +: find-all-files ( path quot: ( obj -- ? ) -- paths/f ) + f swap '[ _ _ _ [ ] dip pusher [ [ f ] compose iterate-directory drop ] dip diff --git a/basis/io/directories/search/windows/windows.factor b/basis/io/directories/search/windows/windows.factor index 755710befd..cda9403417 100644 --- a/basis/io/directories/search/windows/windows.factor +++ b/basis/io/directories/search/windows/windows.factor @@ -7,7 +7,7 @@ IN: io.directories.search.windows : program-files-directories ( -- array ) program-files program-files-x86 2array harvest ; inline -: find-in-program-files ( base-directory bfs? quot -- path ) - [ +: find-in-program-files ( base-directory quot -- path ) + t swap [ [ program-files-directories ] dip '[ _ append-path ] map ] 2dip find-in-directories ; inline 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/mmap/mmap-tests.factor b/basis/io/mmap/mmap-tests.factor index 166167a7e7..a4d55f3c1e 100644 --- a/basis/io/mmap/mmap-tests.factor +++ b/basis/io/mmap/mmap-tests.factor @@ -1,6 +1,6 @@ USING: io io.mmap io.mmap.char io.files io.files.temp io.directories kernel tools.test continuations sequences -io.encodings.ascii accessors ; +io.encodings.ascii accessors math ; IN: io.mmap.tests [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors @@ -9,3 +9,13 @@ IN: io.mmap.tests [ 5 ] [ "mmap-test-file.txt" temp-file [ length ] with-mapped-char-file ] unit-test [ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test [ "mmap-test-file.txt" temp-file delete-file ] ignore-errors + + +[ "mmap-empty-file.txt" temp-file delete-file ] ignore-errors +[ ] [ "mmap-empty-file.txt" temp-file touch-file ] unit-test + +[ + "mmap-empty-file.txt" temp-file [ + drop + ] with-mapped-file +] [ bad-mmap-size? ] must-fail-with diff --git a/basis/io/mmap/mmap.factor b/basis/io/mmap/mmap.factor index 6f2fabb709..1a58471514 100644 --- a/basis/io/mmap/mmap.factor +++ b/basis/io/mmap/mmap.factor @@ -2,15 +2,20 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations destructors io.files io.files.info io.backend kernel quotations system alien alien.accessors -accessors system vocabs.loader combinators alien.c-types ; +accessors system vocabs.loader combinators alien.c-types +math ; IN: io.mmap TUPLE: mapped-file address handle length disposed ; HOOK: (mapped-file) os ( path length -- address handle ) +ERROR: bad-mmap-size path size ; + : ( path -- mmap ) - [ normalize-path ] [ file-info size>> ] bi [ (mapped-file) ] keep + [ normalize-path ] [ file-info size>> ] bi + dup 0 <= [ bad-mmap-size ] when + [ (mapped-file) ] keep f mapped-file boa ; HOOK: close-mapped-file io-backend ( mmap -- ) diff --git a/basis/io/mmap/unix/unix.factor b/basis/io/mmap/unix/unix.factor index 9325dcd632..0fa8e1151f 100644 --- a/basis/io/mmap/unix/unix.factor +++ b/basis/io/mmap/unix/unix.factor @@ -9,7 +9,7 @@ IN: io.mmap.unix :: mmap-open ( path length prot flags -- alien fd ) [ f length prot flags - path open-r/w |dispose + path open-r/w [ |dispose drop ] keep [ 0 mmap dup MAP_FAILED = [ (io-error) ] when ] keep ] with-destructors ; 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/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 7e2ac0884c..964074512a 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 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/errors/errors.factor b/basis/stack-checker/errors/errors.factor index 6a9a7cb8af..7f35ece714 100644 --- a/basis/stack-checker/errors/errors.factor +++ b/basis/stack-checker/errors/errors.factor @@ -80,4 +80,4 @@ TUPLE: inconsistent-recursive-call-error word ; TUPLE: unknown-primitive-error ; : unknown-primitive-error ( -- * ) - \ unknown-primitive-error inference-error ; + \ unknown-primitive-error inference-warning ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0c20c41d99..1b4d9012db 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -141,9 +141,7 @@ M: object infer-call* apply-word/effect ; : infer-exit ( -- ) - \ exit - { integer } { } t >>terminated? - apply-word/effect ; + \ exit (( n -- * )) apply-word/effect ; : infer-load-locals ( -- ) pop-literal nip @@ -189,7 +187,7 @@ M: object infer-call* { \ load-locals [ infer-load-locals ] } { \ get-local [ infer-get-local ] } { \ drop-locals [ infer-drop-locals ] } - { \ do-primitive [ unknown-primitive-error inference-warning ] } + { \ do-primitive [ unknown-primitive-error ] } { \ alien-invoke [ infer-alien-invoke ] } { \ alien-indirect [ infer-alien-indirect ] } { \ alien-callback [ infer-alien-callback ] } @@ -207,7 +205,7 @@ M: object infer-call* { declare call (call) slip 2slip 3slip dip 2dip 3dip curry compose execute (execute) if dispatch - (throw) load-local load-locals get-local drop-locals do-primitive + (throw) exit load-local load-locals get-local drop-locals do-primitive alien-invoke alien-indirect alien-callback } [ t "special" set-word-prop ] each diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index bc6eb9f092..6e7774aba1 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -6,7 +6,8 @@ quotations effects tools.test continuations generic.standard sorting assocs definitions prettyprint io inspector classes.tuple classes.union classes.predicate debugger threads.private io.streams.string io.timeouts io.thread -sequences.private destructors combinators eval locals.backend ; +sequences.private destructors combinators eval locals.backend +system ; IN: stack-checker.tests \ infer. must-infer @@ -511,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 @@ -581,4 +582,6 @@ DEFER: eee' : debugging-curry-folding ( quot -- ) [ debugging-curry-folding ] curry call ; inline recursive -[ [ ] debugging-curry-folding ] must-infer \ No newline at end of file +[ [ ] debugging-curry-folding ] must-infer + +[ [ exit ] [ 1 2 3 ] if ] must-infer \ No newline at end of file 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 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/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/checksums/crc32/crc32.factor b/core/checksums/crc32/crc32.factor index 7ea2964411..47da144d4d 100644 --- a/core/checksums/crc32/crc32.factor +++ b/core/checksums/crc32/crc32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences sequences.private namespaces -words io io.binary io.files io.streams.string quotations +words io io.binary io.files quotations definitions checksums ; IN: checksums.crc32 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..7933dd86ca --- /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 ; inline + +: sequence-read1 ( stream -- elt/f ) + [ >sequence-stream< ?nth ] + [ next ] bi ; inline + +: add-length ( n stream -- i+n ) + [ i>> + ] [ underlying>> length ] bi min ; inline + +: (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/io/streams/string/string-tests.factor b/core/io/streams/string/string-tests.factor index a6502046c8..967c0d4613 100644 --- a/core/io/streams/string/string-tests.factor +++ b/core/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/core/io/streams/string/string.factor b/core/io/streams/string/string.factor index 4582490726..73bf5f5efe 100644 --- a/core/io/streams/string/string.factor +++ b/core/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/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 342376fb22..800bc86b66 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -638,15 +638,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 @@ -667,18 +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 } -"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 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/math/math-docs.factor b/core/math/math-docs.factor index 94ff2c1f29..101557d0cf 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -308,7 +308,7 @@ HELP: find-last-integer HELP: byte-array>bignum { $values { "byte-array" byte-array } { "n" integer } } -{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link >le } " or " { $link >be } " instead." } ; +{ $description "Converts a byte-array, interpreted as little-endian, into a bignum integer. User code should call " { $link le> } " or " { $link be> } " instead." } ; ARTICLE: "division-by-zero" "Division by zero" "Floating point division never raises an error if the denominator is zero. This means that if at least one of the two inputs to " { $link / } ", " { $link /f } " or " { $link mod } " is a float, the result will be a floating point infinity or not a number value." 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 9e64cfa536..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 ) - [ 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 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/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/authors.txt b/extra/id3/authors.txt index ece617b969..2bd5c6037e 100644 --- a/extra/id3/authors.txt +++ b/extra/id3/authors.txt @@ -1,2 +1,2 @@ Tim Wawrzynczak - +Doug Coleman diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor index a54bba1629..d171d03798 100644 --- a/extra/id3/id3-docs.factor +++ b/extra/id3/id3-docs.factor @@ -6,7 +6,7 @@ IN: id3 HELP: file-id3-tags { $values { "path" "a path string" } - { "object/f" "a tuple storing ID3 metadata or f" } } + { "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } } { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: " $nl { $link title>> } $nl { $link artist>> } diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor index bcdc312440..aefbec8550 100644 --- a/extra/id3/id3-tests.factor +++ b/extra/id3/id3-tests.factor @@ -1,35 +1,42 @@ ! Copyright (C) 2009 Tim Wawrzynczak ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test id3 id3.private ; +USING: tools.test id3 combinators ; IN: id3.tests -[ - T{ id3-info - { title "BLAH" } - { artist "ARTIST" } - { album "ALBUM" } - { year "2009" } - { comment "COMMENT" } - { genre "Bluegrass" } - } -] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test +: id3-params ( id3 -- title artist album year comment genre ) + { + [ id3-title ] + [ id3-artist ] + [ id3-album ] + [ id3-year ] + [ id3-comment ] + [ id3-genre ] + } cleave ; [ - T{ id3-info - { title "Anthem of the Trinity" } - { artist "Terry Riley" } - { album "Shri Camel" } - { genre "Classical" } - } -] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test + "BLAH" + "ARTIST" + "ALBUM" + "2009" + "COMMENT" + "Bluegrass" +] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test + +[ + "Anthem of the Trinity" + "Terry Riley" + "Shri Camel" + f + f + "Classical" +] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test [ - T{ id3-info - { title "Stormy Weather" } - { artist "Frank Sinatra" } - { album "Night and Day Frank Sinatra" } - { comment "eng, AG# 08E1C12E" } - { genre "Big Band" } - } -] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test + "Stormy Weather" + "Frank Sinatra" + "Night and Day Frank Sinatra" + f + "eng, AG# 08E1C12E" + "Big Band" +] [ "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 f2bbd08996..f01c400338 100644 --- a/extra/id3/id3.factor +++ b/extra/id3/id3.factor @@ -1,142 +1,43 @@ -! Copyright (C) 2009 Tim Wawrzynczak +! Copyright (C) 2009 Tim Wawrzynczak, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -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.utf8 assocs math.parser ; +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 combinators.smart +splitting io.encodings.ascii arrays ; IN: id3 ( -- object ) id3-info new ; +: ( -- object ) id3v1-info new ; -: ( header frames -- object ) id3v2-info boa ; +: ( header frames -- object ) + [ [ frame-id>> ] keep ] H{ } map>assoc + id3v2-info boa ; :
( -- object ) header new ; : ( -- object ) frame new ; -! utility words - -: id3v2? ( mmap -- ? ) - "ID3" head? ; +: id3v2? ( mmap -- ? ) "ID3" head? ; inline : id3v1? ( mmap -- ? ) - 128 tail-slice* "TAG" head? ; + { [ length 128 >= ] [ 128 tail-slice* "TAG" head? ] } 1&& ; inline + +: id3v1-frame ( string key -- frame ) + + swap >>frame-id + swap >>data ; + +: id3v1>id3v2 ( id3v1 -- id3v2 ) + [ + { + [ title>> "TIT2" id3v1-frame ] + [ artist>> "TPE1" id3v1-frame ] + [ album>> "TALB" id3v1-frame ] + [ year>> "TYER" id3v1-frame ] + [ comment>> "COMM" id3v1-frame ] + [ genre>> "TCON" id3v1-frame ] + } cleave + ] output>array f swap ; : >28bitword ( seq -- int ) - 0 [ swap 7 shift bitor ] reduce ; + 0 [ [ 7 shift ] dip bitor ] reduce ; inline : filter-text-data ( data -- filtered ) - [ printable? ] filter ; - -! frame details stuff + [ printable? ] filter ; inline : valid-frame-id? ( id -- ? ) - [ [ digit? ] [ LETTER? ] bi or ] all? ; - -: read-frame-id ( mmap -- id ) - 4 head-slice ; - -: read-frame-size ( mmap -- size ) - [ 4 8 ] dip subseq ; - -: read-frame-flags ( mmap -- flags ) - [ 8 10 ] dip subseq ; + [ { [ digit? ] [ LETTER? ] } 1|| ] all? ; inline : read-frame-data ( frame mmap -- frame data ) - [ 10 over size>> 10 + ] dip filter-text-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? + utf16 ascii ? decode ; inline : (read-frame) ( mmap -- frame ) [ ] dip { - [ read-frame-id utf8 decode >>frame-id ] - [ read-frame-flags >byte-array >>flags ] - [ read-frame-size >28bitword >>size ] - [ read-frame-data utf8 decode >>data ] + [ 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? [ (read-frame) ] [ drop f ] if ; + dup 4 head-slice valid-frame-id? + [ (read-frame) ] [ drop f ] if ; : remove-frame ( mmap frame -- mmap ) - size>> 10 + tail-slice ; + size>> 10 + tail-slice ; inline : 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 [ { 4 } head? ] [ { 3 } head? ] bi or ; - -: read-header-flags ( mmap -- flags ) - 5 swap nth ; - -: read-header-size ( mmap -- size ) - [ 6 10 ] dip >28bitword ; - -: read-v2-header ( mmap -- id3header ) +: read-v2-header ( seq -- id3header ) [
] dip { - [ read-header-supported-version? >>version ] - [ read-header-flags >>flags ] - [ read-header-size >>size ] - } cleave ; + [ [ 3 5 ] dip >array >>version ] + [ [ 5 ] dip nth >>flags ] + [ [ 6 10 ] dip >28bitword >>size ] + } cleave ; inline -: drop-header ( mmap -- seq1 seq2 ) - dup 10 tail-slice swap ; - -: parse-frames ( id3v2-info -- id3-info ) - [ ] dip frames>> - { - [ [ frame-id>> "TIT2" = ] find nip [ data>> >>title ] when* ] - [ [ frame-id>> "TALB" = ] find nip [ data>> >>album ] when* ] - [ [ frame-id>> "TPE1" = ] find nip [ data>> >>artist ] when* ] - [ [ frame-id>> "TCON" = ] find nip [ data>> [ [ digit? ] filter string>number ] keep swap [ genres at nip ] when* - >>genre ] when* ] - [ [ frame-id>> "COMM" = ] find nip [ data>> >>comment ] when* ] - [ [ frame-id>> "TYER" = ] find nip [ data>> >>year ] when* ] - } cleave ; - -: read-v2-tag-data ( seq -- id3-info ) - drop-header read-v2-header swap read-frames parse-frames ; +: read-v2-tag-data ( seq -- id3v2-info ) + 10 cut-slice + [ read-v2-header ] + [ read-frames ] bi* ; inline ! v1 information -: skip-to-v1-data ( seq -- seq ) - 125 tail-slice* ; - -: read-title ( seq -- title ) - 30 head-slice ; - -: read-artist ( seq -- title ) - [ 30 60 ] dip subseq ; - -: read-album ( seq -- album ) - [ 60 90 ] dip subseq ; - -: read-year ( seq -- year ) - [ 90 94 ] dip subseq ; - -: read-comment ( seq -- comment ) - [ 94 124 ] dip subseq ; - -: read-genre ( seq -- genre ) - [ 124 ] dip nth ; +: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline : (read-v1-tag-data) ( seq -- mp3-file ) - [ ] dip + [ ] dip { - [ read-title utf8 decode filter-text-data >>title ] - [ read-artist utf8 decode filter-text-data >>artist ] - [ read-album utf8 decode filter-text-data >>album ] - [ read-year utf8 decode filter-text-data >>year ] - [ read-comment utf8 decode filter-text-data >>comment ] - [ read-genre >fixnum genres at >>genre ] - } cleave ; + [ 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 ) - skip-to-v1-data (read-v1-tag-data) ; + skip-to-v1-data (read-v1-tag-data) ; inline + +: parse-genre ( string -- n/f ) + dup "(" ?head-slice drop ")" ?tail-slice drop + string>number dup number? [ + genres ?nth swap or + ] [ + drop + ] if ; inline PRIVATE> -! public interface +: frame-named ( id3 name quot -- obj ) + [ swap frames>> at* ] dip + [ data>> ] prepose [ drop f ] if ; inline -: file-id3-tags ( path -- object/f ) +: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline + +: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline + +: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline + +: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline + +: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline + +: id3-genre ( id3 -- genre/f ) + "TCON" [ parse-genre ] frame-named ; inline + +: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline + +: file-id3-tags ( path -- id3v2-info/f ) [ { - { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- id3v2 ) - { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- id3-info ) - [ drop f ] ! ( mmap -- f ) + { [ dup id3v2? ] [ read-v2-tag-data ] } + { [ dup id3v1? ] [ read-v1-tag-data id3v1>id3v2 ] } + [ drop f ] } cond ] with-mapped-uchar-file ; - -! end 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/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/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 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) 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