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

db4
Doug Coleman 2008-04-11 19:56:21 -05:00
commit eb5d47a5eb
34 changed files with 304 additions and 266 deletions

View File

@ -21,12 +21,12 @@ HELP: graph
HELP: add-vertex
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
{ $description "Adds a vertex to a directed graph, using the " { $snippet "edges" } " quotation to generate a sequence of edges leaving the vertex." }
{ $description "Adds a vertex to a directed graph, with " { $snippet "edges" } " as the outward edges from the vertex." }
{ $side-effects "graph" } ;
HELP: remove-vertex
{ $values { "vertex" object } { "edges" "a sequence" } { "graph" "an assoc mapping vertices to sequences of edges" } }
{ $description "Removes a vertex from a graph, using the quotation to generate a sequence of edges leaving the vertex." }
{ $description "Removes a vertex from a graph, using the given edges sequence." }
{ $notes "The " { $snippet "edges" } " sequence must equal the value passed to " { $link add-vertex } ", otherwise some vertices of the graph may continue to refer to the removed vertex." }
{ $side-effects "graph" } ;

View File

@ -1,8 +1,9 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien io kernel namespaces core-foundation cocoa.messages
cocoa cocoa.classes cocoa.runtime sequences threads
debugger init inspector kernel.private ;
USING: alien io kernel namespaces core-foundation
core-foundation.run-loop cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads debugger init inspector
kernel.private ;
IN: cocoa.application
: <NSString> ( str -- alien ) <CFString> -> autorelease ;
@ -21,8 +22,6 @@ IN: cocoa.application
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ;
: CFRunLoopDefaultMode "kCFRunLoopDefaultMode" <NSString> ;
: next-event ( app -- event )
0 f CFRunLoopDefaultMode 1
-> nextEventMatchingMask:untilDate:inMode:dequeue: ;

View File

@ -9,9 +9,9 @@ TYPEDEF: void* CFBundleRef
TYPEDEF: void* CFStringRef
TYPEDEF: void* CFURLRef
TYPEDEF: void* CFUUIDRef
TYPEDEF: void* CFRunLoopRef
TYPEDEF: bool Boolean
TYPEDEF: int CFIndex
TYPEDEF: int SInt32
TYPEDEF: double CFTimeInterval
TYPEDEF: double CFAbsoluteTime
@ -85,5 +85,3 @@ FUNCTION: void CFRelease ( void* cf ) ;
] [
"Cannot load bundled named " prepend throw
] ?if ;
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;

View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax kernel math sequences
namespaces assocs init continuations core-foundation ;
namespaces assocs init accessors continuations combinators
core-foundation core-foundation.run-loop ;
IN: core-foundation.fsevents
! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! ! !
@ -182,11 +183,11 @@ SYMBOL: event-stream-callbacks
}
"cdecl" [
[ >event-triple ] 3curry map
swap event-stream-callbacks get at call
drop
swap event-stream-callbacks get at
dup [ call drop ] [ 3drop ] if
] alien-callback ;
TUPLE: event-stream info handle ;
TUPLE: event-stream info handle closed ;
: <event-stream> ( quot paths latency flags -- event-stream )
>r >r >r
@ -194,9 +195,15 @@ TUPLE: event-stream info handle ;
>r master-event-source-callback r>
r> r> r> <FSEventStream>
dup enable-event-stream
event-stream construct-boa ;
f event-stream construct-boa ;
M: event-stream dispose
dup event-stream-info remove-event-source-callback
event-stream-handle dup disable-event-stream
FSEventStreamRelease ;
dup closed>> [ drop ] [
t >>closed
{
[ info>> remove-event-source-callback ]
[ handle>> disable-event-stream ]
[ handle>> FSEventStreamInvalidate ]
[ handle>> FSEventStreamRelease ]
} cleave
] if ;

View File

@ -0,0 +1,38 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax kernel threads init namespaces alien
core-foundation ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
: kCFRunLoopRunStopped 2 ; inline
: kCFRunLoopRunTimedOut 3 ; inline
: kCFRunLoopRunHandledSource 4 ; inline
TYPEDEF: void* CFRunLoopRef
FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: SInt32 CFRunLoopRunInMode (
CFStringRef mode,
CFTimeInterval seconds,
Boolean returnAfterSourceHandled
) ;
: CFRunLoopDefaultMode ( -- alien )
#! Ugly, but we don't have static NSStrings
\ CFRunLoopDefaultMode get-global dup expired? [
drop
"kCFRunLoopDefaultMode" <CFString>
dup \ CFRunLoopDefaultMode set-global
] when ;
: run-loop-thread ( -- )
CFRunLoopDefaultMode 0 f CFRunLoopRunInMode
kCFRunLoopRunHandledSource = [ 1000 sleep ] unless
run-loop-thread ;
: start-run-loop-thread ( -- )
[ run-loop-thread t ] "CFRunLoop dispatcher" spawn-server drop ;
[ start-run-loop-thread ] "core-foundation.run-loop" add-init-hook

View File

@ -199,7 +199,7 @@ ARTICLE: "cookbook-io" "Input and output cookbook"
}
"Convert a file of 4-byte cells from little to big endian or vice versa, by directly mapping it into memory and operating on it with sequence words:"
{ $code
"\"mydata.dat\" dup file-info file-info-length ["
"\"mydata.dat\" dup file-info size>> ["
" 4 <sliced-groups> [ reverse-here ] change-each"
"] with-mapped-file"
}

View File

@ -10,7 +10,7 @@ IN: http.server.static
TUPLE: file-responder root hook special ;
: file-http-date ( filename -- string )
file-info file-info-modified timestamp>http-string ;
file-info modified>> timestamp>http-string ;
: last-modified-matches? ( filename -- ? )
file-http-date dup [
@ -27,7 +27,7 @@ TUPLE: file-responder root hook special ;
[
<content>
swap
[ file-info file-info-size "content-length" set-header ]
[ file-info size>> "content-length" set-header ]
[ file-http-date "last-modified" set-header ]
[ '[ , binary <file-reader> stdio get stream-copy ] >>body ]
tri

View File

@ -1,5 +1,5 @@
USING: inverse tools.test arrays math kernel sequences
math.functions math.constants ;
math.functions math.constants continuations ;
IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
@ -51,7 +51,7 @@ C: <nil> nil
{
{ [ <cons> ] [ list-sum + ] }
{ [ <nil> ] [ 0 ] }
{ [ ] [ "Malformed list" throw ] }
[ "Malformed list" throw ]
} switch ;
[ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
@ -59,6 +59,7 @@ C: <nil> nil
[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
[ "Malformed list" ] [ [ f list-sum ] [ ] recover ] unit-test
: empty-cons ( -- cons ) cons construct-empty ;
: cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
@ -68,3 +69,4 @@ C: <nil> nil
[ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
[ ] [ 3 [ _ ] undo ] unit-test

View File

@ -60,11 +60,13 @@ PREDICATE: math-inverse < word "math-inverse" word-prop ;
PREDICATE: pop-inverse < word "pop-length" word-prop ;
UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
: enough? ( stack quot -- ? )
[ >r length r> 1quotation infer effect-in >= ] [ 3drop f ]
recover ;
: enough? ( stack word -- ? )
dup deferred? [ 2drop f ] [
[ >r length r> 1quotation infer effect-in >= ]
[ 3drop f ] recover
] if ;
: fold-word ( stack quot -- stack )
: fold-word ( stack word -- stack )
2dup enough?
[ 1quotation with-datastack ] [ >r % r> , { } ] if ;
@ -72,10 +74,10 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
[ { } swap [ fold-word ] each % ] [ ] make ;
: flattenable? ( object -- ? )
[ [ word? ] [ primitive? not ] and? ] [
{ [ word? ] [ primitive? not ] [
{ "inverse" "math-inverse" "pop-inverse" }
[ word-prop ] with contains? not
] and? ;
] } <-&& ;
: (flatten) ( quot -- )
[ dup flattenable? [ word-def (flatten) ] [ , ] if ] each ;
@ -159,7 +161,7 @@ MACRO: undo ( quot -- ) [undo] ;
2curry
] define-pop-inverse
: _ f ;
DEFER: _
\ _ [ drop ] define-inverse
: both ( object object -- object )
@ -256,6 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
[ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
: [switch] ( quot-alist -- quot )
[ dup quotation? [ [ ] swap 2array ] when ] map
reverse [ >r [undo] r> compose ] { } assoc>map
recover-chain ;

View File

@ -29,9 +29,10 @@ IN: io.encodings.8-bit
{ "mac-roman" "ROMAN" }
} ;
: full-path ( file-name -- path )
: encoding-file ( file-name -- stream )
"extra/io/encodings/8-bit/" ".TXT"
swapd 3append resource-path ;
swapd 3append resource-path
ascii <file-reader> ;
: tail-if ( seq n -- newseq )
2dup swap length <= [ tail ] [ drop ] if ;
@ -48,8 +49,8 @@ IN: io.encodings.8-bit
: ch>byte ( assoc -- newassoc )
[ swap ] assoc-map >hashtable ;
: parse-file ( file-name -- byte>ch ch>byte )
ascii file-lines process-contents
: parse-file ( path -- byte>ch ch>byte )
lines process-contents
[ byte>ch ] [ ch>byte ] bi ;
TUPLE: 8-bit name decode encode ;
@ -71,13 +72,13 @@ M: 8-bit decode-char
: make-8-bit ( word byte>ch ch>byte -- )
[ 8-bit construct-boa ] 2curry dupd curry define ;
: define-8-bit-encoding ( name path -- )
: define-8-bit-encoding ( name stream -- )
>r in get create r> parse-file make-8-bit ;
PRIVATE>
[
"io.encodings.8-bit" in [
mappings [ full-path define-8-bit-encoding ] assoc-each
mappings [ encoding-file define-8-bit-encoding ] assoc-each
] with-variable
] with-compilation-unit

View File

@ -129,9 +129,6 @@ HELP: <process>
{ $values { "process" process } }
{ $description "Creates a new, empty process. It must be filled in before being passed to " { $link run-process } "." } ;
HELP: process-stream
{ $class-description "A bidirectional stream for interacting with a running process. Instances are created by calling " { $link <process-stream> } ". The " { $link process-stream-process } " slot holds a " { $link process } " instance." } ;
HELP: <process-stream>
{ $values
{ "desc" "a launch descriptor" }
@ -144,7 +141,7 @@ HELP: with-process-stream
{ "desc" "a launch descriptor" }
{ "quot" quotation }
{ "status" "an exit code" } }
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a process stream. After the quotation returns, waits for the process to end and outputs the exit code." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }

View File

@ -150,18 +150,18 @@ M: process timed-out kill-process ;
HOOK: (process-stream) io-backend ( process -- handle in out )
TUPLE: process-stream process ;
: <process-stream*> ( desc encoding -- stream process )
>r >process dup dup (process-stream) <reader&writer>
r> <encoder-duplex> -roll
process-started ;
: <process-stream> ( desc encoding -- stream )
>r >process dup dup (process-stream)
>r >r process-started process-stream construct-boa
r> r> <reader&writer> r> <encoder-duplex>
over set-delegate ;
<process-stream*> drop ; inline
: with-process-stream ( desc quot -- status )
swap <process-stream>
swap <process-stream*> >r
[ swap with-stream ] keep
process>> wait-for-process ; inline
r> wait-for-process ; inline
: notify-exit ( process status -- )
>>status

View File

@ -1,10 +1,10 @@
USING: io io.mmap io.files kernel tools.test continuations
sequences io.encodings.ascii ;
sequences io.encodings.ascii accessors ;
IN: io.mmap.tests
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors
[ ] [ "12345" "mmap-test-file.txt" resource-path ascii set-file-contents ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info file-info-size [ length ] with-mapped-file ] unit-test
[ ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ CHAR: 2 0 pick set-nth drop ] with-mapped-file ] unit-test
[ 5 ] [ "mmap-test-file.txt" resource-path dup file-info size>> [ length ] with-mapped-file ] unit-test
[ "22345" ] [ "mmap-test-file.txt" resource-path ascii file-contents ] unit-test
[ "mmap-test-file.txt" resource-path delete-file ] ignore-errors

View File

@ -75,13 +75,13 @@ os { winnt linux macosx } member? [
[ ] [ "monitor-test/xyz/test.txt" temp-file touch-file ] unit-test
[ ] [ "c1" get 5 seconds await-timeout ] unit-test
[ ] [ "c1" get 15 seconds await-timeout ] unit-test
[ ] [ "monitor-test/subdir/blah/yxy" temp-file make-directories ] unit-test
[ ] [ "monitor-test/subdir/blah/yxy/test.txt" temp-file touch-file ] unit-test
[ ] [ "c2" get 5 seconds await-timeout ] unit-test
[ ] [ "c2" get 15 seconds await-timeout ] unit-test
! Dispose twice
[ ] [ "m" get dispose ] unit-test

View File

@ -36,10 +36,10 @@ HELP: port
$nl
"Ports have the following slots:"
{ $list
{ { $link port-handle } " - a native handle identifying the underlying native resource used by the port" }
{ { $link port-error } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
{ { $link port-type } " - a symbol identifying the port's intended purpose" }
{ { $link port-eof? } " - a flag indicating if the port has reached the end of file while reading" }
{ { $snippet "handle" } " - a native handle identifying the underlying native resource used by the port" }
{ { $snippet "error" } " - the most recent I/O error, if any. This error is thrown to the waiting thread when " { $link pending-error } " is called by stream operations" }
{ { $snippet "type" } " - a symbol identifying the port's intended purpose" }
{ { $snippet "eof" } " - a flag indicating if the port has reached the end of file while reading" }
} } ;
HELP: input-port
@ -53,8 +53,8 @@ HELP: init-handle
{ $contract "Prepares a native handle for use by the port; called by " { $link <port> } "." } ;
HELP: <port>
{ $values { "handle" "a native handle identifying an I/O resource" } { "buffer" "a " { $link buffer } " or " { $link f } } { "type" symbol } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " using the specified native handle and I/O buffer." }
{ $values { "handle" "a native handle identifying an I/O resource" } { "type" symbol } { "port" "a new " { $link port } } }
{ $description "Creates a new " { $link port } " with no buffer." }
$low-level-note ;
HELP: <buffered-port>

View File

@ -1,46 +1,39 @@
! Copyright (C) 2005, 2008 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
IN: io.nonblocking
USING: math kernel io sequences io.buffers io.timeouts generic
byte-vectors system io.streams.duplex io.encodings
io.backend continuations debugger classes byte-arrays namespaces
splitting dlists assocs io.encodings.binary ;
splitting dlists assocs io.encodings.binary accessors ;
IN: io.nonblocking
SYMBOL: default-buffer-size
64 1024 * default-buffer-size set-global
! Common delegate of native stream readers and writers
TUPLE: port
handle
error
timeout
type eof? ;
TUPLE: port handle buffer error timeout closed eof ;
M: port timeout port-timeout ;
M: port timeout timeout>> ;
M: port set-timeout set-port-timeout ;
SYMBOL: closed
PREDICATE: input-port < port port-type input-port eq? ;
PREDICATE: output-port < port port-type output-port eq? ;
M: port set-timeout (>>timeout) ;
GENERIC: init-handle ( handle -- )
GENERIC: close-handle ( handle -- )
: <port> ( handle buffer type -- port )
pick init-handle {
set-port-handle
set-delegate
set-port-type
} port construct ;
: <port> ( handle class -- port )
construct-empty
swap dup init-handle >>handle ; inline
: <buffered-port> ( handle type -- port )
default-buffer-size get <buffer> swap <port> ;
: <buffered-port> ( handle class -- port )
<port>
default-buffer-size get <buffer> >>buffer ; inline
TUPLE: input-port < port ;
: <reader> ( handle -- input-port )
input-port <buffered-port> ;
TUPLE: output-port < port ;
: <writer> ( handle -- output-port )
output-port <buffered-port> ;
@ -48,7 +41,10 @@ GENERIC: close-handle ( handle -- )
swap <reader> [ swap <writer> ] [ ] [ dispose drop ] cleanup ;
: pending-error ( port -- )
dup port-error f rot set-port-error [ throw ] when* ;
[ f ] change-error drop [ throw ] when* ;
: check-closed ( port -- port )
dup closed>> [ "Port closed" throw ] when ;
HOOK: cancel-io io-backend ( port -- )
@ -59,21 +55,22 @@ M: port timed-out cancel-io ;
GENERIC: (wait-to-read) ( port -- )
: wait-to-read ( count port -- )
tuck buffer-length > [ (wait-to-read) ] [ drop ] if ;
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
: wait-to-read1 ( port -- )
1 swap wait-to-read ;
: unless-eof ( port quot -- value )
>r dup buffer-empty? over port-eof? and
[ f swap set-port-eof? f ] r> if ; inline
>r dup buffer>> buffer-empty? over eof>> and
[ f >>eof drop f ] r> if ; inline
M: input-port stream-read1
dup wait-to-read1 [ buffer-pop ] unless-eof ;
check-closed
dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
: read-step ( count port -- byte-array/f )
[ wait-to-read ] 2keep
[ dupd buffer-read ] unless-eof nip ;
[ dupd buffer>> buffer-read ] unless-eof nip ;
: read-loop ( count port accum -- )
pick over length - dup 0 > [
@ -87,6 +84,7 @@ M: input-port stream-read1
] if ;
M: input-port stream-read
check-closed
>r 0 max >fixnum r>
2dup read-step dup [
pick over length > [
@ -94,72 +92,75 @@ M: input-port stream-read
[ push-all ] keep
[ read-loop ] keep
B{ } like
] [
2nip
] if
] [
2nip
] if ;
] [ 2nip ] if
] [ 2nip ] if ;
M: input-port stream-read-partial ( max stream -- byte-array/f )
check-closed
>r 0 max >fixnum r> read-step ;
: can-write? ( len writer -- ? )
: can-write? ( len buffer -- ? )
[ buffer-fill + ] keep buffer-capacity <= ;
: wait-to-write ( len port -- )
tuck can-write? [ drop ] [ stream-flush ] if ;
tuck buffer>> can-write? [ drop ] [ stream-flush ] if ;
M: output-port stream-write1
1 over wait-to-write byte>buffer ;
check-closed
1 over wait-to-write
buffer>> byte>buffer ;
M: output-port stream-write
over length over buffer-size > [
[ buffer-size <groups> ] keep
[ stream-write ] curry each
check-closed
over length over buffer>> buffer-size > [
[ buffer>> buffer-size <groups> ]
[ [ stream-write ] curry ] bi
each
] [
over length over wait-to-write >buffer
[ >r length r> wait-to-write ]
[ buffer>> >buffer ] 2bi
] if ;
GENERIC: port-flush ( port -- )
M: output-port stream-flush ( port -- )
dup port-flush pending-error ;
check-closed
[ port-flush ] [ pending-error ] bi ;
: close-port ( port type -- )
output-port eq? [ dup port-flush ] when
GENERIC: close-port ( port -- )
M: output-port close-port
[ port-flush ] [ call-next-method ] bi ;
M: port close-port
dup cancel-io
dup port-handle close-handle
dup delegate [ buffer-free ] when*
f swap set-delegate ;
dup handle>> close-handle
[ [ buffer-free ] when* f ] change-buffer drop ;
M: port dispose
dup port-type closed eq?
[ drop ]
[ dup port-type >r closed over set-port-type r> close-port ]
if ;
dup closed>> [ drop ] [ t >>closed close-port ] if ;
TUPLE: server-port addr client client-addr encoding ;
TUPLE: server-port < port addr client client-addr encoding ;
: <server-port> ( handle addr encoding -- server )
rot f server-port <port>
{ set-server-port-addr set-server-port-encoding set-delegate }
server-port construct ;
rot server-port <port>
swap >>encoding
swap >>addr ;
: check-server-port ( port -- )
port-type server-port assert= ;
: check-server-port ( port -- port )
dup server-port? [ "Not a server port" throw ] unless ; inline
TUPLE: datagram-port addr packet packet-addr ;
TUPLE: datagram-port < port addr packet packet-addr ;
: <datagram-port> ( handle addr -- datagram )
>r f datagram-port <port> r>
{ set-delegate set-datagram-port-addr }
datagram-port construct ;
swap datagram-port <port>
swap >>addr ;
: check-datagram-port ( port -- )
port-type datagram-port assert= ;
: check-datagram-port ( port -- port )
check-closed
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
: check-datagram-send ( packet addrspec port -- )
dup check-datagram-port
datagram-port-addr [ class ] bi@ assert=
class byte-array assert= ;
: check-datagram-send ( packet addrspec port -- packet addrspec port )
check-datagram-port
2dup addr>> [ class ] bi@ assert=
pick class byte-array assert= ;

View File

@ -12,17 +12,17 @@ SYMBOL: servers
LOG: accepted-connection NOTICE
: with-client ( client quot -- )
: with-client ( client addrspec quot -- )
[
over client-stream-addr accepted-connection
swap accepted-connection
with-stream*
] curry with-disposal ; inline
] 2curry with-disposal ; inline
\ with-client DEBUG add-error-logging
: accept-loop ( server quot -- )
[
>r accept r> [ with-client ] 2curry "Client" spawn drop
>r accept r> [ with-client ] 3curry "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )

View File

@ -17,8 +17,6 @@ ARTICLE: "network-connection" "Connection-oriented networking"
"Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
{ $subsection <server> }
{ $subsection accept }
"The stream returned by " { $link accept } " holds the address specifier of the remote client:"
{ $subsection client-stream-addr }
"Server sockets are closed by calling " { $link dispose } "."
$nl
"Address specifiers have the following interpretation with connection-oriented networking words:"
@ -118,10 +116,8 @@ HELP: <server>
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
HELP: accept
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } }
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor."
$nl
"The returned client stream responds to the " { $link client-stream-addr } " word with the address of the incoming connection." }
{ $values { "server" "a handle" } { "client" "a bidirectional stream" } { "addrspec" "an address specifier" } }
{ $description "Waits for a connection to a server socket created by " { $link <server> } ", and outputs a bidirectional stream when the connection has been established. The encoding of this stream is the one that was passed to the server constructor." }
{ $errors "Throws an error if the server socket is closed or otherwise is unavailable." } ;
HELP: <datagram>

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: generic kernel io.backend namespaces continuations
sequences arrays io.encodings io.nonblocking ;
sequences arrays io.encodings io.nonblocking accessors ;
IN: io.sockets
TUPLE: local path ;
@ -21,20 +21,14 @@ TUPLE: inet host port ;
C: <inet> inet
TUPLE: client-stream addr ;
HOOK: ((client)) io-backend ( addrspec -- client-in client-out )
: <client-stream> ( addrspec delegate -- stream )
{ set-client-stream-addr set-delegate }
client-stream construct ;
HOOK: (client) io-backend ( addrspec -- client-in client-out )
GENERIC: client* ( addrspec -- client-in client-out )
M: array client* [ (client) 2array ] attempt-all first2 ;
M: object client* (client) ;
GENERIC: (client) ( addrspec -- client-in client-out )
M: array (client) [ ((client)) 2array ] attempt-all first2 ;
M: object (client) ((client)) ;
: <client> ( addrspec encoding -- stream )
>r client* r> <encoder-duplex> ;
>r (client) r> <encoder-duplex> ;
HOOK: (server) io-backend ( addrspec -- handle )
@ -43,10 +37,9 @@ HOOK: (server) io-backend ( addrspec -- handle )
HOOK: (accept) io-backend ( server -- addrspec handle )
: accept ( server -- client )
[ (accept) dup <reader&writer> ] keep
server-port-encoding <encoder-duplex>
<client-stream> ;
: accept ( server -- client addrspec )
[ (accept) dup <reader&writer> ] [ encoding>> ] bi
<encoder-duplex> swap ;
HOOK: <datagram> io-backend ( addrspec -- datagram )
@ -58,7 +51,8 @@ HOOK: resolve-host io-backend ( host serv passive? -- seq )
HOOK: host-name io-backend ( -- string )
M: inet client*
dup inet-host swap inet-port f resolve-host
dup empty? [ "Host name lookup failed" throw ] when
client* ;
M: inet (client)
[ host>> ] [ port>> ] bi f resolve-host
[ empty? [ "Host name lookup failed" throw ] when ]
[ (client) ]
bi ;

View File

@ -14,18 +14,13 @@ TUPLE: io-task port callbacks ;
: io-task-fd port>> handle>> ;
: <io-task> ( port continuation/f class -- task )
>r [ 1vector ] [ V{ } clone ] if* io-task construct-boa
r> construct-delegate ; inline
construct-empty
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
swap >>port ; inline
TUPLE: input-task ;
TUPLE: input-task < io-task ;
: <input-task> ( port continuation class -- task )
>r input-task <io-task> r> construct-delegate ; inline
TUPLE: output-task ;
: <output-task> ( port continuation class -- task )
>r output-task <io-task> r> construct-delegate ; inline
TUPLE: output-task < io-task ;
GENERIC: do-io-task ( task -- ? )
GENERIC: io-task-container ( mx task -- hashtable )
@ -37,9 +32,10 @@ M: input-task io-task-container drop reads>> ;
M: output-task io-task-container drop writes>> ;
: <mx> ( -- mx ) f H{ } clone H{ } clone mx construct-boa ;
: construct-mx ( class -- obj ) <mx> swap construct-delegate ;
: construct-mx ( class -- obj )
construct-empty
H{ } clone >>reads
H{ } clone >>writes ; inline
GENERIC: register-io-task ( task mx -- )
GENERIC: unregister-io-task ( task mx -- )
@ -123,16 +119,18 @@ M: unix cancel-io ( port -- )
! Readers
: reader-eof ( reader -- )
dup buffer-empty? [ t >>eof? ] when drop ;
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
: (refill) ( port -- n )
[ handle>> ] [ buffer-end ] [ buffer-capacity ] tri read ;
[ handle>> ]
[ buffer>> buffer-end ]
[ buffer>> buffer-capacity ] tri read ;
: refill ( port -- ? )
#! Return f if there is a recoverable error
dup buffer-empty? [
dup buffer>> buffer-empty? [
dup (refill) dup 0 >= [
swap n>buffer t
swap buffer>> n>buffer t
] [
drop defer-error
] if
@ -140,10 +138,10 @@ M: unix cancel-io ( port -- )
drop t
] if ;
TUPLE: read-task ;
TUPLE: read-task < input-task ;
: <read-task> ( port continuation -- task )
read-task <input-task> ;
read-task <io-task> ;
M: read-task do-io-task
io-task-port dup refill
@ -155,28 +153,33 @@ M: input-port (wait-to-read)
! Writers
: write-step ( port -- ? )
dup [ handle>> ] [ buffer@ ] [ buffer-length ] tri write
dup 0 >= [ swap buffer-consume f ] [ drop defer-error ] if ;
dup
[ handle>> ]
[ buffer>> buffer@ ]
[ buffer>> buffer-length ] tri
write dup 0 >=
[ swap buffer>> buffer-consume f ]
[ drop defer-error ] if ;
TUPLE: write-task ;
TUPLE: write-task < output-task ;
: <write-task> ( port continuation -- task )
write-task <output-task> ;
write-task <io-task> ;
M: write-task do-io-task
io-task-port dup [ buffer-empty? ] [ port-error ] bi or
[ 0 swap buffer-reset t ] [ write-step ] if ;
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
[ 0 swap buffer>> buffer-reset t ] [ write-step ] if ;
: add-write-io-task ( port continuation -- )
over port-handle mx get-global mx-writes at*
over handle>> mx get-global writes>> at*
[ io-task-callbacks push drop ]
[ drop <write-task> add-io-task ] if ;
: (wait-to-write) ( port -- )
[ add-write-io-task ] with-port-continuation drop ;
M: port port-flush ( port -- )
dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: output-port port-flush ( port -- )
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
M: unix io-multiplex ( ms/f -- )
mx get-global wait-for-events ;
@ -187,13 +190,12 @@ M: unix (init-stdio) ( -- )
2 <writer> ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port mx ;
TUPLE: mx-port < port mx ;
: <mx-port> ( mx -- port )
dup fd>> f mx-port <port>
{ set-mx-port-mx set-delegate } mx-port construct ;
dup fd>> mx-port <port> swap >>mx ;
TUPLE: mx-task ;
TUPLE: mx-task < io-task ;
: <mx-task> ( port -- task )
f mx-task <io-task> ;

View File

@ -5,7 +5,7 @@ bit-arrays sequences assocs unix unix.linux.epoll math
namespaces structs ;
IN: io.unix.epoll
TUPLE: epoll-mx events ;
TUPLE: epoll-mx < mx events ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
@ -33,12 +33,10 @@ M: output-task io-task-events drop EPOLLOUT ;
epoll_ctl io-error ;
M: epoll-mx register-io-task ( task mx -- )
2dup EPOLL_CTL_ADD do-epoll-ctl
delegate register-io-task ;
[ EPOLL_CTL_ADD do-epoll-ctl ] [ call-next-method ] 2bi ;
M: epoll-mx unregister-io-task ( task mx -- )
2dup delegate unregister-io-task
EPOLL_CTL_DEL do-epoll-ctl ;
[ call-next-method ] [ EPOLL_CTL_DEL do-epoll-ctl ] 2bi ;
: wait-event ( mx timeout -- n )
>r { mx-fd epoll-mx-events } get-slots max-events

View File

@ -72,7 +72,7 @@ M: unix delete-directory ( path -- )
M: unix copy-file ( from to -- )
[ normalize-path ] bi@
[ (copy-file) ]
[ swap file-info file-info-permissions chmod io-error ]
[ swap file-info permissions>> chmod io-error ]
2bi ;
: stat>type ( stat -- type )

View File

@ -8,7 +8,7 @@ io.nonblocking io.unix.backend io.launcher io.unix.launcher
io.monitors ;
IN: io.unix.kqueue
TUPLE: kqueue-mx events monitors ;
TUPLE: kqueue-mx < mx events monitors ;
: max-events ( -- n )
#! We read up to 256 events at a time. This is an arbitrary
@ -43,12 +43,14 @@ M: io-task io-task-fflags drop 0 ;
0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
M: kqueue-mx register-io-task ( task mx -- )
over EV_ADD make-kevent over register-kevent
delegate register-io-task ;
[ >r EV_ADD make-kevent r> register-kevent ]
[ call-next-method ]
2bi ;
M: kqueue-mx unregister-io-task ( task mx -- )
2dup delegate unregister-io-task
swap EV_DELETE make-kevent swap register-kevent ;
[ call-next-method ]
[ >r EV_DELETE make-kevent r> register-kevent ]
2bi ;
: wait-kevent ( mx timespec -- n )
>r [ fd>> f 0 ] keep events>> max-events r> kevent

View File

@ -103,8 +103,8 @@ M: linux-monitor dispose ( monitor -- )
: inotify-read-loop ( port -- )
dup wait-to-read1
0 over parse-file-notifications
0 over buffer-reset
0 over buffer>> parse-file-notifications
0 over buffer>> buffer-reset
inotify-read-loop ;
: inotify-read-thread ( port -- )

View File

@ -5,7 +5,7 @@ bit-arrays sequences assocs unix math namespaces structs
accessors ;
IN: io.unix.select
TUPLE: select-mx read-fdset write-fdset ;
TUPLE: select-mx < mx read-fdset write-fdset ;
! Factor's bit-arrays are an array of bytes, OS X expects
! FD_SET to be an array of cells, so we have to account for

View File

@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
io.nonblocking parser threads unix sequences
byte-arrays io.sockets io.binary io.unix.backend
io.streams.duplex io.sockets.impl math.parser continuations libc
combinators io.backend io.files io.files.private system ;
combinators io.backend io.files io.files.private system accessors ;
IN: io.unix.sockets
: pending-init-error ( port -- )
@ -30,10 +30,10 @@ M: unix addrinfo-error ( n -- )
: init-client-socket ( fd -- )
SOL_SOCKET SO_OOBINLINE sockopt ;
TUPLE: connect-task ;
TUPLE: connect-task < output-task ;
: <connect-task> ( port continuation -- task )
connect-task <output-task> ;
connect-task <io-task> ;
M: connect-task do-io-task
io-task-port dup port-handle f 0 write
@ -42,7 +42,7 @@ M: connect-task do-io-task
: wait-to-connect ( port -- )
[ <connect-task> add-io-task ] with-port-continuation drop ;
M: unix (client) ( addrspec -- client-in client-out )
M: unix ((client)) ( addrspec -- client-in client-out )
dup make-sockaddr/size >r >r
protocol-family SOCK_STREAM socket-fd
dup r> r> connect
@ -61,10 +61,10 @@ USE: unix
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR sockopt ;
TUPLE: accept-task ;
TUPLE: accept-task < input-task ;
: <accept-task> ( port continuation -- task )
accept-task <input-task> ;
accept-task <io-task> ;
: accept-sockaddr ( port -- fd sockaddr )
dup port-handle swap server-port-addr sockaddr-type
@ -97,11 +97,10 @@ M: unix (server) ( addrspec -- handle )
M: unix (accept) ( server -- addrspec handle )
#! Wait for a client connection.
dup check-server-port
dup wait-to-accept
dup pending-error
dup server-port-client-addr
swap server-port-client ;
check-server-port
[ wait-to-accept ]
[ pending-error ]
[ [ client-addr>> ] [ client>> ] bi ] tri ;
! Datagram sockets - UDP and Unix domain
M: unix <datagram>
@ -128,10 +127,10 @@ packet-size <byte-array> receive-buffer set-global
rot head
] if ;
TUPLE: receive-task ;
TUPLE: receive-task < input-task ;
: <receive-task> ( stream continuation -- task )
receive-task <input-task> ;
receive-task <io-task> ;
M: receive-task do-io-task
io-task-port
@ -148,19 +147,18 @@ M: receive-task do-io-task
[ <receive-task> add-io-task ] with-port-continuation drop ;
M: unix receive ( datagram -- packet addrspec )
dup check-datagram-port
dup wait-receive
dup pending-error
dup datagram-port-packet
swap datagram-port-packet-addr ;
check-datagram-port
[ wait-receive ]
[ pending-error ]
[ [ packet>> ] [ packet-addr>> ] bi ] tri ;
: do-send ( socket data sockaddr len -- n )
>r >r dup length 0 r> r> sendto ;
TUPLE: send-task packet sockaddr len ;
TUPLE: send-task < output-task packet sockaddr len ;
: <send-task> ( packet sockaddr len stream continuation -- task )
send-task <output-task> [
send-task <io-task> [
{
set-send-task-packet
set-send-task-sockaddr
@ -180,7 +178,7 @@ M: send-task do-io-task
2drop 2drop ;
M: unix send ( packet addrspec datagram -- )
3dup check-datagram-send
check-datagram-send
[ >r make-sockaddr/size r> wait-send ] keep
pending-error ;

View File

@ -11,7 +11,7 @@ IN: io.unix.tests
socket-server <local>
ascii <server> [
accept [
accept drop [
"Hello world" print flush
readln "XYZ" = "FOO" "BAR" ? print flush
] with-stream

View File

@ -64,7 +64,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
dup pending-error
tuck get-overlapped-result
dup pick update-file-ptr
swap buffer-consume ;
swap buffer>> buffer-consume ;
: (flush-output) ( port -- )
dup make-FileArgs
@ -73,7 +73,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
>r FileArgs-lpOverlapped r>
[ save-callback ] 2keep
[ finish-flush ] keep
dup buffer-empty? [ drop ] [ (flush-output) ] if
dup buffer>> buffer-empty? [ drop ] [ (flush-output) ] if
] [
2drop
] if ;
@ -82,7 +82,7 @@ M: winnt FileArgs-overlapped ( port -- overlapped )
[ [ (flush-output) ] with-timeout ] with-destructors ;
M: port port-flush
dup buffer-empty? [ dup flush-output ] unless drop ;
dup buffer>> buffer-empty? [ dup flush-output ] unless drop ;
: finish-read ( overlapped port -- )
dup pending-error

View File

@ -37,10 +37,12 @@ M: winnt <monitor> ( path recursive? -- monitor )
] with-destructors ;
: begin-reading-changes ( monitor -- overlapped )
dup port-handle win32-file-handle
over buffer-ptr
pick buffer-size
roll win32-monitor-recursive? 1 0 ?
{
[ handle>> handle>> ]
[ buffer>> buffer-ptr ]
[ buffer>> buffer-size ]
[ win32-monitor-recursive? 1 0 ? ]
} cleave
FILE_NOTIFY_CHANGE_ALL
0 <uint>
(make-overlapped)
@ -82,6 +84,6 @@ M: winnt <monitor> ( path recursive? -- monitor )
[ 2drop ] [ swap <displaced-alien> (changed-files) ] if ;
M: win32-monitor fill-queue ( monitor -- )
dup buffer-ptr over read-changes
dup buffer>> buffer-ptr over read-changes
[ zero? [ drop ] [ (changed-files) ] if ] H{ } make-assoc
swap set-monitor-queue ;

View File

@ -122,7 +122,7 @@ TUPLE: AcceptEx-args port
M: winnt (accept) ( server -- addrspec handle )
[
[
dup check-server-port
check-server-port
\ AcceptEx-args construct-empty
[ init-accept ] keep
[ ((accept)) ] keep
@ -159,7 +159,7 @@ TUPLE: WSARecvFrom-args port
: init-WSARecvFrom ( datagram WSARecvFrom -- )
[ set-WSARecvFrom-args-port ] 2keep
[
>r delegate port-handle delegate win32-file-handle r>
>r handle>> handle>> r>
set-WSARecvFrom-args-s*
] 2keep [
>r datagram-port-addr sockaddr-type heap-size r>
@ -192,7 +192,7 @@ TUPLE: WSARecvFrom-args port
M: winnt receive ( datagram -- packet addrspec )
[
dup check-datagram-port
check-datagram-port
\ WSARecvFrom-args construct-empty
[ init-WSARecvFrom ] keep
[ call-WSARecvFrom ] keep
@ -244,7 +244,7 @@ USE: io.sockets
M: winnt send ( packet addrspec datagram -- )
[
3dup check-datagram-send
check-datagram-send
\ WSASendTo-args construct-empty
[ init-WSASendTo ] keep
[ call-WSASendTo ] keep

View File

@ -92,7 +92,7 @@ M: win32-file close-handle ( handle -- )
] when drop ;
: open-append ( path -- handle length )
[ dup file-info file-info-size ] [ drop 0 ] recover
[ dup file-info size>> ] [ drop 0 ] recover
>r (open-append) r> 2dup set-file-pointer ;
TUPLE: FileArgs
@ -103,9 +103,9 @@ C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
[ port-handle win32-file-handle ] keep
[ delegate ] keep
[ buffer>> ] keep
[
buffer-length
buffer>> buffer-length
"DWORD" <c-object>
] keep FileArgs-overlapped <FileArgs> ;
@ -152,11 +152,10 @@ M: windows delete-directory ( path -- )
HOOK: WSASocket-flags io-backend ( -- DWORD )
TUPLE: win32-socket ;
TUPLE: win32-socket < win32-file ;
: <win32-socket> ( handle -- win32-socket )
f <win32-file>
\ win32-socket construct-delegate ;
f win32-file construct-boa ;
: open-socket ( family type -- socket )
0 f 0 WSASocket-flags WSASocket dup socket-error ;

View File

@ -22,9 +22,8 @@ IN: tools.deploy.backend
+stdout+ >>stderr
+closed+ >>stdin
+low-priority+ >>priority
utf8 <process-stream>
dup copy-lines
process>> wait-for-process zero? [
utf8 <process-stream*>
>r copy-lines r> wait-for-process zero? [
"Deployment failed" throw
] unless ;

View File

@ -1,7 +1,7 @@
IN: tools.deploy.tests
USING: tools.test system io.files kernel tools.deploy.config
tools.deploy.backend math sequences io.launcher arrays
namespaces continuations layouts ;
namespaces continuations layouts accessors ;
: shake-and-bake ( vocab -- )
[ "test.image" temp-file delete-file ] ignore-errors
@ -12,7 +12,7 @@ namespaces continuations layouts ;
] with-directory ;
: small-enough? ( n -- ? )
>r "test.image" temp-file file-info file-info-size r> <= ;
>r "test.image" temp-file file-info size>> r> <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test

View File

@ -1,8 +1,9 @@
IN: ui.tools.interactor.tests
USING: ui.tools.interactor ui.gadgets.panes namespaces
ui.gadgets.editors concurrency.promises threads listener
tools.test kernel calendar ;
tools.test kernel calendar parser ;
[
\ <interactor> must-infer
[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
@ -25,3 +26,4 @@ tools.test kernel calendar ;
[ ] [ "interactor" get evaluate-input ] unit-test
[ [ [ 1 2 3 ] ] ] [ "promise" get 5 seconds ?promise-timeout ] unit-test
] with-interactive-vocabs