steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2009-03-01 22:24:30 -05:00
parent 4ea52147e3 c57dbf8d48
commit 2152a5c97f
70 changed files with 146 additions and 127 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bit-arrays/bit-arrays.factor
View File

@ -78,7 +78,7 @@ M: bit-array byte-length length 7 + -3 shift ;
[ dup 0 = ] [ [ dup 0 = ] [
[ pick underlying>> pick set-alien-unsigned-1 ] keep [ pick underlying>> pick set-alien-unsigned-1 ] keep
[ 1+ ] [ -8 shift ] bi* [ 1+ ] [ -8 shift ] bi*
] [ ] until 2drop ] until 2drop
] if ; ] if ;
: bit-array>integer ( bit-array -- n ) : bit-array>integer ( bit-array -- n )

2
basis/bootstrap/image/image.factor
View File

@ -240,7 +240,7 @@ GENERIC: ' ( obj -- ptr )
#! n is positive or zero. #! n is positive or zero.
[ dup 0 > ] [ dup 0 > ]
[ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ] [ [ bignum-bits neg shift ] [ bignum-radix bitand ] bi ]
[ ] produce nip ; produce nip ;
: emit-bignum ( n -- ) : emit-bignum ( n -- )
dup dup 0 < [ neg ] when bignum>seq dup dup 0 < [ neg ] when bignum>seq

2
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -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 } ] [ [ 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 } ] [ [ V{ float } ] [
[ { float } declare 10 [ 2.3 * ] times ] final-classes [ { float } declare 10 [ 2.3 * ] times ] final-classes

4
basis/concurrency/mailboxes/mailboxes.factor
View File

@ -51,13 +51,13 @@ M: mailbox dispose* threads>> notify-all ;
block-if-empty block-if-empty
[ dup mailbox-empty? ] [ dup mailbox-empty? ]
[ dup data>> pop-back ] [ dup data>> pop-back ]
[ ] produce nip ; produce nip ;
: mailbox-get-all ( mailbox -- array ) : mailbox-get-all ( mailbox -- array )
f mailbox-get-all-timeout ; f mailbox-get-all-timeout ;
: while-mailbox-empty ( mailbox quot -- ) : while-mailbox-empty ( mailbox quot -- )
[ '[ _ mailbox-empty? ] ] dip [ ] while ; inline [ '[ _ mailbox-empty? ] ] dip while ; inline
: mailbox-get-timeout? ( mailbox timeout pred -- obj ) : mailbox-get-timeout? ( mailbox timeout pred -- obj )
[ block-unless-pred ] [ block-unless-pred ]

2
basis/deques/deques.factor
View File

@ -36,6 +36,6 @@ GENERIC: deque-empty? ( deque -- ? )
: slurp-deque ( deque quot -- ) : slurp-deque ( deque quot -- )
[ drop '[ _ deque-empty? not ] ] [ drop '[ _ deque-empty? not ] ]
[ '[ _ pop-back @ ] ] [ '[ _ pop-back @ ] ]
2bi [ ] while ; inline 2bi while ; inline
MIXIN: deque MIXIN: deque

3
basis/environment/winnt/winnt.factor
View File

@ -27,7 +27,6 @@ M: winnt (os-envs) ( -- seq )
GetEnvironmentStrings [ GetEnvironmentStrings [
<memory-stream> [ <memory-stream> [
utf16n decode-input utf16n decode-input
[ "\0" read-until drop dup empty? not ] [ "\0" read-until drop dup empty? not ] [ ] produce nip
[ ] [ drop ] produce
] with-input-stream* ] with-input-stream*
] [ FreeEnvironmentStrings win32-error=0/f ] bi ; ] [ FreeEnvironmentStrings win32-error=0/f ] bi ;

2
basis/formatting/formatting.factor
View File

@ -41,7 +41,7 @@ IN: formatting
[ dup 10.0 >= [ dup 10.0 >=
[ 10.0 / [ 1+ ] dip ] [ 10.0 / [ 1+ ] dip ]
[ 10.0 * [ 1- ] dip ] if [ 10.0 * [ 1- ] dip ] if
] [ ] while ] while
] keep 0 < [ neg ] when ; ] keep 0 < [ neg ] when ;
: exp>string ( exp base digits -- string ) : exp>string ( exp base digits -- string )

2
basis/heaps/heaps.factor
View File

@ -190,7 +190,7 @@ M: heap heap-pop ( heap -- value key )
: heap-pop-all ( heap -- alist ) : heap-pop-all ( heap -- alist )
[ dup heap-empty? not ] [ dup heap-empty? not ]
[ dup heap-pop swap 2array ] [ dup heap-pop swap 2array ]
[ ] produce nip ; produce nip ;
: slurp-heap ( heap quot: ( elt -- ) -- ) : slurp-heap ( heap quot: ( elt -- ) -- )
over heap-empty? [ 2drop ] [ over heap-empty? [ 2drop ] [

2
basis/http/http.factor
View File

@ -12,7 +12,7 @@ base64 ;
IN: http IN: http
: (read-header) ( -- alist ) : (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' ) : collect-headers ( assoc -- assoc' )
H{ } clone [ '[ _ push-at ] assoc-each ] keep ; H{ } clone [ '[ _ push-at ] assoc-each ] keep ;

2
basis/io/directories/unix/unix.factor
View File

@ -61,5 +61,5 @@ M: unix (directory-entries) ( path -- seq )
[ [
'[ _ find-next-file dup ] '[ _ find-next-file dup ]
[ >directory-entry ] [ >directory-entry ]
[ drop ] produce produce nip
] with-unix-directory ; ] with-unix-directory ;

2
basis/io/directories/windows/windows.factor
View File

@ -61,7 +61,7 @@ M: windows (directory-entries) ( path -- seq )
'[ '[
[ _ find-next-file dup ] [ _ find-next-file dup ]
[ >directory-entry ] [ >directory-entry ]
[ drop ] produce produce nip
over name>> "." = [ nip ] [ swap prefix ] if over name>> "." = [ nip ] [ swap prefix ] if
] ]
] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ; ] [ '[ _ FindClose win32-error=0/f ] ] bi [ ] cleanup ;

4
basis/io/files/info/windows/windows.factor
View File

@ -159,9 +159,7 @@ M: winnt file-system-info ( path -- file-system-info )
find-first-volume find-first-volume
[ [
'[ '[
[ _ find-next-volume dup ] [ _ find-next-volume dup ] [ ] produce nip
[ ]
[ drop ] produce
swap prefix swap prefix
] ]
] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ; ] [ '[ _ FindVolumeClose win32-error=0/f ] ] bi [ ] cleanup ;

4
basis/io/monitors/monitors-tests.factor
View File

@ -101,13 +101,13 @@ os { winnt linux macosx } member? [
! Non-recursive ! Non-recursive
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test [ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] 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 [ ] [ "m" get dispose ] unit-test
! Recursive ! Recursive
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test [ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
[ ] [ 3 seconds "m" get set-timeout ] 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 [ ] [ "m" get dispose ] unit-test
] with-monitors ] with-monitors
] when ] when

2
basis/io/pools/pools.factor
View File

@ -35,7 +35,7 @@ GENERIC: make-connection ( pool -- conn )
: acquire-connection ( pool -- conn ) : acquire-connection ( pool -- conn )
dup check-pool dup check-pool
[ dup connections>> empty? ] [ dup new-connection ] [ ] while [ dup connections>> empty? ] [ dup new-connection ] while
connections>> pop ; connections>> pop ;
: (with-pooled-connection) ( conn pool quot -- ) : (with-pooled-connection) ( conn pool quot -- )

2
basis/io/thread/thread.factor
View File

@ -11,7 +11,7 @@ SYMBOL: io-thread-running?
sleep-time io-multiplex yield ; sleep-time io-multiplex yield ;
: start-io-thread ( -- ) : start-io-thread ( -- )
[ [ io-thread-running? get-global ] [ io-thread ] [ ] while ] [ [ io-thread-running? get-global ] [ io-thread ] while ]
"I/O wait" spawn drop ; "I/O wait" spawn drop ;
[ [

2
basis/math/combinatorics/combinatorics.factor
View File

@ -16,7 +16,7 @@ IN: math.combinatorics
! http://msdn2.microsoft.com/en-us/library/aa302371.aspx ! http://msdn2.microsoft.com/en-us/library/aa302371.aspx
: factoradic ( n -- factoradic ) : 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 ) : (>permutation) ( seq n -- seq )
[ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ; [ '[ _ dupd >= [ 1+ ] when ] map ] keep prefix ;

2
basis/math/functions/functions.factor
View File

@ -29,7 +29,7 @@ M: real sqrt
: factor-2s ( n -- r s ) : factor-2s ( n -- r s )
#! factor an integer into 2^r * s #! factor an integer into 2^r * s
dup 0 = [ 1 ] [ dup 0 = [ 1 ] [
0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while 0 swap [ dup even? ] [ [ 1+ ] [ 2/ ] bi* ] while
] if ; inline ] if ; inline
<PRIVATE <PRIVATE

4
basis/math/primes/factors/factors.factor
View File

@ -7,7 +7,7 @@ IN: math.primes.factors
: count-factor ( n d -- n' c ) : count-factor ( n d -- n' c )
[ 1 ] 2dip [ /i ] keep [ 1 ] 2dip [ /i ] keep
[ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] [ drop ] while [ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop
swap ; swap ;
: write-factor ( n d -- n' d ) : write-factor ( n d -- n' d )
@ -18,7 +18,7 @@ PRIVATE>
: group-factors ( n -- seq ) : group-factors ( n -- seq )
[ [
2 2
[ 2dup sq < ] [ write-factor next-prime ] [ ] until [ 2dup sq < ] [ write-factor next-prime ] until
drop dup 2 < [ drop ] [ 1 2array , ] if drop dup 2 < [ drop ] [ 1 2array , ] if
] { } make ; ] { } make ;

2
basis/math/primes/primes.factor
View File

@ -21,7 +21,7 @@ PRIVATE>
} cond ; foldable } cond ; foldable
: next-prime ( n -- p ) : 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 ) : primes-between ( low high -- seq )
[ dup 3 max dup even? [ 1 + ] when ] dip [ dup 3 max dup even? [ 1 + ] when ] dip

2
basis/persistent/deques/deques.factor
View File

@ -67,4 +67,4 @@ PRIVATE>
<deque> [ push-back ] reduce ; <deque> [ push-back ] reduce ;
: deque>sequence ( deque -- sequence ) : deque>sequence ( deque -- sequence )
[ dup deque-empty? not ] [ pop-front swap ] [ ] produce nip ; [ dup deque-empty? not ] [ pop-front swap ] produce nip ;

2
basis/persistent/heaps/heaps.factor
View File

@ -98,6 +98,6 @@ M: branch pheap-push
<persistent-heap> swap [ rot pheap-push ] assoc-each ; <persistent-heap> swap [ rot pheap-push ] assoc-each ;
: pheap>alist ( heap -- alist ) : 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 ; : pheap>values ( heap -- seq ) pheap>alist keys ;

4
basis/quoted-printable/quoted-printable.factor
View File

@ -32,7 +32,7 @@ IN: quoted-printable
[ 1- cut-slice swap ] [ f swap ] if* concat ; [ 1- cut-slice swap ] [ f swap ] if* concat ;
: divide-lines ( strings -- strings ) : divide-lines ( strings -- strings )
[ dup ] [ take-some ] [ ] produce nip ; [ dup ] [ take-some ] produce nip ;
PRIVATE> PRIVATE>
@ -53,7 +53,7 @@ PRIVATE>
] when ; ] when ;
: read-quoted ( -- bytes ) : read-quoted ( -- bytes )
[ read1 dup ] [ read-char ] [ drop ] B{ } produce-as ; [ read1 dup ] [ read-char ] B{ } produce-as nip ;
PRIVATE> PRIVATE>

2
basis/random/random.factor
View File

@ -55,7 +55,7 @@ PRIVATE>
: randomize ( seq -- seq ) : randomize ( seq -- seq )
dup length [ dup 1 > ] dup length [ dup 1 > ]
[ [ random ] [ 1- ] bi [ pick exchange ] keep ] [ [ random ] [ 1- ] bi [ pick exchange ] keep ]
[ ] while drop ; while drop ;
: delete-random ( seq -- elt ) : delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep delete-nth ; [ length random-integer ] keep [ nth ] 2keep delete-nth ;

2
basis/regexp/regexp.factor
View File

@ -75,7 +75,7 @@ IN: regexp
[ [ split1-slice nip ] keep ] [ 2drop f f ] if ; [ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
: all-matches ( string regexp -- seq ) : all-matches ( string regexp -- seq )
[ dup ] swap '[ _ next-match ] [ ] produce nip harvest ; [ dup ] swap '[ _ next-match ] produce nip harvest ;
: count-matches ( string regexp -- n ) : count-matches ( string regexp -- n )
all-matches length ; all-matches length ;

4
basis/stack-checker/stack-checker-tests.factor
View File

@ -512,9 +512,9 @@ ERROR: custom-error ;
[ [ missing->r-check ] infer ] must-fail [ [ missing->r-check ] infer ] must-fail
! Corner case ! 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 : erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline

2
basis/threads/threads.factor
View File

@ -115,7 +115,7 @@ DEFER: stop
sleep-queue sleep-queue
[ dup expire-sleep? ] [ dup expire-sleep? ]
[ dup heap-pop drop expire-sleep ] [ dup heap-pop drop expire-sleep ]
[ ] while while
drop ; drop ;
: start ( namestack thread -- * ) : start ( namestack thread -- * )

6
basis/tools/walker/walker.factor
View File

@ -205,7 +205,7 @@ SYMBOL: +stopped+
] ]
} case } case
] handle-synchronous ] handle-synchronous
] [ ] while ; ] while ;
: step-back-msg ( continuation -- continuation' ) : step-back-msg ( continuation -- continuation' )
walker-history tget walker-history tget
@ -233,7 +233,7 @@ SYMBOL: +stopped+
{ step-back [ step-back-msg ] } { step-back [ step-back-msg ] }
} case f } case f
] handle-synchronous ] handle-synchronous
] [ ] while ; ] while ;
: walker-loop ( -- ) : walker-loop ( -- )
+running+ set-status +running+ set-status
@ -256,7 +256,7 @@ SYMBOL: +stopped+
[ walker-suspended ] [ walker-suspended ]
} case } case
] handle-synchronous ] handle-synchronous
] [ ] until ; ] until ;
: associate-thread ( walker -- ) : associate-thread ( walker -- )
walker-thread tset walker-thread tset

2
basis/ui/event-loop/event-loop.factor
View File

@ -13,6 +13,6 @@ IN: ui.event-loop
HOOK: do-events ui-backend ( -- ) HOOK: do-events ui-backend ( -- )
: event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ; : event-loop ( -- ) [ event-loop? ] [ do-events ] while ;
: ui-wait ( -- ) 10 milliseconds sleep ; : ui-wait ( -- ) 10 milliseconds sleep ;

2
basis/ui/tools/interactor/interactor-tests.factor
View File

@ -22,7 +22,7 @@ tools.test kernel calendar parser accessors calendar io ;
! This should not throw an exception ! This should not throw an exception
[ ] [ "interactor" get evaluate-input ] unit-test [ ] [ "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 [ ] [ "[ 1 2 3 ]" "interactor" get set-editor-string ] unit-test

2
basis/ui/ui.factor
View File

@ -155,7 +155,7 @@ SYMBOL: ui-thread
: update-ui-loop ( -- ) : update-ui-loop ( -- )
[ ui-running? ui-thread get-global self eq? and ] [ ui-running? ui-thread get-global self eq? and ]
[ ui-notify-flag get lower-flag update-ui ] [ ui-notify-flag get lower-flag update-ui ]
[ ] while ; while ;
: start-ui-thread ( -- ) : start-ui-thread ( -- )
[ self ui-thread set-global update-ui-loop ] [ self ui-thread set-global update-ui-loop ]

6
basis/ui/windows/windows.factor
View File

@ -22,11 +22,7 @@ SINGLETON: windows-ui-backend
[ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ; [ [ dup CHAR: \n = [ CHAR: \r , ] when , ] each ] "" make ;
: enum-clipboard ( -- seq ) : enum-clipboard ( -- seq )
0 0 [ EnumClipboardFormats win32-error dup dup 0 > ] [ ] produce 2nip ;
[ EnumClipboardFormats win32-error dup dup 0 > ]
[ ]
[ drop ]
produce nip ;
: with-clipboard ( quot -- ) : with-clipboard ( quot -- )
f OpenClipboard win32-error=0/f f OpenClipboard win32-error=0/f

3
basis/unicode/breaks/breaks.factor
View File

@ -102,8 +102,7 @@ PRIVATE>
<PRIVATE <PRIVATE
: >pieces ( str quot: ( str -- i ) -- graphemes ) : >pieces ( str quot: ( str -- i ) -- graphemes )
[ dup empty? not ] swap '[ dup @ cut-slice swap ] [ dup empty? not ] swap '[ dup @ cut-slice swap ] produce nip ; inline
[ ] produce nip ; inline
PRIVATE> PRIVATE>

2
basis/unicode/case/case.factor
View File

@ -18,7 +18,7 @@ SYMBOL: locale ! Just casing locale, or overall?
<PRIVATE <PRIVATE
: split-subseq ( string sep -- strings ) : split-subseq ( string sep -- strings )
[ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ; [ dup ] swap '[ _ split1-slice swap ] produce nip ;
: replace ( old new str -- newstr ) : replace ( old new str -- newstr )
[ split-subseq ] dip join ; inline [ split-subseq ] dip join ; inline

2
basis/unix/groups/groups.factor
View File

@ -77,7 +77,7 @@ M: integer user-groups ( id -- seq )
user-name (user-groups) ; user-name (user-groups) ;
: all-groups ( -- seq ) : all-groups ( -- seq )
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ; [ getgrent dup ] [ group-struct>group ] produce nip ;
: <group-cache> ( -- assoc ) : <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ; all-groups [ [ id>> ] keep ] H{ } map>assoc ;

2
basis/unix/users/users.factor
View File

@ -36,7 +36,7 @@ PRIVATE>
: all-users ( -- seq ) : all-users ( -- seq )
[ [
[ getpwent dup ] [ passwd>new-passwd ] [ drop ] produce [ getpwent dup ] [ passwd>new-passwd ] produce nip
] with-pwent ; ] with-pwent ;
SYMBOL: user-cache SYMBOL: user-cache

2
basis/unix/utilities/utilities.factor
View File

@ -14,7 +14,7 @@ IN: unix.utilities
: alien>strings ( alien encoding -- strings ) : alien>strings ( alien encoding -- strings )
[ [ dup more? ] ] dip [ [ dup more? ] ] dip
'[ [ advance ] [ *void* _ alien>string ] bi ] '[ [ advance ] [ *void* _ alien>string ] bi ]
[ ] produce nip ; produce nip ;
: strings>alien ( strings encoding -- array ) : strings>alien ( strings encoding -- array )
'[ _ malloc-string ] void*-array{ } map-as f suffix ; '[ _ malloc-string ] void*-array{ } map-as f suffix ;

2
basis/unix/utmpx/utmpx.factor
View File

@ -57,7 +57,7 @@ M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
[ [
[ getutxent dup ] [ getutxent dup ]
[ utmpx>utmpx-record ] [ utmpx>utmpx-record ]
[ drop ] produce produce nip
] with-utmpx ; ] with-utmpx ;
os { os {

2
core/classes/algebra/algebra.factor
View File

@ -210,7 +210,7 @@ M: anonymous-complement (classes-intersect?)
[ [ name>> ] compare ] sort >vector [ [ name>> ] compare ] sort >vector
[ dup empty? not ] [ dup empty? not ]
[ dup largest-class [ over delete-nth ] dip ] [ dup largest-class [ over delete-nth ] dip ]
[ ] produce nip ; produce nip ;
: min-class ( class seq -- class/f ) : min-class ( class seq -- class/f )
over [ classes-intersect? ] curry filter over [ classes-intersect? ] curry filter

2
core/effects/parser/parser.factor
View File

@ -21,7 +21,7 @@ ERROR: bad-effect ;
] if ; ] if ;
: parse-effect-tokens ( end -- tokens ) : 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 ( end -- effect )
parse-effect-tokens { "--" } split1 dup parse-effect-tokens { "--" } split1 dup

2
core/io/io-docs.factor
View File

@ -224,7 +224,7 @@ $io-error ;
ARTICLE: "stream-protocol" "Stream protocol" ARTICLE: "stream-protocol" "Stream protocol"
"The stream protocol consists of a large number of generic words, many of which are optional." "The stream protocol consists of a large number of generic words, many of which are optional."
$nl $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 $nl
"All streams must implement the " { $link dispose } " word in addition to the stream protocol." "All streams must implement the " { $link dispose } " word in addition to the stream protocol."
$nl $nl

7
core/io/io.factor
View File

@ -65,12 +65,12 @@ SYMBOL: error-stream
: bl ( -- ) " " write ; : bl ( -- ) " " write ;
: lines ( stream -- seq ) : lines ( stream -- seq )
[ [ readln dup ] [ ] [ drop ] produce ] with-input-stream ; [ [ readln dup ] [ ] produce nip ] with-input-stream ;
<PRIVATE <PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- ) : each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
[ dup ] compose swap [ drop ] while ; inline [ dup ] compose swap while drop ; inline
PRIVATE> PRIVATE>
@ -79,8 +79,7 @@ PRIVATE>
: contents ( stream -- seq ) : contents ( stream -- seq )
[ [
[ 65536 read-partial dup ] [ 65536 read-partial dup ] [ ] produce nip concat f like
[ ] [ drop ] produce concat f like
] with-input-stream ; ] with-input-stream ;
: each-block ( quot: ( block -- ) -- ) : each-block ( quot: ( block -- ) -- )

15
core/kernel/kernel-docs.factor
View File

@ -638,15 +638,15 @@ HELP: 4dip
} ; } ;
HELP: while 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 } "." } ; { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link f } "." } ;
HELP: until 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 } "." } ; { $description "Calls " { $snippet "body" } " until " { $snippet "pred" } " returns " { $link t } "." } ;
HELP: do 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." } ; { $description "Executes one iteration of a " { $link while } " or " { $link until } " loop." } ;
HELP: 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." "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 while }
{ $subsection until } { $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:" "To execute one iteration of a loop, use the following word:"
{ $subsection do } { $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 } ":" "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 { $code
"[ P ] [ Q ] [ T ] do while" "[ P ] [ Q ] do while"
} }
"A simpler looping combinator which executes a single quotation until it returns " { $link f } ":" "A simpler looping combinator which executes a single quotation until it returns " { $link f } ":"
{ $subsection loop } ; { $subsection loop } ;

15
core/kernel/kernel.factor
View File

@ -185,21 +185,20 @@ PRIVATE>
: either? ( x y quot -- ? ) bi@ or ; inline : either? ( x y quot -- ? ) bi@ or ; inline
: most ( x y quot -- z ) : most ( x y quot -- z ) 2keep ? ; inline
[ 2dup ] dip call [ drop ] [ nip ] if ; inline
! Loops ! Loops
: loop ( pred: ( -- ? ) -- ) : loop ( pred: ( -- ? ) -- )
[ call ] keep [ loop ] curry when ; inline recursive [ call ] keep [ loop ] curry when ; inline recursive
: do ( pred body tail -- pred body tail ) : do ( pred body -- pred body )
over 3dip ; inline dup 2dip ; inline
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) : while ( pred: ( -- ? ) body: ( -- ) -- )
[ pick 3dip [ do while ] 3curry ] keep if ; inline recursive swap do compose [ loop ] curry when ; inline
: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- ) : until ( pred: ( -- ? ) body: ( -- ) -- )
[ [ not ] compose ] 2dip while ; inline [ [ not ] compose ] dip while ; inline
! Object protocol ! Object protocol
GENERIC: hashcode* ( depth obj -- code ) GENERIC: hashcode* ( depth obj -- code )

4
core/math/integers/integers.factor
View File

@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ;
M: fixnum bit? neg shift 1 bitand 0 > ; M: fixnum bit? neg shift 1 bitand 0 > ;
: fixnum-log2 ( x -- n ) : 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 ; M: fixnum (log2) fixnum-log2 ;
@ -103,7 +103,7 @@ M: bignum (log2) bignum-log2 ;
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem ) : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ] [ 2dup /i log2 53 > ]
[ [ shift-mantissa ] dip ] [ [ shift-mantissa ] dip ]
[ ] while /mod ; inline while /mod ; inline
! Third step: post-scaling ! Third step: post-scaling
: unscaled-float ( mantissa -- n ) : unscaled-float ( mantissa -- n )

2
core/math/parser/parser.factor
View File

@ -96,7 +96,7 @@ PRIVATE>
: positive>base ( num radix -- str ) : positive>base ( num radix -- str )
dup 1 <= [ "Invalid radix" throw ] when 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 dup reverse-here ; inline
PRIVATE> PRIVATE>

17
core/sequences/sequences-docs.factor
View File

@ -915,24 +915,19 @@ HELP: supremum
{ $errors "Throws an error if the sequence is empty." } ; { $errors "Throws an error if the sequence is empty." } ;
HELP: produce 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." } { $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 { $examples
"The following example divides a number by two until we reach zero, and accumulates intermediate results:" "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 }" } { $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:" "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 > ] [ ] [ drop ] produce ." "{ 8 2 2 9 }" } { $unchecked-example "USING: kernel prettyprint random sequences ;" "[ 10 random dup 1 > ] [ ] produce nip ." "{ 8 2 2 9 }" }
} ; } ;
HELP: produce-as 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." } { $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 { $examples "See " { $link produce } " for 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 }" }
} ;
HELP: sigma HELP: sigma
{ $values { "seq" sequence } { "quot" quotation } { "n" number } } { $values { "seq" sequence } { "quot" quotation } { "n" number } }

8
core/sequences/sequences.factor
View File

@ -487,14 +487,14 @@ PRIVATE>
: accumulator ( quot -- quot' vec ) : accumulator ( quot -- quot' vec )
V{ } clone [ [ push ] curry compose ] keep ; inline V{ } clone [ [ push ] curry compose ] keep ; inline
: produce-as ( pred quot tail exemplar -- seq ) : produce-as ( pred quot exemplar -- seq )
[ swap accumulator [ swap while ] dip ] dip like ; inline [ accumulator [ while ] dip ] dip like ; inline
: produce ( pred quot tail -- seq ) : produce ( pred quot -- seq )
{ } produce-as ; inline { } produce-as ; inline
: follow ( obj quot -- seq ) : 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 ) : prepare-index ( seq quot -- seq n quot )
[ dup length ] dip ; inline [ dup length ] dip ; inline

2
core/slots/slots.factor
View File

@ -199,7 +199,7 @@ M: array make-slot
swap swap
peel-off-name peel-off-name
peel-off-class peel-off-class
[ dup empty? ] [ peel-off-attributes ] [ ] until drop [ dup empty? ] [ peel-off-attributes ] until drop
check-initial-value ; check-initial-value ;
M: slot-spec make-slot M: slot-spec make-slot

2
core/sorting/sorting.factor
View File

@ -126,7 +126,7 @@ TUPLE: merge
: sort-loop ( merge quot -- ) : sort-loop ( merge quot -- )
[ 2 [ over seq>> length over > ] ] dip [ 2 [ over seq>> length over > ] ] dip
[ [ 1 shift 2dup ] dip sort-pass ] curry [ [ 1 shift 2dup ] dip sort-pass ] curry
[ ] while 2drop ; inline while 2drop ; inline
: each-pair ( seq quot -- ) : each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip [ [ length 1+ 2/ ] keep ] dip

5
core/system/system.factor
View File

@ -25,9 +25,11 @@ SINGLETON: solaris
SINGLETON: macosx SINGLETON: macosx
SINGLETON: linux SINGLETON: linux
SINGLETON: haiku
UNION: bsd freebsd netbsd openbsd macosx ; UNION: bsd freebsd netbsd openbsd macosx ;
UNION: unix bsd solaris linux ; UNION: unix bsd solaris linux haiku ;
: os ( -- class ) \ os get-global ; foldable : os ( -- class ) \ os get-global ; foldable
@ -51,6 +53,7 @@ UNION: unix bsd solaris linux ;
{ "solaris" solaris } { "solaris" solaris }
{ "macosx" macosx } { "macosx" macosx }
{ "linux" linux } { "linux" linux }
{ "haiku" haiku }
} at ; } at ;
PRIVATE> PRIVATE>

2
extra/adsoda/adsoda.factor
View File

@ -337,7 +337,7 @@ TUPLE: solid dimension silhouettes
: compute-adjacencies ( solid -- solid ) : compute-adjacencies ( solid -- solid )
dup dimension>> [ >= ] curry dup dimension>> [ >= ] curry
[ keep swap ] curry MAX-FACE-PER-CORNER swap [ 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 ) : find-adjacencies ( solid -- solid )
erase-old-adjacencies erase-old-adjacencies

8
extra/bubble-chamber/bubble-chamber.factor
View File

@ -135,7 +135,7 @@ METHOD: collide ( <axion> -- )
0 >>theta-d 0 >>theta-d
0 >>theta-dd 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 ; drop ;
@ -201,7 +201,7 @@ METHOD: collide ( <hadron> -- )
0 >>theta-d 0 >>theta-d
0 >>theta-dd 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 0 1 0 1 rgba boa >>myc
@ -302,7 +302,7 @@ METHOD: collide ( <muon> -- )
0 >>theta-d 0 >>theta-d
0 >>theta-dd 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-good-color
set-anti-color set-anti-color
@ -355,7 +355,7 @@ METHOD: collide ( <quark> -- )
0 >>theta-d 0 >>theta-d
0 >>theta-dd 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 ; drop ;

2
extra/graph-theory/graph-theory.factor
View File

@ -78,7 +78,7 @@ PRIVATE>
: full-depth-first ( graph pre post tail -- ? ) : full-depth-first ( graph pre post tail -- ? )
'[ [ visited? get [ nip not ] assoc-find ] '[ [ visited? get [ nip not ] assoc-find ]
[ drop _ _ (depth-first) @ ] [ drop _ _ (depth-first) @ ]
[ 2drop ] while ] swap search-wrap ; inline while 2drop ] swap search-wrap ; inline
: dag? ( graph -- ? ) : dag? ( graph -- ? )
V{ } clone swap [ 2dup swap push dupd V{ } clone swap [ 2dup swap push dupd

2
extra/id3/id3.factor
View File

@ -115,7 +115,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
: read-frames ( mmap -- frames ) : read-frames ( mmap -- frames )
[ dup read-frame dup ] [ dup read-frame dup ]
[ [ remove-frame ] keep ] [ [ remove-frame ] keep ]
[ drop ] produce nip ; produce 2nip ;
! header stuff ! header stuff

4
extra/iokit/iokit.factor
View File

@ -166,9 +166,7 @@ M: mach-error error.
IOObjectRelease mach-error ; IOObjectRelease mach-error ;
: io-objects-from-iterator* ( i -- i array ) : io-objects-from-iterator* ( i -- i array )
[ dup IOIteratorNext dup MACH_PORT_NULL = not ] [ dup IOIteratorNext dup MACH_PORT_NULL = not ] [ ] produce nip ;
[ ]
[ drop ] produce ;
: io-objects-from-iterator ( i -- array ) : io-objects-from-iterator ( i -- array )
io-objects-from-iterator* [ release-io-object ] dip ; io-objects-from-iterator* [ release-io-object ] dip ;

2
extra/irc/ui/ui.factor
View File

@ -152,7 +152,7 @@ M: object handle-inbox
: display ( stream tab -- ) : display ( stream tab -- )
'[ _ [ [ t ] '[ _ [ [ t ]
[ _ dup chat>> hear handle-inbox ] [ _ dup chat>> hear handle-inbox ]
[ ] while ] with-output-stream ] "ircv" spawn drop ; while ] with-output-stream ] "ircv" spawn drop ;
: <irc-pane> ( tab -- tab pane ) : <irc-pane> ( tab -- tab pane )
<scrolling-pane> <scrolling-pane>

2
extra/math/text/utils/utils.factor
View File

@ -4,4 +4,4 @@ USING: kernel math sequences ;
IN: math.text.utils IN: math.text.utils
: 3digit-groups ( n -- seq ) : 3digit-groups ( n -- seq )
[ dup 0 > ] [ 1000 /mod ] [ ] produce nip ; [ dup 0 > ] [ 1000 /mod ] produce nip ;

2
extra/multi-methods/multi-methods.factor
View File

@ -82,7 +82,7 @@ SYMBOL: total
: topological-sort ( seq quot -- newseq ) : topological-sort ( seq quot -- newseq )
[ >vector [ dup empty? not ] ] dip [ >vector [ dup empty? not ] ] dip
[ dupd maximal-element [ over delete-nth ] dip ] curry [ dupd maximal-element [ over delete-nth ] dip ] curry
[ ] produce nip ; inline produce nip ; inline
: classes< ( seq1 seq2 -- lt/eq/gt ) : classes< ( seq1 seq2 -- lt/eq/gt )
[ [

2
extra/otug-talk/otug-talk.factor
View File

@ -223,7 +223,7 @@ CONSTANT: otug-slides
} }
{ $slide "Modifiers" { $slide "Modifiers"
{ $code ": bank ( n -- n )" " readln string>number +" " dup \"Balance: $\" write . ;" } { $code ": bank ( n -- n )" " readln string>number +" " dup \"Balance: $\" write . ;" }
{ $code "0 [ dup 0 > ] [ bank ] [ ] while" } { $code "0 [ dup 0 > ] [ bank ] while" }
} }
{ $slide "Modifiers" { $slide "Modifiers"
{ $code "0 [ dup 0 > ] [ bank ] [ ] do while" } { $code "0 [ dup 0 > ] [ bank ] [ ] do while" }

2
extra/project-euler/002/002.factor
View File

@ -41,7 +41,7 @@ PRIVATE>
! ------------------- ! -------------------
: fib-upto* ( n -- seq ) : 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 ; but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer ) : euler002a ( -- answer )

2
extra/project-euler/012/012.factor
View File

@ -34,7 +34,7 @@ IN: project-euler.012
! -------- ! --------
: euler012 ( -- answer ) : 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 ! [ euler012 ] 10 ave-time
! 6573 ms ave run time - 346.27 SD (10 trials) ! 6573 ms ave run time - 346.27 SD (10 trials)

2
extra/project-euler/014/014.factor
View File

@ -43,7 +43,7 @@ IN: project-euler.014
PRIVATE> PRIVATE>
: collatz ( n -- seq ) : collatz ( n -- seq )
[ [ dup 1 > ] [ dup , next-collatz ] [ ] while , ] { } make ; [ [ dup 1 > ] [ dup , next-collatz ] while , ] { } make ;
: euler014 ( -- answer ) : euler014 ( -- answer )
1000000 [1,b] 0 [ collatz longest ] reduce first ; 1000000 [1,b] 0 [ collatz longest ] reduce first ;

2
extra/project-euler/019/019.factor
View File

@ -53,7 +53,7 @@ IN: project-euler.019
: first-days ( end-date start-date -- days ) : first-days ( end-date start-date -- days )
[ 2dup after=? ] [ 2dup after=? ]
[ dup 1 months time+ swap day-of-week ] [ dup 1 months time+ swap day-of-week ]
[ ] produce 2nip ; produce 2nip ;
PRIVATE> PRIVATE>

2
extra/project-euler/071/071.factor
View File

@ -40,7 +40,7 @@ IN: project-euler.071
PRIVATE> PRIVATE>
: euler071 ( -- answer ) : 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 ; nip penultimate numerator ;
! [ euler071 ] 100 ave-time ! [ euler071 ] 100 ave-time

2
extra/project-euler/100/100.factor
View File

@ -26,7 +26,7 @@ IN: project-euler.100
: euler100 ( -- answer ) : euler100 ( -- answer )
1 1 1 1
[ dup dup 1- * 2 * 10 24 ^ <= ] [ dup dup 1- * 2 * 10 24 ^ <= ]
[ tuck 6 * swap - 2 - ] [ ] while nip ; [ tuck 6 * swap - 2 - ] while nip ;
! TODO: solution needs generalization ! TODO: solution needs generalization

2
extra/project-euler/148/148.factor
View File

@ -35,7 +35,7 @@ IN: project-euler.148
dup 1+ * 2/ ; inline dup 1+ * 2/ ; inline
: >base7 ( x -- y ) : >base7 ( x -- y )
[ dup 0 > ] [ 7 /mod ] [ ] produce nip ; [ dup 0 > ] [ 7 /mod ] produce nip ;
: (use-digit) ( prev x index -- next ) : (use-digit) ( prev x index -- next )
[ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ; [ [ 1+ * ] [ sum-1toN 7 sum-1toN ] bi ] dip ^ * + ;

2
extra/project-euler/common/common.factor
View File

@ -72,7 +72,7 @@ PRIVATE>
] if ; ] if ;
: number>digits ( n -- seq ) : number>digits ( n -- seq )
[ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ; [ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
: number-length ( n -- m ) : number-length ( n -- m )
log10 floor 1+ >integer ; log10 floor 1+ >integer ;

13
misc/fuel/fu.el
View File

@ -37,5 +37,18 @@
(autoload 'fuel-scaffold-help "fuel-scaffold.el" (autoload 'fuel-scaffold-help "fuel-scaffold.el"
"Create a Factor vocabulary help file." t) "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 ;;; fu.el ends here

32
misc/fuel/fuel-listener.el
View File

@ -59,6 +59,35 @@ buffer."
:type 'boolean :type 'boolean
:group 'fuel-listener) :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: ;;; Fuel listener buffer/process:
@ -84,7 +113,8 @@ buffer."
(pop-to-buffer (fuel-listener--buffer)) (pop-to-buffer (fuel-listener--buffer))
(make-comint-in-buffer "fuel listener" (current-buffer) factor nil (make-comint-in-buffer "fuel listener" (current-buffer) factor nil
"-run=listener" (format "-i=%s" image)) "-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)))) (fuel-con--setup-connection (current-buffer))))
(defun fuel-listener--connect-process (port) (defun fuel-listener--connect-process (port)

7
unmaintained/combinators-lib/lib.factor
View File

@ -126,12 +126,9 @@ MACRO: multikeep ( word out-indexes -- ... )
r> [ drop \ r> , ] each r> [ drop \ r> , ] each
] [ ] make ; ] [ ] make ;
: do-while ( pred body tail -- )
[ tuck 2slip ] dip while ; inline
: generate ( generator predicate -- obj ) : generate ( generator predicate -- obj )
'[ dup @ dup [ nip ] unless not ] '[ dup @ dup [ nip ] unless ]
swap [ ] do-while ; swap do until ;
MACRO: predicates ( seq -- quot/f ) MACRO: predicates ( seq -- quot/f )
dup [ 1quotation [ drop ] prepend ] map dup [ 1quotation [ drop ] prepend ] map