Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
5aba91a0c5
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -27,7 +27,6 @@ M: winnt (os-envs) ( -- seq )
|
|||
GetEnvironmentStrings [
|
||||
<memory-stream> [
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ] [
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -61,5 +61,5 @@ M: unix (directory-entries) ( path -- seq )
|
|||
[
|
||||
'[ _ find-next-file dup ]
|
||||
[ >directory-entry ]
|
||||
[ drop ] produce
|
||||
produce nip
|
||||
] with-unix-directory ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -101,13 +101,13 @@ os { winnt linux macosx } member? [
|
|||
! Non-recursive
|
||||
[ ] [ "monitor-timeout-test" temp-file f <monitor> "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 <monitor> "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
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ IN: math.primes.factors
|
|||
|
||||
: count-factor ( n d -- n' c )
|
||||
[ 1 ] 2dip [ /i ] keep
|
||||
[ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] [ drop ] while
|
||||
[ dupd /mod zero? ] curry [ nip [ 1+ ] dip ] while drop
|
||||
swap ;
|
||||
|
||||
: write-factor ( n d -- n' d )
|
||||
|
|
@ -18,7 +18,7 @@ PRIVATE>
|
|||
: 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -67,4 +67,4 @@ PRIVATE>
|
|||
<deque> [ 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 ;
|
||||
|
|
|
|||
|
|
@ -98,6 +98,6 @@ M: branch pheap-push
|
|||
<persistent-heap> 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 ;
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ IN: regexp
|
|||
[ [ split1-slice nip ] keep ] [ 2drop f f ] if ;
|
||||
|
||||
: all-matches ( string regexp -- seq )
|
||||
[ dup ] swap '[ _ next-match ] [ ] produce nip harvest ;
|
||||
[ dup ] swap '[ _ next-match ] produce nip harvest ;
|
||||
|
||||
: count-matches ( string regexp -- n )
|
||||
all-matches length ;
|
||||
|
|
|
|||
|
|
@ -512,9 +512,9 @@ ERROR: custom-error ;
|
|||
[ [ missing->r-check ] infer ] must-fail
|
||||
|
||||
! Corner case
|
||||
[ [ [ f dup ] [ dup ] [ ] produce ] infer ] must-fail
|
||||
[ [ [ f dup ] [ dup ] produce ] infer ] must-fail
|
||||
|
||||
[ [ [ f dup ] [ ] [ ] while ] infer ] must-fail
|
||||
[ [ [ f dup ] [ ] while ] infer ] must-fail
|
||||
|
||||
: erg's-inference-bug ( -- ) f dup [ erg's-inference-bug ] when ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ DEFER: stop
|
|||
sleep-queue
|
||||
[ dup expire-sleep? ]
|
||||
[ dup heap-pop drop expire-sleep ]
|
||||
[ ] while
|
||||
while
|
||||
drop ;
|
||||
|
||||
: start ( namestack thread -- * )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -102,8 +102,7 @@ PRIVATE>
|
|||
<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>
|
||||
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ SYMBOL: locale ! Just casing locale, or overall?
|
|||
<PRIVATE
|
||||
|
||||
: split-subseq ( string sep -- strings )
|
||||
[ dup ] swap '[ _ split1-slice swap ] [ ] produce nip ;
|
||||
[ dup ] swap '[ _ split1-slice swap ] produce nip ;
|
||||
|
||||
: replace ( old new str -- newstr )
|
||||
[ split-subseq ] dip join ; inline
|
||||
|
|
|
|||
|
|
@ -77,7 +77,7 @@ M: integer user-groups ( id -- seq )
|
|||
user-name (user-groups) ;
|
||||
|
||||
: all-groups ( -- seq )
|
||||
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
|
||||
[ getgrent dup ] [ group-struct>group ] produce nip ;
|
||||
|
||||
: <group-cache> ( -- assoc )
|
||||
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -57,7 +57,7 @@ M: unix utmpx>utmpx-record ( utmpx -- utmpx-record )
|
|||
[
|
||||
[ getutxent dup ]
|
||||
[ utmpx>utmpx-record ]
|
||||
[ drop ] produce
|
||||
produce nip
|
||||
] with-utmpx ;
|
||||
|
||||
os {
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
|
||||
[ dup ] compose swap [ drop ] while ; inline
|
||||
[ dup ] compose swap while drop ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -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 -- ) -- )
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -135,7 +135,7 @@ METHOD: collide ( <axion> -- )
|
|||
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 ( <hadron> -- )
|
|||
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 ( <muon> -- )
|
|||
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 ( <quark> -- )
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -115,7 +115,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
: read-frames ( mmap -- frames )
|
||||
[ dup read-frame dup ]
|
||||
[ [ remove-frame ] keep ]
|
||||
[ drop ] produce nip ;
|
||||
produce 2nip ;
|
||||
|
||||
! header stuff
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
: <irc-pane> ( tab -- tab pane )
|
||||
<scrolling-pane>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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>
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ^ * + ;
|
||||
|
|
|
|||
|
|
@ -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 / ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue