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

Merge branch 'master' of git://factorcode.org/git/factor into mongo-factor-driver

db4
Sascha Matzke 2009-05-02 14:10:36 +02:00
parent 6a3e15665a 50d0597580
commit 57a55aaed6
52 changed files with 227 additions and 143 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/cocoa/dialogs/dialogs.factor
View File

@ -12,6 +12,9 @@ IN: cocoa.dialogs
dup 1 -> setResolvesAliases: dup 1 -> setResolvesAliases:
dup 1 -> setAllowsMultipleSelection: ; dup 1 -> setAllowsMultipleSelection: ;
: <NSDirPanel> ( -- panel ) <NSOpenPanel>
dup 1 -> setCanChooseDirectories: ;
: <NSSavePanel> ( -- panel ) : <NSSavePanel> ( -- panel )
NSSavePanel -> savePanel NSSavePanel -> savePanel
dup 1 -> setCanChooseFiles: dup 1 -> setCanChooseFiles:
@ -21,10 +24,12 @@ IN: cocoa.dialogs
CONSTANT: NSOKButton 1 CONSTANT: NSOKButton 1
CONSTANT: NSCancelButton 0 CONSTANT: NSCancelButton 0
: open-panel ( -- paths ) : (open-panel) ( panel -- paths )
<NSOpenPanel>
dup -> runModal NSOKButton = dup -> runModal NSOKButton =
[ -> filenames CF>string-array ] [ drop f ] if ; [ -> 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 ) : split-path ( path -- dir file )
"/" split1-last [ <NSString> ] bi@ ; "/" split1-last [ <NSString> ] bi@ ;

2
basis/ftp/client/client.factor
View File

@ -66,7 +66,7 @@ ERROR: ftp-error got expected ;
: list ( url -- ftp-response ) : list ( url -- ftp-response )
utf8 open-passive-client utf8 open-passive-client
ftp-list ftp-list
lines stream-lines
<ftp-response> swap >>strings <ftp-response> swap >>strings
read-response 226 ftp-assert read-response 226 ftp-assert
parse-list ; parse-list ;

11
basis/inverse/inverse-tests.factor
View File

@ -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 USING: inverse tools.test arrays math kernel sequences
math.functions math.constants continuations ; math.functions math.constants continuations combinators.smart ;
IN: inverse-tests IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
@ -69,7 +71,7 @@ C: <nil> nil
[ t ] [ pi [ pi ] matches? ] unit-test [ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] 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 [ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test [ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
@ -88,4 +90,7 @@ TUPLE: funny-tuple ;
: <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ; : <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
: funny-tuple ( -- ) "OOPS" throw ; : funny-tuple ( -- ) "OOPS" throw ;
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test [ ] [ [ <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

59
basis/inverse/inverse.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel words summary slots quotations USING: accessors kernel words summary slots quotations
sequences assocs math arrays stack-checker effects generalizations sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting sequences.private combinators mirrors splitting combinators.smart
combinators.short-circuit fry words.symbol generalizations ; combinators.short-circuit fry words.symbol generalizations
RENAME: _ fry => __ classes ;
IN: inverse IN: inverse
ERROR: fail ; ERROR: fail ;
@ -14,7 +14,7 @@ M: fail summary drop "Matching failed" ;
: assure ( ? -- ) [ fail ] unless ; inline : assure ( ? -- ) [ fail ] unless ; inline
: =/fail ( obj1 obj2 -- ) = assure ; : =/fail ( obj1 obj2 -- ) = assure ; inline
! Inverse of a quotation ! Inverse of a quotation
@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ;
\ pick [ [ pick ] dip =/fail ] define-inverse \ pick [ [ pick ] dip =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] 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 \ not define-involution
\ >boolean [ { t f } memq? assure ] define-inverse \ >boolean [ dup { t f } memq? assure ] define-inverse
\ tuple>array \ >tuple define-dual \ tuple>array \ >tuple define-dual
\ reverse define-involution \ reverse define-involution
\ undo 1 [ [ call ] curry ] define-pop-inverse \ undo 1 [ ] define-pop-inverse
\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse \ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
\ exp \ log define-dual \ exp \ log define-dual
\ sq \ sqrt define-dual \ sq \ sqrt define-dual
@ -173,16 +178,13 @@ ERROR: missing-literal ;
2curry 2curry
] define-pop-inverse ] define-pop-inverse
DEFER: _ DEFER: __
\ _ [ drop ] define-inverse \ __ [ drop ] define-inverse
: both ( object object -- object ) : both ( object object -- object )
dupd assert= ; dupd assert= ;
\ both [ dup ] define-inverse \ both [ dup ] define-inverse
: assure-length ( seq length -- seq )
over length =/fail ;
{ {
{ >array array? } { >array array? }
{ >vector vector? } { >vector vector? }
@ -194,14 +196,23 @@ DEFER: _
{ >string string? } { >string string? }
{ >sbuf sbuf? } { >sbuf sbuf? }
{ >quotation quotation? } { >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? : assure-length ( seq length -- )
\ 1array [ 1 assure-length first ] define-inverse swap length =/fail ; inline
\ 2array [ 2 assure-length first2 ] define-inverse
\ 3array [ 3 assure-length first3 ] define-inverse : assure-array ( array -- array )
\ 4array [ 4 assure-length first4 ] define-inverse dup array? assure ; inline
\ narray 1 [ [ firstn ] curry ] define-pop-inverse
: 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 \ first [ 1array ] define-inverse
\ first2 [ 2array ] define-inverse \ first2 [ 2array ] define-inverse
@ -214,6 +225,12 @@ DEFER: _
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
\ prepend 1 [ [ ?head 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 ! Constructor inverse
: deconstruct-pred ( class -- quot ) : deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ; "predicate" word-prop [ dupd call assure ] curry ;
@ -245,7 +262,7 @@ DEFER: _
] recover ; inline ] recover ; inline
: true-out ( quot effect -- quot' ) : true-out ( quot effect -- quot' )
out>> '[ @ __ ndrop t ] ; out>> '[ @ _ ndrop t ] ;
: false-recover ( effect -- quot ) : false-recover ( effect -- quot )
in>> [ ndrop f ] curry [ recover-fail ] curry ; in>> [ ndrop f ] curry [ recover-fail ] curry ;

2
basis/io/encodings/string/string.factor
View File

@ -4,7 +4,7 @@ USING: io io.streams.byte-array ;
IN: io.encodings.string IN: io.encodings.string
: decode ( byte-array encoding -- string ) : decode ( byte-array encoding -- string )
<byte-reader> contents ; <byte-reader> stream-contents ;
: encode ( string encoding -- byte-array ) : encode ( string encoding -- byte-array )
[ write ] with-byte-writer ; [ write ] with-byte-writer ;

8
basis/io/launcher/launcher.factor
View File

@ -3,9 +3,9 @@
USING: system kernel namespaces strings hashtables sequences USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment math accessors concurrency.flags destructors environment
io io.backend io.timeouts io.pipes io.pipes.private io.encodings io io.encodings.ascii io.backend io.timeouts io.pipes
io.streams.duplex io.ports debugger prettyprint summary io.pipes.private io.encodings io.streams.duplex io.ports
calendar ; debugger prettyprint summary calendar ;
IN: io.launcher IN: io.launcher
TUPLE: process < identity-tuple TUPLE: process < identity-tuple
@ -265,3 +265,5 @@ M: object run-pipeline-element
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] } { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
[ ] [ ]
} cond } cond
: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;

14
basis/io/launcher/unix/unix-tests.factor
View File

@ -33,7 +33,7 @@ concurrency.promises threads unix.process ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-reader> contents ascii <process-reader> stream-contents
] unit-test ] unit-test
[ ] [ [ ] [
@ -52,7 +52,7 @@ concurrency.promises threads unix.process ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-reader> contents ascii <process-reader> stream-contents
] unit-test ] unit-test
[ ] [ [ ] [
@ -70,14 +70,14 @@ concurrency.promises threads unix.process ;
"cat" "cat"
"launcher-test-1" temp-file "launcher-test-1" temp-file
2array 2array
ascii <process-reader> contents ascii <process-reader> stream-contents
] unit-test ] unit-test
[ t ] [ [ t ] [
<process> <process>
"env" >>command "env" >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
ascii <process-reader> lines ascii <process-reader> stream-lines
"A=B" swap member? "A=B" swap member?
] unit-test ] unit-test
@ -86,7 +86,7 @@ concurrency.promises threads unix.process ;
"env" >>command "env" >>command
{ { "A" "B" } } >>environment { { "A" "B" } } >>environment
+replace-environment+ >>environment-mode +replace-environment+ >>environment-mode
ascii <process-reader> lines ascii <process-reader> stream-lines
] unit-test ] unit-test
[ "hi\n" ] [ [ "hi\n" ] [
@ -113,13 +113,13 @@ concurrency.promises threads unix.process ;
"append-test" temp-file utf8 file-contents "append-test" temp-file utf8 file-contents
] unit-test ] unit-test
[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test [ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
[ "Hello world.\n" ] [ [ "Hello world.\n" ] [
"cat" utf8 <process-stream> [ "cat" utf8 <process-stream> [
"Hello world.\n" write "Hello world.\n" write
output-stream get dispose output-stream get dispose
input-stream get contents input-stream get stream-contents
] with-stream ] with-stream
] unit-test ] unit-test

2
basis/io/servers/connection/connection-tests.factor
View File

@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ;
dup start-server* sockets>> first addr>> port>> "port" set dup start-server* sockets>> first addr>> port>> "port" set
] unit-test ] 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

2
basis/io/sockets/secure/unix/unix-tests.factor
View File

@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ;
: client-test ( -- string ) : client-test ( -- string )
<secure-config> [ <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 ; ] with-secure-context ;
[ ] [ [ class name>> write ] server-test ] unit-test [ ] [ [ class name>> write ] server-test ] unit-test

4
basis/io/streams/byte-array/byte-array-tests.factor
View File

@ -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 } ] [ 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 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{ 121 120 } 0 ] [
B{ 0 121 120 0 0 0 0 0 0 } binary B{ 0 121 120 0 0 0 0 0 0 } binary
@ -26,4 +26,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
0 seek-end input-stream get stream-seek 0 seek-end input-stream get stream-seek
read1 read1
] with-byte-reader ] with-byte-reader
] unit-test ] unit-test

2
basis/random/random.factor
View File

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

4
basis/ui/tools/listener/listener-tests.factor
View File

@ -75,7 +75,7 @@ CONSTANT: text "Hello world.\nThis is a test."
[ ] [ [ ] [
[ [
"interactor" get register-self "interactor" get register-self
"interactor" get contents "promise" get fulfill "interactor" get stream-contents "promise" get fulfill
] in-thread ] in-thread
] unit-test ] unit-test
@ -150,4 +150,4 @@ CONSTANT: text "Hello world.\nThis is a test."
[ ] [ <listener-gadget> "l" set ] unit-test [ ] [ <listener-gadget> "l" set ] unit-test
[ ] [ "l" get com-scroll-up ] unit-test [ ] [ "l" get com-scroll-up ] unit-test
[ ] [ "l" get com-scroll-down ] unit-test [ ] [ "l" get com-scroll-down ] unit-test

2
basis/xmode/code2html/code2html.factor
View File

@ -24,7 +24,7 @@ IN: xmode.code2html
[XML <style><-></style> XML] ; [XML <style><-></style> XML] ;
:: htmlize-stream ( path stream -- xml ) :: htmlize-stream ( path stream -- xml )
stream lines stream stream-lines
[ "" ] [ path over first find-mode htmlize-lines ] [ "" ] [ path over first find-mode htmlize-lines ]
if-empty :> input if-empty :> input
default-stylesheet :> stylesheet default-stylesheet :> stylesheet

4
core/assocs/assocs.factor
View File

@ -32,7 +32,7 @@ M: assoc assoc-like drop ;
3drop f 3drop f
] [ ] [
3dup nth-unsafe at* 3dup nth-unsafe at*
[ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
] if ; inline recursive ] if ; inline recursive
: search-alist ( key alist -- pair/f i/f ) : search-alist ( key alist -- pair/f i/f )
@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
assoc-size 0 = ; assoc-size 0 = ;
: assoc-stack ( key seq -- value ) : assoc-stack ( key seq -- value )
[ length 1- ] keep (assoc-stack) ; flushable [ length 1 - ] keep (assoc-stack) ; flushable
: assoc-subset? ( assoc1 assoc2 -- ? ) : assoc-subset? ( assoc1 assoc2 -- ? )
[ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ; [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;

2
core/bootstrap/primitives.factor
View File

@ -513,4 +513,4 @@ tuple
} [ [ first3 ] dip swap make-primitive ] each-index } [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number ! Bump build number
"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared "build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared

2
core/checksums/checksums.factor
View File

@ -13,7 +13,7 @@ GENERIC: checksum-stream ( stream checksum -- value )
GENERIC: checksum-lines ( lines checksum -- value ) GENERIC: checksum-lines ( lines checksum -- value )
M: checksum checksum-stream M: checksum checksum-stream
[ contents ] dip checksum-bytes ; [ stream-contents ] dip checksum-bytes ;
M: checksum checksum-lines M: checksum checksum-lines
[ B{ CHAR: \n } join ] dip checksum-bytes ; [ B{ CHAR: \n } join ] dip checksum-bytes ;

2
core/checksums/crc32/crc32.factor
View File

@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320
CONSTANT: crc32-table V{ } CONSTANT: crc32-table V{ }
256 [ 256 iota [
8 [ 8 [
[ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
] times >bignum ] times >bignum

2
core/classes/tuple/tuple-docs.factor
View File

@ -254,7 +254,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
" } ;" " } ;"
"" ""
": next-position ( role -- newrole )" ": next-position ( role -- newrole )"
" positions [ index 1+ ] keep nth ;" " positions [ index 1 + ] keep nth ;"
"" ""
": promote ( employee -- employee )" ": promote ( employee -- employee )"
" [ 1.2 * ] change-salary" " [ 1.2 * ] change-salary"

4
core/classes/tuple/tuple.factor
View File

@ -165,7 +165,7 @@ ERROR: bad-superclass class ;
{ {
[ , ] [ , ]
[ [ superclass class-size ] [ "slots" word-prop length ] bi + , ] [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
[ superclasses length 1- , ] [ superclasses length 1 - , ]
[ superclasses [ [ , ] [ hashcode , ] bi ] each ] [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
} cleave } cleave
] { } make ; ] { } make ;
@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x )
M: tuple tuple-hashcode M: tuple tuple-hashcode
[ [
[ class hashcode ] [ tuple-size ] [ ] tri [ class hashcode ] [ tuple-size iota ] [ ] tri
[ rot ] dip [ [ rot ] dip [
swapd array-nth hashcode* sequence-hashcode-step swapd array-nth hashcode* sequence-hashcode-step
] 2curry each ] 2curry each

4
core/combinators/combinators.factor
View File

@ -123,7 +123,7 @@ ERROR: no-case object ;
[ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ; [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
: hash-dispatch-quot ( table -- quot ) : hash-dispatch-quot ( table -- quot )
[ length 1- [ fixnum-bitand ] curry ] keep [ length 1 - [ fixnum-bitand ] curry ] keep
[ dispatch ] curry append ; [ dispatch ] curry append ;
: hash-case-quot ( default assoc -- quot ) : hash-case-quot ( default assoc -- quot )
@ -162,7 +162,7 @@ ERROR: no-case object ;
! recursive-hashcode ! recursive-hashcode
: recursive-hashcode ( n obj quot -- code ) : 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 ! These go here, not in sequences and hashtables, since those
! two cannot depend on us ! two cannot depend on us

2
core/continuations/continuations-tests.factor
View File

@ -4,7 +4,7 @@ kernel.private accessors eval ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) ( n obj -- n' obj ) : (callcc1-test) ( n obj -- n' obj )
[ 1- dup ] dip ?push [ 1 - dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ; (callcc1-test) ;

4
core/generic/single/single.factor
View File

@ -178,7 +178,7 @@ M: echelon-dispatch-engine compile-engine
M: tuple-dispatch-engine compile-engine M: tuple-dispatch-engine compile-engine
tuple assumed [ tuple assumed [
echelons>> compile-engines echelons>> compile-engines
dup keys supremum 1+ f <array> dup keys supremum 1 + f <array>
[ <enum> swap update ] keep [ <enum> swap update ] keep
] with-variable ; ] with-variable ;
@ -253,4 +253,4 @@ M: single-combination perform-combination
[ mega-cache-quot define ] [ mega-cache-quot define ]
[ define-inline-cache-quot ] [ define-inline-cache-quot ]
2tri 2tri
] with-combination ; ] with-combination ;

2
core/generic/standard/standard.factor
View File

@ -28,7 +28,7 @@ CONSTANT: simple-combination T{ standard-combination f 0 }
{ 0 [ [ dup ] ] } { 0 [ [ dup ] ] }
{ 1 [ [ over ] ] } { 1 [ [ over ] ] }
{ 2 [ [ pick ] ] } { 2 [ [ pick ] ] }
[ 1- (picker) [ dip swap ] curry ] [ 1 - (picker) [ dip swap ] curry ]
} case ; } case ;
M: standard-combination picker M: standard-combination picker

2
core/growable/growable.factor
View File

@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
] if ] if
(>>length) ; (>>length) ;
: new-size ( old -- new ) 1+ 3 * ; inline : new-size ( old -- new ) 1 + 3 * ; inline
: ensure ( n seq -- n seq ) : ensure ( n seq -- n seq )
growable-check growable-check

10
core/hashtables/hashtables.factor
View File

@ -34,7 +34,7 @@ TUPLE: hashtable
[ no-key ] [ 2dup hash@ (key@) ] if ; inline [ no-key ] [ 2dup hash@ (key@) ] if ; inline
: <hash-array> ( n -- array ) : <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 -- ) : init-hash ( hash -- )
0 >>count 0 >>deleted drop ; inline 0 >>count 0 >>deleted drop ; inline
@ -61,10 +61,10 @@ TUPLE: hashtable
1 fixnum+fast set-slot ; inline 1 fixnum+fast set-slot ; inline
: hash-count+ ( hash -- ) : hash-count+ ( hash -- )
[ 1+ ] change-count drop ; inline [ 1 + ] change-count drop ; inline
: hash-deleted+ ( hash -- ) : hash-deleted+ ( hash -- )
[ 1+ ] change-deleted drop ; inline [ 1 + ] change-deleted drop ; inline
: (rehash) ( hash alist -- ) : (rehash) ( hash alist -- )
swap [ swapd set-at ] curry assoc-each ; inline swap [ swapd set-at ] curry assoc-each ; inline
@ -77,7 +77,7 @@ TUPLE: hashtable
[ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
: grow-hash ( hash -- ) : grow-hash ( hash -- )
[ [ >alist ] [ assoc-size 1+ ] bi ] keep [ [ >alist ] [ assoc-size 1 + ] bi ] keep
[ reset-hash ] keep [ reset-hash ] keep
swap (rehash) ; swap (rehash) ;
@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- )
PRIVATE> PRIVATE>
M: hashtable >alist 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 [ 1 fixnum-shift-fast ] dip

4
core/io/files/files.factor
View File

@ -20,13 +20,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
swap normalize-path (file-appender) swap <encoder> ; swap normalize-path (file-appender) swap <encoder> ;
: file-lines ( path encoding -- seq ) : file-lines ( path encoding -- seq )
<file-reader> lines ; <file-reader> stream-lines ;
: with-file-reader ( path encoding quot -- ) : with-file-reader ( path encoding quot -- )
[ <file-reader> ] dip with-input-stream ; inline [ <file-reader> ] dip with-input-stream ; inline
: file-contents ( path encoding -- seq ) : file-contents ( path encoding -- seq )
<file-reader> contents ; <file-reader> stream-contents ;
: with-file-writer ( path encoding quot -- ) : with-file-writer ( path encoding quot -- )
[ <file-writer> ] dip with-output-stream ; inline [ <file-writer> ] dip with-output-stream ; inline

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

@ -221,10 +221,14 @@ HELP: bl
{ $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." } { $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
$io-error ; $io-error ;
HELP: lines HELP: stream-lines
{ $values { "stream" "an input stream" } { "seq" "a sequence of strings" } } { $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." } ; { $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 HELP: each-line
{ $values { "quot" { $quotation "( str -- )" } } } { $values { "quot" { $quotation "( str -- )" } } }
{ $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ; { $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 -- )" } } } { $values { "quot" { $quotation "( block -- )" } } }
{ $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ; { $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 } } } { $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 ; $io-error ;
ARTICLE: "stream-protocol" "Stream protocol" ARTICLE: "stream-protocol" "Stream protocol"
@ -347,9 +356,11 @@ $nl
"First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":" "First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
{ $subsection stream-print } { $subsection stream-print }
"Processing lines one by one:" "Processing lines one by one:"
{ $subsection stream-lines }
{ $subsection lines } { $subsection lines }
{ $subsection each-line } { $subsection each-line }
"Processing blocks of data:" "Processing blocks of data:"
{ $subsection stream-contents }
{ $subsection contents } { $subsection contents }
{ $subsection each-block } { $subsection each-block }
"Copying the contents of one stream to another:" "Copying the contents of one stream to another:"

10
core/io/io.factor
View File

@ -68,9 +68,12 @@ SYMBOL: error-stream
: bl ( -- ) " " write ; : bl ( -- ) " " write ;
: lines ( stream -- seq ) : stream-lines ( stream -- seq )
[ [ readln dup ] [ ] produce nip ] with-input-stream ; [ [ readln dup ] [ ] produce nip ] with-input-stream ;
: lines ( -- seq )
input-stream get stream-lines ;
<PRIVATE <PRIVATE
: each-morsel ( handler: ( data -- ) reader: ( -- data ) -- ) : each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
@ -81,11 +84,14 @@ PRIVATE>
: each-line ( quot -- ) : each-line ( quot -- )
[ readln ] each-morsel ; inline [ readln ] each-morsel ; inline
: contents ( stream -- seq ) : stream-contents ( stream -- seq )
[ [
[ 65536 read-partial dup ] [ ] produce nip concat f like [ 65536 read-partial dup ] [ ] produce nip concat f like
] with-input-stream ; ] with-input-stream ;
: contents ( -- seq )
input-stream get stream-contents ;
: each-block ( quot: ( block -- ) -- ) : each-block ( quot: ( block -- ) -- )
[ 8192 read-partial ] each-morsel ; inline [ 8192 read-partial ] each-morsel ; inline

6
core/io/pathnames/pathnames.factor
View File

@ -17,7 +17,7 @@ SYMBOL: current-directory
[ path-separator? ] trim-head ; [ path-separator? ] trim-head ;
: last-path-separator ( path -- n ? ) : 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 -- ? ) HOOK: root-directory? io-backend ( path -- ? )
@ -30,7 +30,7 @@ ERROR: no-parent-directory path ;
dup root-directory? [ dup root-directory? [
trim-tail-separators trim-tail-separators
dup last-path-separator [ dup last-path-separator [
1+ cut 1 + cut
] [ ] [
drop "." swap drop "." swap
] if ] if
@ -113,7 +113,7 @@ PRIVATE>
: file-name ( path -- string ) : file-name ( path -- string )
dup root-directory? [ dup root-directory? [
trim-tail-separators trim-tail-separators
dup last-path-separator [ 1+ tail ] [ dup last-path-separator [ 1 + tail ] [
drop special-path? [ file-name ] when drop special-path? [ file-name ] when
] if ] if
] unless ; ] unless ;

2
core/io/streams/c/c-tests.factor
View File

@ -5,6 +5,6 @@ IN: io.streams.c.tests
[ "hello world" ] [ [ "hello world" ] [
"hello world" "test.txt" temp-file ascii set-file-contents "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 >string
] unit-test ] unit-test

4
core/io/streams/sequence/sequence.factor
View File

@ -12,7 +12,7 @@ SLOT: i
[ i>> ] [ underlying>> ] bi ; inline [ i>> ] [ underlying>> ] bi ; inline
: next ( stream -- ) : next ( stream -- )
[ 1+ ] change-i drop ; inline [ 1 + ] change-i drop ; inline
: sequence-read1 ( stream -- elt/f ) : sequence-read1 ( stream -- elt/f )
[ >sequence-stream< ?nth ] [ next ] bi ; inline [ >sequence-stream< ?nth ] [ next ] bi ; inline
@ -45,4 +45,4 @@ M: growable stream-write1 push ;
M: growable stream-write push-all ; M: growable stream-write push-all ;
M: growable stream-flush drop ; M: growable stream-flush drop ;
INSTANCE: growable plain-writer INSTANCE: growable plain-writer

2
core/kernel/kernel-tests.factor
View File

@ -114,7 +114,7 @@ IN: kernel.tests
! Regression ! Regression
: (loop) ( a b c d -- ) : (loop) ( a b c d -- )
[ pick ] dip swap [ pick ] dip swap [ pick ] dip swap [ pick ] dip swap
< [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
: loop ( obj -- ) : loop ( obj -- )
H{ } values swap [ dup length swap ] dip 0 -roll (loop) ; H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;

6
core/layouts/layouts.factor
View File

@ -49,13 +49,13 @@ SYMBOL: mega-cache-size
cell-bits (first-bignum) ; inline cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n ) : most-positive-fixnum ( -- n )
first-bignum 1- ; inline first-bignum 1 - ; inline
: most-negative-fixnum ( -- n ) : most-negative-fixnum ( -- n )
first-bignum neg ; inline first-bignum neg ; inline
: (max-array-capacity) ( b -- n ) : (max-array-capacity) ( b -- n )
5 - 2^ 1- ; inline 5 - 2^ 1 - ; inline
: max-array-capacity ( -- n ) : max-array-capacity ( -- n )
cell-bits (max-array-capacity) ; inline cell-bits (max-array-capacity) ; inline
@ -64,7 +64,7 @@ SYMBOL: mega-cache-size
bootstrap-cell-bits (first-bignum) ; bootstrap-cell-bits (first-bignum) ;
: bootstrap-most-positive-fixnum ( -- n ) : bootstrap-most-positive-fixnum ( -- n )
bootstrap-first-bignum 1- ; bootstrap-first-bignum 1 - ;
: bootstrap-most-negative-fixnum ( -- n ) : bootstrap-most-negative-fixnum ( -- n )
bootstrap-first-bignum neg ; bootstrap-first-bignum neg ;

4
core/lexer/lexer.factor
View File

@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ;
: next-line ( lexer -- ) : next-line ( lexer -- )
dup [ line>> ] [ text>> ] bi ?nth >>line-text dup [ line>> ] [ text>> ] bi ?nth >>line-text
dup line-text>> length >>line-length dup line-text>> length >>line-length
[ 1+ ] change-line [ 1 + ] change-line
0 >>column 0 >>column
drop ; drop ;
@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- )
M: lexer 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 ; ] change-lexer-column ;
: still-parsing? ( lexer -- ? ) : still-parsing? ( lexer -- ? )

4
core/math/floats/floats-tests.factor
View File

@ -50,8 +50,8 @@ IN: math.floats.tests
[ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ] [ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ]
unit-test unit-test
[ 2.0 ] [ 1.0 1+ ] unit-test [ 2.0 ] [ 1.0 1 + ] unit-test
[ 0.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
[ t ] [ -0.0 zero? ] unit-test [ t ] [ -0.0 zero? ] unit-test

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

@ -206,8 +206,8 @@ unit-test
[ 2. ] [ 2 1 ratio>float ] unit-test [ 2. ] [ 2 1 ratio>float ] unit-test
[ .5 ] [ 1 2 ratio>float ] unit-test [ .5 ] [ 1 2 ratio>float ] unit-test
[ .75 ] [ 3 4 ratio>float ] unit-test [ .75 ] [ 3 4 ratio>float ] unit-test
[ 1. ] [ 2000 2^ 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 [ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test
[ 0.4 ] [ 6 15 ratio>float ] unit-test [ 0.4 ] [ 6 15 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ] [ HEX: 3fe553522d230931 ]

10
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 ;
@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ;
! provided with absolutely no warranty." ! provided with absolutely no warranty."
! First step: pre-scaling ! 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' ) : scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline dup twos neg [ shift ] keep ; inline
@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ;
! Second step: loop ! Second step: loop
: shift-mantissa ( scale mantissa -- scale' mantissa' ) : shift-mantissa ( scale mantissa -- scale' mantissa' )
[ 1+ ] [ 2/ ] bi* ; inline [ 1 + ] [ 2/ ] bi* ; inline
: /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 > ]
@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ;
! Third step: post-scaling ! Third step: post-scaling
: unscaled-float ( mantissa -- n ) : 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' ) : scale-float ( scale mantissa -- float' )
[ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
@ -126,7 +126,7 @@ M: bignum (log2) bignum-log2 ;
] [ ] [
pre-scale pre-scale
/f-loop over odd? /f-loop over odd?
[ zero? [ 1+ ] unless ] [ drop ] if [ zero? [ 1 + ] unless ] [ drop ] if
post-scale post-scale
] if ] if
] if ; inline ] if ; inline

12
core/math/math.factor
View File

@ -63,7 +63,7 @@ PRIVATE>
: neg ( x -- -x ) 0 swap - ; inline : neg ( x -- -x ) 0 swap - ; inline
: recip ( x -- y ) 1 swap / ; inline : recip ( x -- y ) 1 swap / ; inline
: sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; 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 : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
: 2^ ( n -- 2^n ) 1 swap shift ; inline : 2^ ( n -- 2^n ) 1 swap shift ; inline
: even? ( n -- ? ) 1 bitand zero? ; : even? ( n -- ? ) 1 bitand zero? ;
@ -103,13 +103,13 @@ M: float fp-infinity? ( float -- ? )
] if ; ] if ;
: next-power-of-2 ( m -- n ) : 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 -- ? ) : 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 ) : align ( m w -- n )
1- [ + ] keep bitnot bitand ; inline 1 - [ + ] keep bitnot bitand ; inline
<PRIVATE <PRIVATE
@ -121,7 +121,7 @@ M: float fp-infinity? ( float -- ? )
#! Apply quot to i, keep i and quot, hide n. #! Apply quot to i, keep i and quot, hide n.
[ nip call ] 3keep ; inline [ 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> PRIVATE>
@ -160,6 +160,6 @@ PRIVATE>
[ call ] 2keep rot [ [ call ] 2keep rot [
drop drop
] [ ] [
[ 1- ] dip find-last-integer [ 1 - ] dip find-last-integer
] if ] if
] if ; inline recursive ] if ; inline recursive

4
core/namespaces/namespaces.factor
View File

@ -29,8 +29,8 @@ PRIVATE>
: inc ( variable -- ) 1 swap +@ ; inline : inc ( variable -- ) 1 swap +@ ; inline
: dec ( variable -- ) -1 swap +@ ; inline : dec ( variable -- ) -1 swap +@ ; inline
: bind ( ns quot -- ) swap >n call ndrop ; 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 : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline : with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline : with-variable ( value key quot -- ) [ associate ] dip bind ; inline
: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline : initialize ( variable quot -- ) [ unless* ] curry change-global ; inline

2
core/parser/parser.factor
View File

@ -272,7 +272,7 @@ print-use-hook [ [ ] ] initialize
: parse-stream ( stream name -- quot ) : parse-stream ( stream name -- quot )
[ [
[ [
lines dup parse-fresh stream-lines dup parse-fresh
[ nip ] [ finish-parsing ] 2bi [ nip ] [ finish-parsing ] 2bi
forget-smudged forget-smudged
] with-source-file ] with-source-file

4
core/quotations/quotations.factor
View File

@ -48,12 +48,12 @@ M: object literalize ;
M: wrapper literalize <wrapper> ; M: wrapper literalize <wrapper> ;
M: curry length quot>> length 1+ ; M: curry length quot>> length 1 + ;
M: curry nth M: curry nth
over 0 = over 0 =
[ nip obj>> literalize ] [ nip obj>> literalize ]
[ [ 1- ] dip quot>> nth ] [ [ 1 - ] dip quot>> nth ]
if ; if ;
INSTANCE: curry immutable-sequence INSTANCE: curry immutable-sequence

36
core/sequences/sequences.factor
View File

@ -198,7 +198,7 @@ C: <reversed> reversed
M: reversed virtual-seq seq>> ; 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 ; M: reversed length seq>> length ;
@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence
] 3keep ; inline ] 3keep ; inline
: (copy) ( dst i src j n -- dst ) : (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 inline recursive
: prepare-subseq ( from to seq -- dst i src j n ) : prepare-subseq ( from to seq -- dst i src j n )
@ -460,7 +460,7 @@ PRIVATE>
[ nip find-last-integer ] (find-from) ; inline [ nip find-last-integer ] (find-from) ; inline
: find-last ( seq quot -- i elt ) : find-last ( seq quot -- i elt )
[ [ 1- ] dip find-last-integer ] (find) ; inline [ [ 1 - ] dip find-last-integer ] (find) ; inline
: all? ( seq quot -- ? ) : all? ( seq quot -- ? )
(each) all-integers? ; inline (each) all-integers? ; inline
@ -556,7 +556,7 @@ PRIVATE>
[ empty? not ] filter ; [ empty? not ] filter ;
: mismatch ( seq1 seq2 -- i ) : mismatch ( seq1 seq2 -- i )
[ min-length ] 2keep [ min-length iota ] 2keep
[ 2nth-unsafe = not ] 2curry [ 2nth-unsafe = not ] 2curry
find drop ; inline find drop ; inline
@ -595,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
: (filter-here) ( quot: ( elt -- ? ) store scan seq -- ) : (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
2dup length < [ 2dup length < [
[ move ] 3keep [ move ] 3keep
[ nth-unsafe pick call [ 1+ ] when ] 2keep [ nth-unsafe pick call [ 1 + ] when ] 2keep
[ 1+ ] dip [ 1 + ] dip
(filter-here) (filter-here)
] [ nip set-length drop ] if ; inline recursive ] [ nip set-length drop ] if ; inline recursive
@ -612,20 +612,20 @@ PRIVATE>
[ eq? not ] with filter-here ; [ eq? not ] with filter-here ;
: prefix ( seq elt -- newseq ) : prefix ( seq elt -- newseq )
over [ over length 1+ ] dip [ over [ over length 1 + ] dip [
[ 0 swap set-nth-unsafe ] keep [ 0 swap set-nth-unsafe ] keep
[ 1 swap copy ] keep [ 1 swap copy ] keep
] new-like ; ] new-like ;
: suffix ( seq elt -- newseq ) : suffix ( seq elt -- newseq )
over [ over length 1+ ] dip [ over [ over length 1 + ] dip [
[ [ over length ] dip set-nth-unsafe ] keep [ [ over length ] dip set-nth-unsafe ] keep
[ 0 swap copy ] keep [ 0 swap copy ] keep
] new-like ; ] 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 <PRIVATE
@ -633,7 +633,7 @@ PRIVATE>
2over = [ 2over = [
2drop 2drop 2drop 2drop
] [ ] [
[ [ 2over + pick ] dip move [ 1+ ] dip ] keep [ [ 2over + pick ] dip move [ 1 + ] dip ] keep
move-backward move-backward
] if ; ] if ;
@ -641,13 +641,13 @@ PRIVATE>
2over = [ 2over = [
2drop 2drop 2drop 2drop
] [ ] [
[ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep [ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep
move-forward move-forward
] if ; ] if ;
: (open-slice) ( shift from to seq ? -- ) : (open-slice) ( shift from to seq ? -- )
[ [
[ [ 1- ] bi@ ] dip move-forward [ [ 1 - ] bi@ ] dip move-forward
] [ ] [
[ over - ] 2dip move-backward [ over - ] 2dip move-backward
] if ; ] if ;
@ -667,7 +667,7 @@ PRIVATE>
check-slice [ over [ - ] dip ] dip open-slice ; check-slice [ over [ - ] dip ] dip open-slice ;
: delete-nth ( n seq -- ) : delete-nth ( n seq -- )
[ dup 1+ ] dip delete-slice ; [ dup 1 + ] dip delete-slice ;
: snip ( from to seq -- head tail ) : snip ( from to seq -- head tail )
[ swap head ] [ swap tail ] bi-curry bi* ; inline [ swap head ] [ swap tail ] bi-curry bi* ; inline
@ -679,10 +679,10 @@ PRIVATE>
snip-slice surround ; snip-slice surround ;
: remove-nth ( n seq -- seq' ) : remove-nth ( n seq -- seq' )
[ [ { } ] dip dup 1+ ] dip replace-slice ; [ [ { } ] dip dup 1 + ] dip replace-slice ;
: pop ( seq -- elt ) : pop ( seq -- elt )
[ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ; [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ;
: exchange ( m n seq -- ) : exchange ( m n seq -- )
[ nip bounds-check 2drop ] [ nip bounds-check 2drop ]
@ -692,7 +692,7 @@ PRIVATE>
: reverse-here ( seq -- ) : reverse-here ( seq -- )
[ length 2/ ] [ length ] [ ] tri [ length 2/ ] [ length ] [ ] tri
[ [ over - 1- ] dip exchange-unsafe ] 2curry each ; [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
: reverse ( seq -- newseq ) : reverse ( seq -- newseq )
[ [
@ -799,7 +799,7 @@ PRIVATE>
PRIVATE> PRIVATE>
: start* ( subseq seq n -- i ) : start* ( subseq seq n -- i )
pick length pick length swap - 1+ pick length pick length swap - 1 +
[ (start) ] find-from [ (start) ] find-from
swap [ 3drop ] dip ; swap [ 3drop ] dip ;

12
core/sorting/sorting.factor
View File

@ -29,13 +29,13 @@ TUPLE: merge
[ [ [ 2drop ] dip nth-unsafe ] dip push ] [ [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
pick 2 = [ pick 2 = [
[ [
[ 2drop dup 1+ ] dip [ 2drop dup 1 + ] dip
[ nth-unsafe ] curry bi@ [ nth-unsafe ] curry bi@
] dip [ push ] curry bi@ ] dip [ push ] curry bi@
] [ ] [
pick 3 = [ pick 3 = [
[ [
[ 2drop dup 1+ dup 1+ ] dip [ 2drop dup 1 + dup 1 + ] dip
[ nth-unsafe ] curry tri@ [ nth-unsafe ] curry tri@
] dip [ push ] curry tri@ ] dip [ push ] curry tri@
] [ [ nip subseq ] dip push-all ] if ] [ [ nip subseq ] dip push-all ] if
@ -57,10 +57,10 @@ TUPLE: merge
[ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
: l-next ( merge -- ) : 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-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 -- ? ) : decide ( merge -- ? )
[ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
@ -129,8 +129,8 @@ TUPLE: merge
while 2drop ; inline while 2drop ; inline
: each-pair ( seq quot -- ) : each-pair ( seq quot -- )
[ [ length 1+ 2/ ] keep ] dip [ [ length 1 + 2/ ] keep ] dip
[ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline
: (sort-pairs) ( i1 i2 seq quot accum -- ) : (sort-pairs) ( i1 i2 seq quot accum -- )
[ 2dup length = ] 2dip rot [ [ 2dup length = ] 2dip rot [

2
core/splitting/splitting.factor
View File

@ -55,7 +55,7 @@ PRIVATE>
: (split) ( separators n seq -- ) : (split) ( separators n seq -- )
3dup rot [ member? ] curry find-from drop 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 [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
: split, ( seq separators -- ) 0 rot (split) ; : split, ( seq separators -- ) 0 rot (split) ;

4
core/syntax/syntax-docs.factor
View File

@ -749,7 +749,7 @@ HELP: <PRIVATE
"<PRIVATE" "<PRIVATE"
"" ""
": (fac) ( accum n -- n! )" ": (fac) ( accum n -- n! )"
" dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;" " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
"" ""
"PRIVATE>" "PRIVATE>"
"" ""
@ -760,7 +760,7 @@ HELP: <PRIVATE
"IN: factorial.private" "IN: factorial.private"
"" ""
": (fac) ( accum n -- n! )" ": (fac) ( accum n -- n! )"
" dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;" " dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
"" ""
"IN: factorial" "IN: factorial"
"" ""

2
extra/contributors/contributors.factor
View File

@ -7,7 +7,7 @@ IN: contributors
: changelog ( -- authors ) : changelog ( -- authors )
image parent-directory [ image parent-directory [
"git log --pretty=format:%an" ascii <process-reader> lines "git log --pretty=format:%an" ascii <process-reader> stream-lines
] with-directory ; ] with-directory ;
: patch-counts ( authors -- assoc ) : patch-counts ( authors -- assoc )

4
extra/file-trees/file-trees-tests.factor Normal file
View File

@ -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

23
extra/file-trees/file-trees.factor Normal file
View File

@ -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 ;

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

@ -33,7 +33,7 @@ M: object handle-message drop ;
"--pretty=format:%h %an: %s" , "--pretty=format:%h %an: %s" ,
".." glue , ".." glue ,
] { } make ] { } make
latin1 [ input-stream get lines ] with-process-reader ; latin1 [ lines ] with-process-reader ;
: updates ( from to -- lines ) : updates ( from to -- lines )
git-log reverse git-log reverse

2
extra/mason/common/common.factor
View File

@ -16,7 +16,7 @@ M: output-process-error error.
: try-output-process ( command -- ) : try-output-process ( command -- )
>process +stdout+ >>stderr utf8 <process-reader*> >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 ; 0 = [ 2drop ] [ output-process-error ] if ;
HOOK: really-delete-tree os ( path -- ) HOOK: really-delete-tree os ( path -- )

18
extra/ui/frp/frp-docs.factor
View File

@ -1,36 +1,46 @@
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 IN: ui.frp
! Layout utilities ! Layout utilities
HELP: , HELP: ,
{ $values { "uiitem" "a gadget or model" } }
{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ; { $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
HELP: -> HELP: ->
{ $values { "uiitem" "a gadget or model" } { "model" model } }
{ $description "Like " { $link , } "but passes its model on for further use." } ; { $description "Like " { $link , } "but passes its model on for further use." } ;
HELP: <hbox> HELP: <hbox>
{ $values { "gadgets" "a list of gadgets" } { "track" track } }
{ $syntax "[ gadget , gadget , ... ] <hbox>" } { $syntax "[ gadget , gadget , ... ] <hbox>" }
{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ; { $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
HELP: <vbox> HELP: <vbox>
{ $values { "gadgets" "a list of gadgets" } { "track" track } }
{ $syntax "[ gadget , gadget , ... ] <hbox>" } { $syntax "[ gadget , gadget , ... ] <hbox>" }
{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ; { $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
! Gadgets ! Gadgets
HELP: <frp-button> HELP: <frp-button>
{ $values { "text" "the button's label" } { "button" button } }
{ $description "Creates an button whose model updates on clicks" } ; { $description "Creates an button whose model updates on clicks" } ;
HELP: <merge> 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> 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" } ; { $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
HELP: <fold> 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" } ; { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
HELP: switch 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" } ; { $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" ARTICLE: { "frp" "instances" } "FRP Instances"
"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. " "Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ; "Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;

9
extra/ui/frp/frp.factor
View File

@ -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-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
M: frp-table row-color color-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> ( model -- table )
frp-table new-line-gadget dup >>renderer swap >>quot swap >>model frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
f <model> >>selected-value sans-serif-font >>font f <model> >>selected-value sans-serif-font >>font
focus-border-color >>focus-border-color focus-border-color >>focus-border-color
transparent >>column-line-color ; transparent >>column-line-color ;
: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
: <frp-field> ( -- field ) f <model> <model-field> ; : <frp-field> ( -- field ) f <model> <model-field> ;
! Layout utilities ! Layout utilities
@ -27,11 +28,11 @@ GENERIC: output-model ( gadget -- model )
M: gadget output-model model>> ; M: gadget output-model model>> ;
M: frp-table output-model selected-value>> ; M: frp-table output-model selected-value>> ;
GENERIC: , ( object -- ) GENERIC: , ( uiitem -- )
M: gadget , make:, ; M: gadget , make:, ;
M: model , activate-model ; M: model , activate-model ;
GENERIC: -> ( object -- model ) GENERIC: -> ( uiitem -- model )
M: gadget -> dup make:, output-model ; M: gadget -> dup make:, output-model ;
M: model -> dup , ; M: model -> dup , ;
M: table -> dup , selected-value>> ; M: table -> dup , selected-value>> ;