Merge branch 'master' of git://factorcode.org/git/factor into mongo-factor-driver
commit
57a55aaed6
|
@ -12,6 +12,9 @@ IN: cocoa.dialogs
|
|||
dup 1 -> setResolvesAliases:
|
||||
dup 1 -> setAllowsMultipleSelection: ;
|
||||
|
||||
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
|
||||
dup 1 -> setCanChooseDirectories: ;
|
||||
|
||||
: <NSSavePanel> ( -- panel )
|
||||
NSSavePanel -> savePanel
|
||||
dup 1 -> setCanChooseFiles:
|
||||
|
@ -21,11 +24,13 @@ IN: cocoa.dialogs
|
|||
CONSTANT: NSOKButton 1
|
||||
CONSTANT: NSCancelButton 0
|
||||
|
||||
: open-panel ( -- paths )
|
||||
<NSOpenPanel>
|
||||
: (open-panel) ( panel -- paths )
|
||||
dup -> runModal NSOKButton =
|
||||
[ -> filenames CF>string-array ] [ drop f ] if ;
|
||||
|
||||
: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
|
||||
: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
|
||||
|
||||
: split-path ( path -- dir file )
|
||||
"/" split1-last [ <NSString> ] bi@ ;
|
||||
|
||||
|
|
|
@ -66,7 +66,7 @@ ERROR: ftp-error got expected ;
|
|||
: list ( url -- ftp-response )
|
||||
utf8 open-passive-client
|
||||
ftp-list
|
||||
lines
|
||||
stream-lines
|
||||
<ftp-response> swap >>strings
|
||||
read-response 226 ftp-assert
|
||||
parse-list ;
|
||||
|
|
|
@ -1,5 +1,7 @@
|
|||
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: inverse tools.test arrays math kernel sequences
|
||||
math.functions math.constants continuations ;
|
||||
math.functions math.constants continuations combinators.smart ;
|
||||
IN: inverse-tests
|
||||
|
||||
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
|
||||
|
@ -69,7 +71,7 @@ C: <nil> nil
|
|||
|
||||
[ t ] [ pi [ pi ] matches? ] unit-test
|
||||
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
|
||||
[ ] [ 3 [ _ ] undo ] unit-test
|
||||
[ ] [ 3 [ __ ] undo ] unit-test
|
||||
|
||||
[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
|
||||
[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
|
||||
|
@ -89,3 +91,6 @@ TUPLE: funny-tuple ;
|
|||
: funny-tuple ( -- ) "OOPS" throw ;
|
||||
|
||||
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
|
||||
|
||||
[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
|
||||
[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2007, 2008 Daniel Ehrenberg.
|
||||
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel words summary slots quotations
|
||||
sequences assocs math arrays stack-checker effects generalizations
|
||||
continuations debugger classes.tuple namespaces make vectors
|
||||
bit-arrays byte-arrays strings sbufs math.functions macros
|
||||
sequences.private combinators mirrors splitting
|
||||
combinators.short-circuit fry words.symbol generalizations ;
|
||||
RENAME: _ fry => __
|
||||
sequences.private combinators mirrors splitting combinators.smart
|
||||
combinators.short-circuit fry words.symbol generalizations
|
||||
classes ;
|
||||
IN: inverse
|
||||
|
||||
ERROR: fail ;
|
||||
|
@ -14,7 +14,7 @@ M: fail summary drop "Matching failed" ;
|
|||
|
||||
: assure ( ? -- ) [ fail ] unless ; inline
|
||||
|
||||
: =/fail ( obj1 obj2 -- ) = assure ;
|
||||
: =/fail ( obj1 obj2 -- ) = assure ; inline
|
||||
|
||||
! Inverse of a quotation
|
||||
|
||||
|
@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ;
|
|||
\ pick [ [ pick ] dip =/fail ] define-inverse
|
||||
\ tuck [ swapd [ =/fail ] keep ] define-inverse
|
||||
|
||||
\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
|
||||
\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
|
||||
\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
|
||||
\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
|
||||
|
||||
\ not define-involution
|
||||
\ >boolean [ { t f } memq? assure ] define-inverse
|
||||
\ >boolean [ dup { t f } memq? assure ] define-inverse
|
||||
|
||||
\ tuple>array \ >tuple define-dual
|
||||
\ reverse define-involution
|
||||
|
||||
\ undo 1 [ [ call ] curry ] define-pop-inverse
|
||||
\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
|
||||
\ undo 1 [ ] define-pop-inverse
|
||||
\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
|
||||
|
||||
\ exp \ log define-dual
|
||||
\ sq \ sqrt define-dual
|
||||
|
@ -173,16 +178,13 @@ ERROR: missing-literal ;
|
|||
2curry
|
||||
] define-pop-inverse
|
||||
|
||||
DEFER: _
|
||||
\ _ [ drop ] define-inverse
|
||||
DEFER: __
|
||||
\ __ [ drop ] define-inverse
|
||||
|
||||
: both ( object object -- object )
|
||||
dupd assert= ;
|
||||
\ both [ dup ] define-inverse
|
||||
|
||||
: assure-length ( seq length -- seq )
|
||||
over length =/fail ;
|
||||
|
||||
{
|
||||
{ >array array? }
|
||||
{ >vector vector? }
|
||||
|
@ -194,14 +196,23 @@ DEFER: _
|
|||
{ >string string? }
|
||||
{ >sbuf sbuf? }
|
||||
{ >quotation quotation? }
|
||||
} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
|
||||
} [ '[ dup _ execute assure ] define-inverse ] assoc-each
|
||||
|
||||
! These actually work on all seqs--should they?
|
||||
\ 1array [ 1 assure-length first ] define-inverse
|
||||
\ 2array [ 2 assure-length first2 ] define-inverse
|
||||
\ 3array [ 3 assure-length first3 ] define-inverse
|
||||
\ 4array [ 4 assure-length first4 ] define-inverse
|
||||
\ narray 1 [ [ firstn ] curry ] define-pop-inverse
|
||||
: assure-length ( seq length -- )
|
||||
swap length =/fail ; inline
|
||||
|
||||
: assure-array ( array -- array )
|
||||
dup array? assure ; inline
|
||||
|
||||
: undo-narray ( array n -- ... )
|
||||
[ assure-array ] dip
|
||||
[ assure-length ] [ firstn ] 2bi ; inline
|
||||
|
||||
\ 1array [ 1 undo-narray ] define-inverse
|
||||
\ 2array [ 2 undo-narray ] define-inverse
|
||||
\ 3array [ 3 undo-narray ] define-inverse
|
||||
\ 4array [ 4 undo-narray ] define-inverse
|
||||
\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
|
||||
|
||||
\ first [ 1array ] define-inverse
|
||||
\ first2 [ 2array ] define-inverse
|
||||
|
@ -214,6 +225,12 @@ DEFER: _
|
|||
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
|
||||
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
|
||||
|
||||
: assure-same-class ( obj1 obj2 -- )
|
||||
[ class ] bi@ = assure ; inline
|
||||
|
||||
\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
|
||||
\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
|
||||
|
||||
! Constructor inverse
|
||||
: deconstruct-pred ( class -- quot )
|
||||
"predicate" word-prop [ dupd call assure ] curry ;
|
||||
|
@ -245,7 +262,7 @@ DEFER: _
|
|||
] recover ; inline
|
||||
|
||||
: true-out ( quot effect -- quot' )
|
||||
out>> '[ @ __ ndrop t ] ;
|
||||
out>> '[ @ _ ndrop t ] ;
|
||||
|
||||
: false-recover ( effect -- quot )
|
||||
in>> [ ndrop f ] curry [ recover-fail ] curry ;
|
||||
|
|
|
@ -4,7 +4,7 @@ USING: io io.streams.byte-array ;
|
|||
IN: io.encodings.string
|
||||
|
||||
: decode ( byte-array encoding -- string )
|
||||
<byte-reader> contents ;
|
||||
<byte-reader> stream-contents ;
|
||||
|
||||
: encode ( string encoding -- byte-array )
|
||||
[ write ] with-byte-writer ;
|
||||
|
|
|
@ -3,9 +3,9 @@
|
|||
USING: system kernel namespaces strings hashtables sequences
|
||||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors environment
|
||||
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||
io.streams.duplex io.ports debugger prettyprint summary
|
||||
calendar ;
|
||||
io io.encodings.ascii io.backend io.timeouts io.pipes
|
||||
io.pipes.private io.encodings io.streams.duplex io.ports
|
||||
debugger prettyprint summary calendar ;
|
||||
IN: io.launcher
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
@ -265,3 +265,5 @@ M: object run-pipeline-element
|
|||
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
|
||||
[ ]
|
||||
} cond
|
||||
|
||||
: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;
|
||||
|
|
|
@ -33,7 +33,7 @@ concurrency.promises threads unix.process ;
|
|||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -52,7 +52,7 @@ concurrency.promises threads unix.process ;
|
|||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
|
@ -70,14 +70,14 @@ concurrency.promises threads unix.process ;
|
|||
"cat"
|
||||
"launcher-test-1" temp-file
|
||||
2array
|
||||
ascii <process-reader> contents
|
||||
ascii <process-reader> stream-contents
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
<process>
|
||||
"env" >>command
|
||||
{ { "A" "B" } } >>environment
|
||||
ascii <process-reader> lines
|
||||
ascii <process-reader> stream-lines
|
||||
"A=B" swap member?
|
||||
] unit-test
|
||||
|
||||
|
@ -86,7 +86,7 @@ concurrency.promises threads unix.process ;
|
|||
"env" >>command
|
||||
{ { "A" "B" } } >>environment
|
||||
+replace-environment+ >>environment-mode
|
||||
ascii <process-reader> lines
|
||||
ascii <process-reader> stream-lines
|
||||
] unit-test
|
||||
|
||||
[ "hi\n" ] [
|
||||
|
@ -113,13 +113,13 @@ concurrency.promises threads unix.process ;
|
|||
"append-test" temp-file utf8 file-contents
|
||||
] unit-test
|
||||
|
||||
[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
|
||||
[ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
|
||||
|
||||
[ "Hello world.\n" ] [
|
||||
"cat" utf8 <process-stream> [
|
||||
"Hello world.\n" write
|
||||
output-stream get dispose
|
||||
input-stream get contents
|
||||
input-stream get stream-contents
|
||||
] with-stream
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ;
|
|||
dup start-server* sockets>> first addr>> port>> "port" set
|
||||
] unit-test
|
||||
|
||||
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
|
||||
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test
|
||||
|
|
|
@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ;
|
|||
|
||||
: client-test ( -- string )
|
||||
<secure-config> [
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
|
||||
"127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
|
||||
] with-secure-context ;
|
||||
|
||||
[ ] [ [ class name>> write ] server-test ] unit-test
|
||||
|
|
|
@ -6,7 +6,7 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
|
|||
|
||||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
|
||||
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
|
||||
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
|
||||
|
||||
[ B{ 121 120 } 0 ] [
|
||||
B{ 0 121 120 0 0 0 0 0 0 } binary
|
||||
|
|
|
@ -54,7 +54,7 @@ PRIVATE>
|
|||
|
||||
: randomize ( seq -- seq )
|
||||
dup length [ dup 1 > ]
|
||||
[ [ random ] [ 1- ] bi [ pick exchange ] keep ]
|
||||
[ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
|
||||
while drop ;
|
||||
|
||||
: delete-random ( seq -- elt )
|
||||
|
|
|
@ -75,7 +75,7 @@ CONSTANT: text "Hello world.\nThis is a test."
|
|||
[ ] [
|
||||
[
|
||||
"interactor" get register-self
|
||||
"interactor" get contents "promise" get fulfill
|
||||
"interactor" get stream-contents "promise" get fulfill
|
||||
] in-thread
|
||||
] unit-test
|
||||
|
||||
|
|
|
@ -24,7 +24,7 @@ IN: xmode.code2html
|
|||
[XML <style><-></style> XML] ;
|
||||
|
||||
:: htmlize-stream ( path stream -- xml )
|
||||
stream lines
|
||||
stream stream-lines
|
||||
[ "" ] [ path over first find-mode htmlize-lines ]
|
||||
if-empty :> input
|
||||
default-stylesheet :> stylesheet
|
||||
|
|
|
@ -32,7 +32,7 @@ M: assoc assoc-like drop ;
|
|||
3drop f
|
||||
] [
|
||||
3dup nth-unsafe at*
|
||||
[ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
|
||||
[ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
|
||||
] if ; inline recursive
|
||||
|
||||
: search-alist ( key alist -- pair/f i/f )
|
||||
|
@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
|
|||
assoc-size 0 = ;
|
||||
|
||||
: assoc-stack ( key seq -- value )
|
||||
[ length 1- ] keep (assoc-stack) ; flushable
|
||||
[ length 1 - ] keep (assoc-stack) ; flushable
|
||||
|
||||
: assoc-subset? ( assoc1 assoc2 -- ? )
|
||||
[ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;
|
||||
|
|
|
@ -513,4 +513,4 @@ tuple
|
|||
} [ [ first3 ] dip swap make-primitive ] each-index
|
||||
|
||||
! Bump build number
|
||||
"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared
|
||||
"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared
|
||||
|
|
|
@ -13,7 +13,7 @@ GENERIC: checksum-stream ( stream checksum -- value )
|
|||
GENERIC: checksum-lines ( lines checksum -- value )
|
||||
|
||||
M: checksum checksum-stream
|
||||
[ contents ] dip checksum-bytes ;
|
||||
[ stream-contents ] dip checksum-bytes ;
|
||||
|
||||
M: checksum checksum-lines
|
||||
[ B{ CHAR: \n } join ] dip checksum-bytes ;
|
||||
|
|
|
@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320
|
|||
|
||||
CONSTANT: crc32-table V{ }
|
||||
|
||||
256 [
|
||||
256 iota [
|
||||
8 [
|
||||
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
|
||||
] times >bignum
|
||||
|
|
|
@ -254,7 +254,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
|
|||
" } ;"
|
||||
""
|
||||
": next-position ( role -- newrole )"
|
||||
" positions [ index 1+ ] keep nth ;"
|
||||
" positions [ index 1 + ] keep nth ;"
|
||||
""
|
||||
": promote ( employee -- employee )"
|
||||
" [ 1.2 * ] change-salary"
|
||||
|
|
|
@ -165,7 +165,7 @@ ERROR: bad-superclass class ;
|
|||
{
|
||||
[ , ]
|
||||
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
|
||||
[ superclasses length 1- , ]
|
||||
[ superclasses length 1 - , ]
|
||||
[ superclasses [ [ , ] [ hashcode , ] bi ] each ]
|
||||
} cleave
|
||||
] { } make ;
|
||||
|
@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x )
|
|||
|
||||
M: tuple tuple-hashcode
|
||||
[
|
||||
[ class hashcode ] [ tuple-size ] [ ] tri
|
||||
[ class hashcode ] [ tuple-size iota ] [ ] tri
|
||||
[ rot ] dip [
|
||||
swapd array-nth hashcode* sequence-hashcode-step
|
||||
] 2curry each
|
||||
|
|
|
@ -123,7 +123,7 @@ ERROR: no-case object ;
|
|||
[ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
|
||||
|
||||
: hash-dispatch-quot ( table -- quot )
|
||||
[ length 1- [ fixnum-bitand ] curry ] keep
|
||||
[ length 1 - [ fixnum-bitand ] curry ] keep
|
||||
[ dispatch ] curry append ;
|
||||
|
||||
: hash-case-quot ( default assoc -- quot )
|
||||
|
@ -162,7 +162,7 @@ ERROR: no-case object ;
|
|||
|
||||
! recursive-hashcode
|
||||
: recursive-hashcode ( n obj quot -- code )
|
||||
pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
|
||||
pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
|
||||
|
||||
! These go here, not in sequences and hashtables, since those
|
||||
! two cannot depend on us
|
||||
|
|
|
@ -4,7 +4,7 @@ kernel.private accessors eval ;
|
|||
IN: continuations.tests
|
||||
|
||||
: (callcc1-test) ( n obj -- n' obj )
|
||||
[ 1- dup ] dip ?push
|
||||
[ 1 - dup ] dip ?push
|
||||
over 0 = [ "test-cc" get continue-with ] when
|
||||
(callcc1-test) ;
|
||||
|
||||
|
|
|
@ -178,7 +178,7 @@ M: echelon-dispatch-engine compile-engine
|
|||
M: tuple-dispatch-engine compile-engine
|
||||
tuple assumed [
|
||||
echelons>> compile-engines
|
||||
dup keys supremum 1+ f <array>
|
||||
dup keys supremum 1 + f <array>
|
||||
[ <enum> swap update ] keep
|
||||
] with-variable ;
|
||||
|
||||
|
|
|
@ -28,7 +28,7 @@ CONSTANT: simple-combination T{ standard-combination f 0 }
|
|||
{ 0 [ [ dup ] ] }
|
||||
{ 1 [ [ over ] ] }
|
||||
{ 2 [ [ pick ] ] }
|
||||
[ 1- (picker) [ dip swap ] curry ]
|
||||
[ 1 - (picker) [ dip swap ] curry ]
|
||||
} case ;
|
||||
|
||||
M: standard-combination picker
|
||||
|
|
|
@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
|
|||
] if
|
||||
(>>length) ;
|
||||
|
||||
: new-size ( old -- new ) 1+ 3 * ; inline
|
||||
: new-size ( old -- new ) 1 + 3 * ; inline
|
||||
|
||||
: ensure ( n seq -- n seq )
|
||||
growable-check
|
||||
|
|
|
@ -34,7 +34,7 @@ TUPLE: hashtable
|
|||
[ no-key ] [ 2dup hash@ (key@) ] if ; inline
|
||||
|
||||
: <hash-array> ( n -- array )
|
||||
1+ next-power-of-2 4 * ((empty)) <array> ; inline
|
||||
1 + next-power-of-2 4 * ((empty)) <array> ; inline
|
||||
|
||||
: init-hash ( hash -- )
|
||||
0 >>count 0 >>deleted drop ; inline
|
||||
|
@ -61,10 +61,10 @@ TUPLE: hashtable
|
|||
1 fixnum+fast set-slot ; inline
|
||||
|
||||
: hash-count+ ( hash -- )
|
||||
[ 1+ ] change-count drop ; inline
|
||||
[ 1 + ] change-count drop ; inline
|
||||
|
||||
: hash-deleted+ ( hash -- )
|
||||
[ 1+ ] change-deleted drop ; inline
|
||||
[ 1 + ] change-deleted drop ; inline
|
||||
|
||||
: (rehash) ( hash alist -- )
|
||||
swap [ swapd set-at ] curry assoc-each ; inline
|
||||
|
@ -77,7 +77,7 @@ TUPLE: hashtable
|
|||
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
|
||||
|
||||
: grow-hash ( hash -- )
|
||||
[ [ >alist ] [ assoc-size 1+ ] bi ] keep
|
||||
[ [ >alist ] [ assoc-size 1 + ] bi ] keep
|
||||
[ reset-hash ] keep
|
||||
swap (rehash) ;
|
||||
|
||||
|
@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- )
|
|||
PRIVATE>
|
||||
|
||||
M: hashtable >alist
|
||||
[ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
|
||||
[ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
|
||||
[
|
||||
[
|
||||
[ 1 fixnum-shift-fast ] dip
|
||||
|
|
|
@ -20,13 +20,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
|
|||
swap normalize-path (file-appender) swap <encoder> ;
|
||||
|
||||
: file-lines ( path encoding -- seq )
|
||||
<file-reader> lines ;
|
||||
<file-reader> stream-lines ;
|
||||
|
||||
: with-file-reader ( path encoding quot -- )
|
||||
[ <file-reader> ] dip with-input-stream ; inline
|
||||
|
||||
: file-contents ( path encoding -- seq )
|
||||
<file-reader> contents ;
|
||||
<file-reader> stream-contents ;
|
||||
|
||||
: with-file-writer ( path encoding quot -- )
|
||||
[ <file-writer> ] dip with-output-stream ; inline
|
||||
|
|
|
@ -221,10 +221,14 @@ HELP: bl
|
|||
{ $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: lines
|
||||
HELP: stream-lines
|
||||
{ $values { "stream" "an input stream" } { "seq" "a sequence of strings" } }
|
||||
{ $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ;
|
||||
|
||||
HELP: lines
|
||||
{ $values { "seq" "a sequence of strings" } }
|
||||
{ $description "Reads lines of text until from the " { $link input-stream } " until it is exhausted, collecting them in a sequence of strings." } ;
|
||||
|
||||
HELP: each-line
|
||||
{ $values { "quot" { $quotation "( str -- )" } } }
|
||||
{ $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ;
|
||||
|
@ -233,9 +237,14 @@ HELP: each-block
|
|||
{ $values { "quot" { $quotation "( block -- )" } } }
|
||||
{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
|
||||
|
||||
HELP: contents
|
||||
HELP: stream-contents
|
||||
{ $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
|
||||
{ $description "Reads the entire contents of a stream. If the stream is empty, outputs" { $link f } "." }
|
||||
{ $description "Reads the entire contents of a stream. If the stream is empty, outputs " { $link f } "." }
|
||||
$io-error ;
|
||||
|
||||
HELP: contents
|
||||
{ $values { "seq" "a string, byte array or " { $link f } } }
|
||||
{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
|
||||
$io-error ;
|
||||
|
||||
ARTICLE: "stream-protocol" "Stream protocol"
|
||||
|
@ -347,9 +356,11 @@ $nl
|
|||
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
|
||||
{ $subsection stream-print }
|
||||
"Processing lines one by one:"
|
||||
{ $subsection stream-lines }
|
||||
{ $subsection lines }
|
||||
{ $subsection each-line }
|
||||
"Processing blocks of data:"
|
||||
{ $subsection stream-contents }
|
||||
{ $subsection contents }
|
||||
{ $subsection each-block }
|
||||
"Copying the contents of one stream to another:"
|
||||
|
|
|
@ -68,9 +68,12 @@ SYMBOL: error-stream
|
|||
|
||||
: bl ( -- ) " " write ;
|
||||
|
||||
: lines ( stream -- seq )
|
||||
: stream-lines ( stream -- seq )
|
||||
[ [ readln dup ] [ ] produce nip ] with-input-stream ;
|
||||
|
||||
: lines ( -- seq )
|
||||
input-stream get stream-lines ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
|
||||
|
@ -81,11 +84,14 @@ PRIVATE>
|
|||
: each-line ( quot -- )
|
||||
[ readln ] each-morsel ; inline
|
||||
|
||||
: contents ( stream -- seq )
|
||||
: stream-contents ( stream -- seq )
|
||||
[
|
||||
[ 65536 read-partial dup ] [ ] produce nip concat f like
|
||||
] with-input-stream ;
|
||||
|
||||
: contents ( -- seq )
|
||||
input-stream get stream-contents ;
|
||||
|
||||
: each-block ( quot: ( block -- ) -- )
|
||||
[ 8192 read-partial ] each-morsel ; inline
|
||||
|
||||
|
|
|
@ -17,7 +17,7 @@ SYMBOL: current-directory
|
|||
[ path-separator? ] trim-head ;
|
||||
|
||||
: last-path-separator ( path -- n ? )
|
||||
[ length 1- ] keep [ path-separator? ] find-last-from ;
|
||||
[ length 1 - ] keep [ path-separator? ] find-last-from ;
|
||||
|
||||
HOOK: root-directory? io-backend ( path -- ? )
|
||||
|
||||
|
@ -30,7 +30,7 @@ ERROR: no-parent-directory path ;
|
|||
dup root-directory? [
|
||||
trim-tail-separators
|
||||
dup last-path-separator [
|
||||
1+ cut
|
||||
1 + cut
|
||||
] [
|
||||
drop "." swap
|
||||
] if
|
||||
|
@ -113,7 +113,7 @@ PRIVATE>
|
|||
: file-name ( path -- string )
|
||||
dup root-directory? [
|
||||
trim-tail-separators
|
||||
dup last-path-separator [ 1+ tail ] [
|
||||
dup last-path-separator [ 1 + tail ] [
|
||||
drop special-path? [ file-name ] when
|
||||
] if
|
||||
] unless ;
|
||||
|
|
|
@ -5,6 +5,6 @@ IN: io.streams.c.tests
|
|||
[ "hello world" ] [
|
||||
"hello world" "test.txt" temp-file ascii set-file-contents
|
||||
|
||||
"test.txt" temp-file "rb" fopen <c-reader> contents
|
||||
"test.txt" temp-file "rb" fopen <c-reader> stream-contents
|
||||
>string
|
||||
] unit-test
|
||||
|
|
|
@ -12,7 +12,7 @@ SLOT: i
|
|||
[ i>> ] [ underlying>> ] bi ; inline
|
||||
|
||||
: next ( stream -- )
|
||||
[ 1+ ] change-i drop ; inline
|
||||
[ 1 + ] change-i drop ; inline
|
||||
|
||||
: sequence-read1 ( stream -- elt/f )
|
||||
[ >sequence-stream< ?nth ] [ next ] bi ; inline
|
||||
|
|
|
@ -114,7 +114,7 @@ IN: kernel.tests
|
|||
! Regression
|
||||
: (loop) ( a b c d -- )
|
||||
[ pick ] dip swap [ pick ] dip swap
|
||||
< [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
|
||||
< [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
|
||||
|
||||
: loop ( obj -- )
|
||||
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;
|
||||
|
|
|
@ -49,13 +49,13 @@ SYMBOL: mega-cache-size
|
|||
cell-bits (first-bignum) ; inline
|
||||
|
||||
: most-positive-fixnum ( -- n )
|
||||
first-bignum 1- ; inline
|
||||
first-bignum 1 - ; inline
|
||||
|
||||
: most-negative-fixnum ( -- n )
|
||||
first-bignum neg ; inline
|
||||
|
||||
: (max-array-capacity) ( b -- n )
|
||||
5 - 2^ 1- ; inline
|
||||
5 - 2^ 1 - ; inline
|
||||
|
||||
: max-array-capacity ( -- n )
|
||||
cell-bits (max-array-capacity) ; inline
|
||||
|
@ -64,7 +64,7 @@ SYMBOL: mega-cache-size
|
|||
bootstrap-cell-bits (first-bignum) ;
|
||||
|
||||
: bootstrap-most-positive-fixnum ( -- n )
|
||||
bootstrap-first-bignum 1- ;
|
||||
bootstrap-first-bignum 1 - ;
|
||||
|
||||
: bootstrap-most-negative-fixnum ( -- n )
|
||||
bootstrap-first-bignum neg ;
|
||||
|
|
|
@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ;
|
|||
: next-line ( lexer -- )
|
||||
dup [ line>> ] [ text>> ] bi ?nth >>line-text
|
||||
dup line-text>> length >>line-length
|
||||
[ 1+ ] change-line
|
||||
[ 1 + ] change-line
|
||||
0 >>column
|
||||
drop ;
|
||||
|
||||
|
@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- )
|
|||
|
||||
M: lexer skip-word ( lexer -- )
|
||||
[
|
||||
2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
|
||||
2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if
|
||||
] change-lexer-column ;
|
||||
|
||||
: still-parsing? ( lexer -- ? )
|
||||
|
|
|
@ -50,8 +50,8 @@ IN: math.floats.tests
|
|||
[ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ]
|
||||
unit-test
|
||||
|
||||
[ 2.0 ] [ 1.0 1+ ] unit-test
|
||||
[ 0.0 ] [ 1.0 1- ] unit-test
|
||||
[ 2.0 ] [ 1.0 1 + ] unit-test
|
||||
[ 0.0 ] [ 1.0 1 - ] unit-test
|
||||
|
||||
[ t ] [ 0.0 zero? ] unit-test
|
||||
[ t ] [ -0.0 zero? ] unit-test
|
||||
|
|
|
@ -206,8 +206,8 @@ unit-test
|
|||
[ 2. ] [ 2 1 ratio>float ] unit-test
|
||||
[ .5 ] [ 1 2 ratio>float ] unit-test
|
||||
[ .75 ] [ 3 4 ratio>float ] unit-test
|
||||
[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
|
||||
[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
|
||||
[ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test
|
||||
[ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test
|
||||
[ 0.4 ] [ 6 15 ratio>float ] unit-test
|
||||
|
||||
[ HEX: 3fe553522d230931 ]
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ;
|
|||
! provided with absolutely no warranty."
|
||||
|
||||
! First step: pre-scaling
|
||||
: twos ( x -- y ) dup 1- bitxor log2 ; inline
|
||||
: twos ( x -- y ) dup 1 - bitxor log2 ; inline
|
||||
|
||||
: scale-denonimator ( den -- scaled-den scale' )
|
||||
dup twos neg [ shift ] keep ; inline
|
||||
|
@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ;
|
|||
|
||||
! Second step: loop
|
||||
: shift-mantissa ( scale mantissa -- scale' mantissa' )
|
||||
[ 1+ ] [ 2/ ] bi* ; inline
|
||||
[ 1 + ] [ 2/ ] bi* ; inline
|
||||
|
||||
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
|
||||
[ 2dup /i log2 53 > ]
|
||||
|
@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ;
|
|||
|
||||
! Third step: post-scaling
|
||||
: unscaled-float ( mantissa -- n )
|
||||
52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
|
||||
52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
|
||||
|
||||
: scale-float ( scale mantissa -- float' )
|
||||
[ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
|
||||
|
@ -126,7 +126,7 @@ M: bignum (log2) bignum-log2 ;
|
|||
] [
|
||||
pre-scale
|
||||
/f-loop over odd?
|
||||
[ zero? [ 1+ ] unless ] [ drop ] if
|
||||
[ zero? [ 1 + ] unless ] [ drop ] if
|
||||
post-scale
|
||||
] if
|
||||
] if ; inline
|
||||
|
|
|
@ -63,7 +63,7 @@ PRIVATE>
|
|||
: neg ( x -- -x ) 0 swap - ; inline
|
||||
: recip ( x -- y ) 1 swap / ; inline
|
||||
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
|
||||
: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
|
||||
: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
|
||||
: rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
|
||||
: 2^ ( n -- 2^n ) 1 swap shift ; inline
|
||||
: even? ( n -- ? ) 1 bitand zero? ;
|
||||
|
@ -103,13 +103,13 @@ M: float fp-infinity? ( float -- ? )
|
|||
] if ;
|
||||
|
||||
: next-power-of-2 ( m -- n )
|
||||
dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
|
||||
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
|
||||
|
||||
: power-of-2? ( n -- ? )
|
||||
dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
|
||||
dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable
|
||||
|
||||
: align ( m w -- n )
|
||||
1- [ + ] keep bitnot bitand ; inline
|
||||
1 - [ + ] keep bitnot bitand ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -121,7 +121,7 @@ M: float fp-infinity? ( float -- ? )
|
|||
#! Apply quot to i, keep i and quot, hide n.
|
||||
[ nip call ] 3keep ; inline
|
||||
|
||||
: iterate-next ( i n quot -- i' n quot ) [ 1+ ] 2dip ; inline
|
||||
: iterate-next ( i n quot -- i' n quot ) [ 1 + ] 2dip ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
@ -160,6 +160,6 @@ PRIVATE>
|
|||
[ call ] 2keep rot [
|
||||
drop
|
||||
] [
|
||||
[ 1- ] dip find-last-integer
|
||||
[ 1 - ] dip find-last-integer
|
||||
] if
|
||||
] if ; inline recursive
|
||||
|
|
|
@ -29,7 +29,7 @@ PRIVATE>
|
|||
: inc ( variable -- ) 1 swap +@ ; inline
|
||||
: dec ( variable -- ) -1 swap +@ ; inline
|
||||
: bind ( ns quot -- ) swap >n call ndrop ; inline
|
||||
: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ;
|
||||
: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ;
|
||||
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
|
||||
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
|
||||
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
|
||||
|
|
|
@ -272,7 +272,7 @@ print-use-hook [ [ ] ] initialize
|
|||
: parse-stream ( stream name -- quot )
|
||||
[
|
||||
[
|
||||
lines dup parse-fresh
|
||||
stream-lines dup parse-fresh
|
||||
[ nip ] [ finish-parsing ] 2bi
|
||||
forget-smudged
|
||||
] with-source-file
|
||||
|
|
|
@ -48,12 +48,12 @@ M: object literalize ;
|
|||
|
||||
M: wrapper literalize <wrapper> ;
|
||||
|
||||
M: curry length quot>> length 1+ ;
|
||||
M: curry length quot>> length 1 + ;
|
||||
|
||||
M: curry nth
|
||||
over 0 =
|
||||
[ nip obj>> literalize ]
|
||||
[ [ 1- ] dip quot>> nth ]
|
||||
[ [ 1 - ] dip quot>> nth ]
|
||||
if ;
|
||||
|
||||
INSTANCE: curry immutable-sequence
|
||||
|
|
|
@ -198,7 +198,7 @@ C: <reversed> reversed
|
|||
|
||||
M: reversed virtual-seq seq>> ;
|
||||
|
||||
M: reversed virtual@ seq>> [ length swap - 1- ] keep ;
|
||||
M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
|
||||
|
||||
M: reversed length seq>> length ;
|
||||
|
||||
|
@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence
|
|||
] 3keep ; inline
|
||||
|
||||
: (copy) ( dst i src j n -- dst )
|
||||
dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
|
||||
dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ;
|
||||
inline recursive
|
||||
|
||||
: prepare-subseq ( from to seq -- dst i src j n )
|
||||
|
@ -460,7 +460,7 @@ PRIVATE>
|
|||
[ nip find-last-integer ] (find-from) ; inline
|
||||
|
||||
: find-last ( seq quot -- i elt )
|
||||
[ [ 1- ] dip find-last-integer ] (find) ; inline
|
||||
[ [ 1 - ] dip find-last-integer ] (find) ; inline
|
||||
|
||||
: all? ( seq quot -- ? )
|
||||
(each) all-integers? ; inline
|
||||
|
@ -556,7 +556,7 @@ PRIVATE>
|
|||
[ empty? not ] filter ;
|
||||
|
||||
: mismatch ( seq1 seq2 -- i )
|
||||
[ min-length ] 2keep
|
||||
[ min-length iota ] 2keep
|
||||
[ 2nth-unsafe = not ] 2curry
|
||||
find drop ; inline
|
||||
|
||||
|
@ -595,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
|
|||
: (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
|
||||
2dup length < [
|
||||
[ move ] 3keep
|
||||
[ nth-unsafe pick call [ 1+ ] when ] 2keep
|
||||
[ 1+ ] dip
|
||||
[ nth-unsafe pick call [ 1 + ] when ] 2keep
|
||||
[ 1 + ] dip
|
||||
(filter-here)
|
||||
] [ nip set-length drop ] if ; inline recursive
|
||||
|
||||
|
@ -612,20 +612,20 @@ PRIVATE>
|
|||
[ eq? not ] with filter-here ;
|
||||
|
||||
: prefix ( seq elt -- newseq )
|
||||
over [ over length 1+ ] dip [
|
||||
over [ over length 1 + ] dip [
|
||||
[ 0 swap set-nth-unsafe ] keep
|
||||
[ 1 swap copy ] keep
|
||||
] new-like ;
|
||||
|
||||
: suffix ( seq elt -- newseq )
|
||||
over [ over length 1+ ] dip [
|
||||
over [ over length 1 + ] dip [
|
||||
[ [ over length ] dip set-nth-unsafe ] keep
|
||||
[ 0 swap copy ] keep
|
||||
] new-like ;
|
||||
|
||||
: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
|
||||
: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
|
||||
|
||||
: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
|
||||
: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -633,7 +633,7 @@ PRIVATE>
|
|||
2over = [
|
||||
2drop 2drop
|
||||
] [
|
||||
[ [ 2over + pick ] dip move [ 1+ ] dip ] keep
|
||||
[ [ 2over + pick ] dip move [ 1 + ] dip ] keep
|
||||
move-backward
|
||||
] if ;
|
||||
|
||||
|
@ -641,13 +641,13 @@ PRIVATE>
|
|||
2over = [
|
||||
2drop 2drop
|
||||
] [
|
||||
[ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep
|
||||
[ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep
|
||||
move-forward
|
||||
] if ;
|
||||
|
||||
: (open-slice) ( shift from to seq ? -- )
|
||||
[
|
||||
[ [ 1- ] bi@ ] dip move-forward
|
||||
[ [ 1 - ] bi@ ] dip move-forward
|
||||
] [
|
||||
[ over - ] 2dip move-backward
|
||||
] if ;
|
||||
|
@ -667,7 +667,7 @@ PRIVATE>
|
|||
check-slice [ over [ - ] dip ] dip open-slice ;
|
||||
|
||||
: delete-nth ( n seq -- )
|
||||
[ dup 1+ ] dip delete-slice ;
|
||||
[ dup 1 + ] dip delete-slice ;
|
||||
|
||||
: snip ( from to seq -- head tail )
|
||||
[ swap head ] [ swap tail ] bi-curry bi* ; inline
|
||||
|
@ -679,10 +679,10 @@ PRIVATE>
|
|||
snip-slice surround ;
|
||||
|
||||
: remove-nth ( n seq -- seq' )
|
||||
[ [ { } ] dip dup 1+ ] dip replace-slice ;
|
||||
[ [ { } ] dip dup 1 + ] dip replace-slice ;
|
||||
|
||||
: pop ( seq -- elt )
|
||||
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
|
||||
[ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ;
|
||||
|
||||
: exchange ( m n seq -- )
|
||||
[ nip bounds-check 2drop ]
|
||||
|
@ -692,7 +692,7 @@ PRIVATE>
|
|||
|
||||
: reverse-here ( seq -- )
|
||||
[ length 2/ ] [ length ] [ ] tri
|
||||
[ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
|
||||
[ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
|
||||
|
||||
: reverse ( seq -- newseq )
|
||||
[
|
||||
|
@ -799,7 +799,7 @@ PRIVATE>
|
|||
PRIVATE>
|
||||
|
||||
: start* ( subseq seq n -- i )
|
||||
pick length pick length swap - 1+
|
||||
pick length pick length swap - 1 +
|
||||
[ (start) ] find-from
|
||||
swap [ 3drop ] dip ;
|
||||
|
||||
|
|
|
@ -29,13 +29,13 @@ TUPLE: merge
|
|||
[ [ [ 2drop ] dip nth-unsafe ] dip push ] [
|
||||
pick 2 = [
|
||||
[
|
||||
[ 2drop dup 1+ ] dip
|
||||
[ 2drop dup 1 + ] dip
|
||||
[ nth-unsafe ] curry bi@
|
||||
] dip [ push ] curry bi@
|
||||
] [
|
||||
pick 3 = [
|
||||
[
|
||||
[ 2drop dup 1+ dup 1+ ] dip
|
||||
[ 2drop dup 1 + dup 1 + ] dip
|
||||
[ nth-unsafe ] curry tri@
|
||||
] dip [ push ] curry tri@
|
||||
] [ [ nip subseq ] dip push-all ] if
|
||||
|
@ -57,10 +57,10 @@ TUPLE: merge
|
|||
[ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
|
||||
|
||||
: l-next ( merge -- )
|
||||
[ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
[ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
|
||||
: r-next ( merge -- )
|
||||
[ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
[ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
|
||||
|
||||
: decide ( merge -- ? )
|
||||
[ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
|
||||
|
@ -129,8 +129,8 @@ TUPLE: merge
|
|||
while 2drop ; inline
|
||||
|
||||
: each-pair ( seq quot -- )
|
||||
[ [ length 1+ 2/ ] keep ] dip
|
||||
[ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
|
||||
[ [ length 1 + 2/ ] keep ] dip
|
||||
[ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline
|
||||
|
||||
: (sort-pairs) ( i1 i2 seq quot accum -- )
|
||||
[ 2dup length = ] 2dip rot [
|
||||
|
|
|
@ -55,7 +55,7 @@ PRIVATE>
|
|||
|
||||
: (split) ( separators n seq -- )
|
||||
3dup rot [ member? ] curry find-from drop
|
||||
[ [ swap subseq , ] 2keep 1+ swap (split) ]
|
||||
[ [ swap subseq , ] 2keep 1 + swap (split) ]
|
||||
[ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
|
||||
|
||||
: split, ( seq separators -- ) 0 rot (split) ;
|
||||
|
|
|
@ -749,7 +749,7 @@ HELP: <PRIVATE
|
|||
"<PRIVATE"
|
||||
""
|
||||
": (fac) ( accum n -- n! )"
|
||||
" dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
|
||||
" dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
|
||||
""
|
||||
"PRIVATE>"
|
||||
""
|
||||
|
@ -760,7 +760,7 @@ HELP: <PRIVATE
|
|||
"IN: factorial.private"
|
||||
""
|
||||
": (fac) ( accum n -- n! )"
|
||||
" dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
|
||||
" dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
|
||||
""
|
||||
"IN: factorial"
|
||||
""
|
||||
|
|
|
@ -7,7 +7,7 @@ IN: contributors
|
|||
|
||||
: changelog ( -- authors )
|
||||
image parent-directory [
|
||||
"git log --pretty=format:%an" ascii <process-reader> lines
|
||||
"git log --pretty=format:%an" ascii <process-reader> stream-lines
|
||||
] with-directory ;
|
||||
|
||||
: patch-counts ( authors -- assoc )
|
||||
|
|
|
@ -0,0 +1,4 @@
|
|||
USING: kernel file-trees ;
|
||||
IN: file-trees.tests
|
||||
{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
|
||||
"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop
|
|
@ -0,0 +1,23 @@
|
|||
USING: accessors delegate delegate.protocols io.pathnames
|
||||
kernel locals namespaces sequences vectors
|
||||
tools.annotations prettyprint ;
|
||||
IN: file-trees
|
||||
|
||||
TUPLE: tree node children ;
|
||||
CONSULT: sequence-protocol tree children>> [ node>> ] map ;
|
||||
|
||||
: <tree> ( start -- tree ) V{ } clone
|
||||
[ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
|
||||
|
||||
DEFER: (tree-insert)
|
||||
|
||||
: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
|
||||
:: (tree-insert) ( path-rest path-head tree-children -- )
|
||||
tree-children [ node>> path-head node>> = ] find nip
|
||||
[ path-rest swap tree-insert ]
|
||||
[
|
||||
path-head tree-children push
|
||||
path-rest [ path-head tree-insert ] unless-empty
|
||||
] if* ;
|
||||
: create-tree ( file-list -- tree ) [ path-components ] map
|
||||
t <tree> [ [ tree-insert ] curry each ] keep ;
|
|
@ -33,7 +33,7 @@ M: object handle-message drop ;
|
|||
"--pretty=format:%h %an: %s" ,
|
||||
".." glue ,
|
||||
] { } make
|
||||
latin1 [ input-stream get lines ] with-process-reader ;
|
||||
latin1 [ lines ] with-process-reader ;
|
||||
|
||||
: updates ( from to -- lines )
|
||||
git-log reverse
|
||||
|
|
|
@ -16,7 +16,7 @@ M: output-process-error error.
|
|||
|
||||
: try-output-process ( command -- )
|
||||
>process +stdout+ >>stderr utf8 <process-reader*>
|
||||
[ contents ] [ dup wait-for-process ] bi*
|
||||
[ stream-contents ] [ dup wait-for-process ] bi*
|
||||
0 = [ 2drop ] [ output-process-error ] if ;
|
||||
|
||||
HOOK: really-delete-tree os ( path -- )
|
||||
|
|
|
@ -1,33 +1,43 @@
|
|||
USING: ui.frp help.syntax help.markup monads sequences ;
|
||||
USING: help.markup help.syntax models monads sequences
|
||||
ui.gadgets.buttons ui.gadgets.tracks ;
|
||||
IN: ui.frp
|
||||
|
||||
! Layout utilities
|
||||
|
||||
HELP: ,
|
||||
{ $values { "uiitem" "a gadget or model" } }
|
||||
{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
|
||||
HELP: ->
|
||||
{ $values { "uiitem" "a gadget or model" } { "model" model } }
|
||||
{ $description "Like " { $link , } "but passes its model on for further use." } ;
|
||||
HELP: <hbox>
|
||||
{ $values { "gadgets" "a list of gadgets" } { "track" track } }
|
||||
{ $syntax "[ gadget , gadget , ... ] <hbox>" }
|
||||
{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
|
||||
HELP: <vbox>
|
||||
{ $values { "gadgets" "a list of gadgets" } { "track" track } }
|
||||
{ $syntax "[ gadget , gadget , ... ] <hbox>" }
|
||||
{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
|
||||
|
||||
! Gadgets
|
||||
HELP: <frp-button>
|
||||
{ $values { "text" "the button's label" } { "button" button } }
|
||||
{ $description "Creates an button whose model updates on clicks" } ;
|
||||
|
||||
HELP: <merge>
|
||||
{ $description "Creates a model that merges the updates of two others" } ;
|
||||
{ $values { "models" "a list of models" } { "model" merge-model } }
|
||||
{ $description "Creates a model that merges the updates of others" } ;
|
||||
|
||||
HELP: <filter>
|
||||
{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
|
||||
{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
|
||||
|
||||
HELP: <fold>
|
||||
{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
|
||||
{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
|
||||
|
||||
HELP: switch
|
||||
{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
|
||||
{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
|
||||
|
||||
ARTICLE: { "frp" "instances" } "FRP Instances"
|
||||
|
|
|
@ -14,11 +14,12 @@ M: frp-table row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
|||
M: frp-table row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
||||
M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
||||
|
||||
: <frp-table> ( model quot -- table )
|
||||
frp-table new-line-gadget dup >>renderer swap >>quot swap >>model
|
||||
: <frp-table> ( model -- table )
|
||||
frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
|
||||
f <model> >>selected-value sans-serif-font >>font
|
||||
focus-border-color >>focus-border-color
|
||||
transparent >>column-line-color ;
|
||||
: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
|
||||
: <frp-field> ( -- field ) f <model> <model-field> ;
|
||||
|
||||
! Layout utilities
|
||||
|
@ -27,11 +28,11 @@ GENERIC: output-model ( gadget -- model )
|
|||
M: gadget output-model model>> ;
|
||||
M: frp-table output-model selected-value>> ;
|
||||
|
||||
GENERIC: , ( object -- )
|
||||
GENERIC: , ( uiitem -- )
|
||||
M: gadget , make:, ;
|
||||
M: model , activate-model ;
|
||||
|
||||
GENERIC: -> ( object -- model )
|
||||
GENERIC: -> ( uiitem -- model )
|
||||
M: gadget -> dup make:, output-model ;
|
||||
M: model -> dup , ;
|
||||
M: table -> dup , selected-value>> ;
|
||||
|
|
Loading…
Reference in New Issue