Fix conflict
commit
ad2ebc90c5
|
@ -105,6 +105,8 @@ strings accessors io.encodings.utf8 math destructors ;
|
|||
|
||||
[ f ] [ "test-bar.txt" temp-file exists? ] unit-test
|
||||
|
||||
[ "test-blah" temp-file delete-tree ] ignore-errors
|
||||
|
||||
[ ] [ "test-blah" temp-file make-directory ] unit-test
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -10,12 +10,15 @@ TUPLE: c-writer handle disposed ;
|
|||
: <c-writer> ( handle -- stream ) f c-writer boa ;
|
||||
|
||||
M: c-writer stream-write1
|
||||
dup check-disposed
|
||||
handle>> fputc ;
|
||||
|
||||
M: c-writer stream-write
|
||||
dup check-disposed
|
||||
handle>> fwrite ;
|
||||
|
||||
M: c-writer stream-flush
|
||||
dup check-disposed
|
||||
handle>> fflush ;
|
||||
|
||||
M: c-writer dispose*
|
||||
|
@ -26,12 +29,14 @@ TUPLE: c-reader handle disposed ;
|
|||
: <c-reader> ( handle -- stream ) f c-reader boa ;
|
||||
|
||||
M: c-reader stream-read
|
||||
dup check-disposed
|
||||
handle>> fread ;
|
||||
|
||||
M: c-reader stream-read-partial
|
||||
stream-read ;
|
||||
|
||||
M: c-reader stream-read1
|
||||
dup check-disposed
|
||||
handle>> fgetc ;
|
||||
|
||||
: read-until-loop ( stream delim -- ch )
|
||||
|
@ -42,6 +47,7 @@ M: c-reader stream-read1
|
|||
] if ;
|
||||
|
||||
M: c-reader stream-read-until
|
||||
dup check-disposed
|
||||
[ swap read-until-loop ] B{ } make swap
|
||||
over empty? over not and [ 2drop f f ] when ;
|
||||
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
IN: io.monitors.tests
|
||||
USING: io.monitors tools.test io.files system sequences
|
||||
continuations namespaces concurrency.count-downs kernel io
|
||||
threads calendar prettyprint destructors ;
|
||||
threads calendar prettyprint destructors io.timeouts ;
|
||||
|
||||
os { winnt linux macosx } member? [
|
||||
[
|
||||
|
@ -91,4 +91,21 @@ os { winnt linux macosx } member? [
|
|||
! Out-of-scope disposal should not fail
|
||||
[ ] [ [ "" resource-path f <monitor> ] with-monitors dispose ] unit-test
|
||||
[ ] [ [ "" resource-path t <monitor> ] with-monitors dispose ] unit-test
|
||||
|
||||
! Timeouts
|
||||
[
|
||||
[ ] [ "monitor-timeout-test" temp-file make-directories ] unit-test
|
||||
|
||||
! Non-recursive
|
||||
[ ] [ "monitor-timeout-test" temp-file f <monitor> "m" set ] unit-test
|
||||
[ ] [ 3 seconds "m" get set-timeout ] unit-test
|
||||
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
|
||||
! Recursive
|
||||
[ ] [ "monitor-timeout-test" temp-file t <monitor> "m" set ] unit-test
|
||||
[ ] [ 3 seconds "m" get set-timeout ] unit-test
|
||||
[ [ t ] [ "m" get next-change 2drop ] [ ] while ] must-fail
|
||||
[ ] [ "m" get dispose ] unit-test
|
||||
] with-monitors
|
||||
] when
|
||||
|
|
|
@ -29,15 +29,7 @@ $nl
|
|||
ABOUT: "io.ports"
|
||||
|
||||
HELP: port
|
||||
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output."
|
||||
$nl
|
||||
"Ports have the following slots:"
|
||||
{ $list
|
||||
{ { $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" }
|
||||
} } ;
|
||||
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output." } ;
|
||||
|
||||
HELP: input-port
|
||||
{ $class-description "The class of ports implementing the input stream protocol." } ;
|
||||
|
@ -65,10 +57,6 @@ HELP: <output-port>
|
|||
{ $description "Creates a new " { $link output-port } " using the specified native handle and a default-sized input buffer." }
|
||||
$low-level-note ;
|
||||
|
||||
HELP: pending-error
|
||||
{ $values { "port" port } }
|
||||
{ $description "If an error occurred while the I/O thread was performing input or output on this port, this error will be thrown to the caller." } ;
|
||||
|
||||
HELP: (wait-to-read)
|
||||
{ $values { "port" input-port } }
|
||||
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
|
||||
|
|
|
@ -10,7 +10,7 @@ IN: io.ports
|
|||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
||||
TUPLE: port handle error timeout disposed ;
|
||||
TUPLE: port handle timeout disposed ;
|
||||
|
||||
M: port timeout timeout>> ;
|
||||
|
||||
|
@ -19,9 +19,6 @@ M: port set-timeout (>>timeout) ;
|
|||
: <port> ( handle class -- port )
|
||||
new swap >>handle ; inline
|
||||
|
||||
: pending-error ( port -- )
|
||||
[ f ] change-error drop [ throw ] when* ;
|
||||
|
||||
TUPLE: buffered-port < port buffer ;
|
||||
|
||||
: <buffered-port> ( handle class -- port )
|
||||
|
@ -106,14 +103,15 @@ M: output-port stream-write
|
|||
|
||||
HOOK: (wait-to-write) io-backend ( port -- )
|
||||
|
||||
: flush-port ( port -- )
|
||||
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
: port-flush ( port -- )
|
||||
dup buffer>> buffer-empty?
|
||||
[ drop ] [ dup (wait-to-write) port-flush ] if ;
|
||||
|
||||
M: output-port stream-flush ( port -- )
|
||||
[ check-disposed ] [ flush-port ] bi ;
|
||||
[ check-disposed ] [ port-flush ] bi ;
|
||||
|
||||
M: output-port dispose*
|
||||
[ flush-port ] [ call-next-method ] bi ;
|
||||
M: output-port dispose
|
||||
[ port-flush ] [ call-next-method ] bi ;
|
||||
|
||||
M: buffered-port dispose*
|
||||
[ call-next-method ]
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
IN: io.sockets.tests
|
||||
USING: io.sockets sequences math tools.test namespaces accessors
|
||||
kernel destructors ;
|
||||
kernel destructors calendar io.timeouts ;
|
||||
|
||||
[ B{ 1 2 3 4 } ]
|
||||
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
|
||||
|
@ -62,3 +62,9 @@ kernel destructors ;
|
|||
|
||||
[ ] [ "datagram1" get dispose ] unit-test
|
||||
[ ] [ "datagram2" get dispose ] unit-test
|
||||
|
||||
! Test timeouts
|
||||
[ ] [ "127.0.0.1" 0 <inet4> <datagram> "datagram3" set ] unit-test
|
||||
|
||||
[ ] [ 1 seconds "datagram3" get set-timeout ] unit-test
|
||||
[ "datagram3" get receive ] must-fail
|
||||
|
|
|
@ -62,21 +62,18 @@ GENERIC: wait-for-events ( ms mx -- )
|
|||
: output-available ( fd mx -- )
|
||||
remove-output-callbacks [ resume ] each ;
|
||||
|
||||
TUPLE: io-timeout ;
|
||||
|
||||
M: io-timeout summary drop "I/O operation timed out" ;
|
||||
|
||||
M: unix cancel-io ( port -- )
|
||||
io-timeout new >>error
|
||||
handle>> handle-fd mx get-global
|
||||
[ input-available ] [ output-available ] 2bi ;
|
||||
[ remove-input-callbacks [ t swap resume-with ] each ]
|
||||
[ remove-output-callbacks [ t swap resume-with ] each ]
|
||||
2bi ;
|
||||
|
||||
SYMBOL: +retry+ ! just try the operation again without blocking
|
||||
SYMBOL: +input+
|
||||
SYMBOL: +output+
|
||||
|
||||
: wait-for-fd ( handle event -- )
|
||||
dup +retry+ eq? [ 2drop ] [
|
||||
: wait-for-fd ( handle event -- timeout? )
|
||||
dup +retry+ eq? [ 2drop f ] [
|
||||
[
|
||||
>r
|
||||
swap handle-fd
|
||||
|
@ -85,12 +82,18 @@ SYMBOL: +output+
|
|||
{ +input+ [ add-input-callback ] }
|
||||
{ +output+ [ add-output-callback ] }
|
||||
} case
|
||||
] curry "I/O" suspend 2drop
|
||||
] curry "I/O" suspend nip
|
||||
] if ;
|
||||
|
||||
ERROR: io-timeout ;
|
||||
|
||||
M: io-timeout summary drop "I/O operation timed out" ;
|
||||
|
||||
: wait-for-port ( port event -- )
|
||||
[ >r dup handle>> r> wait-for-fd ] curry
|
||||
with-timeout pending-error ;
|
||||
[
|
||||
>r handle>> r> wait-for-fd
|
||||
[ io-timeout ] when
|
||||
] with-timeout ;
|
||||
|
||||
! Some general stuff
|
||||
: file-mode OCT: 0666 ;
|
||||
|
@ -147,8 +150,7 @@ M: fd drain
|
|||
} cond ;
|
||||
|
||||
M: unix (wait-to-write) ( port -- )
|
||||
dup dup handle>> drain dup
|
||||
[ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
|
||||
dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ;
|
||||
|
||||
M: unix io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
@ -166,7 +168,8 @@ TUPLE: mx-port < port mx ;
|
|||
|
||||
: multiplexer-error ( n -- )
|
||||
0 < [
|
||||
err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless
|
||||
err_no [ EAGAIN = ] [ EINTR = ] bi or
|
||||
[ (io-error) ] unless
|
||||
] when ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
|
|
|
@ -111,7 +111,7 @@ M: secure (server) addrspec>> (server) ;
|
|||
|
||||
: do-ssl-accept ( ssl-handle -- )
|
||||
dup dup handle>> SSL_accept check-accept-response dup
|
||||
[ >r dup file>> r> wait-for-fd do-ssl-accept ] [ 2drop ] if ;
|
||||
[ >r dup file>> r> wait-for-fd drop do-ssl-accept ] [ 2drop ] if ;
|
||||
|
||||
M: secure (accept)
|
||||
[
|
||||
|
@ -120,7 +120,7 @@ M: secure (accept)
|
|||
dup do-ssl-accept r>
|
||||
] with-destructors ;
|
||||
|
||||
: check-shutdown-response ( handle r -- event ) USING: io prettyprint ;
|
||||
: check-shutdown-response ( handle r -- event )
|
||||
#! SSL_shutdown always returns 0 due to openssl bugs?
|
||||
{
|
||||
{ 1 [ drop f ] }
|
||||
|
@ -146,5 +146,5 @@ M: secure (accept)
|
|||
M: unix ssl-shutdown
|
||||
dup connected>> [
|
||||
dup dup handle>> SSL_shutdown check-shutdown-response
|
||||
dup [ dupd wait-for-fd ssl-shutdown ] [ 2drop ] if
|
||||
dup [ dupd wait-for-fd drop ssl-shutdown ] [ 2drop ] if
|
||||
] [ drop ] if ;
|
||||
|
|
|
@ -8,7 +8,8 @@ accessors locals ;
|
|||
QUALIFIED: windows.winsock
|
||||
IN: io.windows.nt.backend
|
||||
|
||||
SYMBOL: io-hash
|
||||
! Global variable with assoc mapping overlapped to threads
|
||||
SYMBOL: pending-overlapped
|
||||
|
||||
TUPLE: io-callback port thread ;
|
||||
|
||||
|
@ -33,62 +34,41 @@ M: winnt add-completion ( win32-handle -- )
|
|||
handle>> master-completion-port get-global <completion-port> drop ;
|
||||
|
||||
: eof? ( error -- ? )
|
||||
dup ERROR_HANDLE_EOF = swap ERROR_BROKEN_PIPE = or ;
|
||||
|
||||
: overlapped-error? ( port n -- ? )
|
||||
zero? [
|
||||
GetLastError {
|
||||
{ [ dup expected-io-error? ] [ 2drop t ] }
|
||||
{ [ dup eof? ] [ drop t >>eof drop f ] }
|
||||
[ (win32-error-string) throw ]
|
||||
} cond
|
||||
] [
|
||||
drop t
|
||||
] if ;
|
||||
|
||||
: get-overlapped-result ( overlapped port -- bytes-transferred )
|
||||
dup handle>> handle>> rot 0 <uint>
|
||||
[ 0 GetOverlappedResult overlapped-error? drop ] keep *uint ;
|
||||
|
||||
: save-callback ( overlapped port -- )
|
||||
[
|
||||
<io-callback> swap
|
||||
dup alien? [ "bad overlapped in save-callback" throw ] unless
|
||||
io-hash get-global set-at
|
||||
] "I/O" suspend 3drop ;
|
||||
[ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
|
||||
|
||||
: twiddle-thumbs ( overlapped port -- bytes-transferred )
|
||||
[ save-callback ]
|
||||
[ get-overlapped-result ]
|
||||
[ nip pending-error ]
|
||||
2tri ;
|
||||
|
||||
:: wait-for-overlapped ( ms -- overlapped ? )
|
||||
master-completion-port get-global
|
||||
0 <int> ! bytes
|
||||
f <void*> ! key
|
||||
f <void*> ! overlapped
|
||||
[
|
||||
ms INFINITE or ! timeout
|
||||
GetQueuedCompletionStatus
|
||||
] keep *void* swap zero? ;
|
||||
drop
|
||||
[ pending-overlapped get-global set-at ] curry "I/O" suspend
|
||||
{
|
||||
{ [ dup integer? ] [ ] }
|
||||
{ [ dup array? ] [
|
||||
first dup eof?
|
||||
[ drop 0 ] [ (win32-error-string) throw ] if
|
||||
] }
|
||||
} cond
|
||||
] with-timeout ;
|
||||
|
||||
: lookup-callback ( overlapped -- callback )
|
||||
io-hash get-global delete-at* drop
|
||||
dup io-callback? [ "no callback in io-hash" throw ] unless ;
|
||||
:: wait-for-overlapped ( ms -- bytes-transferred overlapped error? )
|
||||
master-completion-port get-global
|
||||
0 <int> [ ! bytes
|
||||
f <void*> ! key
|
||||
f <void*> [ ! overlapped
|
||||
ms INFINITE or ! timeout
|
||||
GetQueuedCompletionStatus zero?
|
||||
] keep *void*
|
||||
] keep *int spin ;
|
||||
|
||||
: resume-callback ( result overlapped -- )
|
||||
pending-overlapped get-global delete-at* drop resume-with ;
|
||||
|
||||
: handle-overlapped ( timeout -- ? )
|
||||
wait-for-overlapped [
|
||||
GetLastError dup expected-io-error? [ 2drop f ] [
|
||||
>r lookup-callback [ thread>> ] [ port>> ] bi r>
|
||||
dup eof?
|
||||
[ drop t >>eof ]
|
||||
[ (win32-error-string) >>error ] if drop
|
||||
resume t
|
||||
] if
|
||||
>r drop GetLastError
|
||||
[ 1array ] [ expected-io-error? ] bi
|
||||
[ r> 2drop f ] [ r> resume-callback t ] if
|
||||
] [
|
||||
lookup-callback
|
||||
thread>> resume t
|
||||
resume-callback t
|
||||
] if ;
|
||||
|
||||
M: winnt cancel-io
|
||||
|
@ -99,29 +79,35 @@ M: winnt io-multiplex ( ms -- )
|
|||
|
||||
M: winnt init-io ( -- )
|
||||
<master-completion-port> master-completion-port set-global
|
||||
H{ } clone io-hash set-global
|
||||
H{ } clone pending-overlapped set-global
|
||||
windows.winsock:init-winsock ;
|
||||
|
||||
: file-error? ( n -- eof? )
|
||||
zero? [
|
||||
GetLastError {
|
||||
{ [ dup expected-io-error? ] [ drop f ] }
|
||||
{ [ dup eof? ] [ drop t ] }
|
||||
[ (win32-error-string) throw ]
|
||||
} cond
|
||||
] [ f ] if ;
|
||||
|
||||
: wait-for-file ( FileArgs n port -- n )
|
||||
swap file-error?
|
||||
[ 2drop 0 ] [ >r lpOverlapped>> r> twiddle-thumbs ] if ;
|
||||
|
||||
: update-file-ptr ( n port -- )
|
||||
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
|
||||
|
||||
: finish-flush ( n port -- )
|
||||
: finish-write ( n port -- )
|
||||
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
|
||||
|
||||
: ((wait-to-write)) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-write WriteFile
|
||||
dupd overlapped-error? [
|
||||
>r lpOverlapped>> r>
|
||||
[ twiddle-thumbs ] keep
|
||||
[ finish-flush ] keep
|
||||
dup buffer>> buffer-empty? [ drop ] [ ((wait-to-write)) ] if
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
M: winnt (wait-to-write)
|
||||
[ [ ((wait-to-write)) ] with-timeout ] with-destructors ;
|
||||
[
|
||||
[ make-FileArgs dup setup-write WriteFile ]
|
||||
[ wait-for-file ]
|
||||
[ finish-write ]
|
||||
tri
|
||||
] with-destructors ;
|
||||
|
||||
: finish-read ( n port -- )
|
||||
over zero? [
|
||||
|
@ -130,13 +116,10 @@ M: winnt (wait-to-write)
|
|||
[ buffer>> n>buffer ] [ update-file-ptr ] 2bi
|
||||
] if ;
|
||||
|
||||
: ((wait-to-read)) ( port -- )
|
||||
dup make-FileArgs
|
||||
tuck setup-read ReadFile
|
||||
dupd overlapped-error? [
|
||||
>r lpOverlapped>> r>
|
||||
[ twiddle-thumbs ] [ finish-read ] bi
|
||||
] [ 2drop ] if ;
|
||||
|
||||
M: winnt (wait-to-read) ( port -- )
|
||||
[ [ ((wait-to-read)) ] with-timeout ] with-destructors ;
|
||||
[
|
||||
[ make-FileArgs dup setup-read ReadFile ]
|
||||
[ wait-for-file ]
|
||||
[ finish-read ]
|
||||
tri
|
||||
] with-destructors ;
|
||||
|
|
|
@ -35,7 +35,7 @@ TUPLE: win32-monitor < monitor port ;
|
|||
(make-overlapped)
|
||||
[ f ReadDirectoryChangesW win32-error=0/f ] keep ;
|
||||
|
||||
: read-changes ( port -- bytes )
|
||||
: read-changes ( port -- bytes-transferred )
|
||||
[
|
||||
[ begin-reading-changes ] [ twiddle-thumbs ] bi
|
||||
] with-destructors ;
|
||||
|
|
|
@ -131,7 +131,8 @@ TUPLE: WSARecvFrom-args port
|
|||
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ;
|
||||
|
||||
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
|
||||
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpFrom*>> ] bi ;
|
||||
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ]
|
||||
[ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ;
|
||||
|
||||
M: winnt (receive) ( datagram -- packet addrspec )
|
||||
[
|
||||
|
|
|
@ -235,13 +235,13 @@ SYMBOL: init
|
|||
|
||||
: init-openal ( -- )
|
||||
init get-global expired? [
|
||||
f f alutInit drop
|
||||
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
|
||||
1337 <alien> init set-global
|
||||
] when ;
|
||||
|
||||
: exit-openal ( -- )
|
||||
init get-global expired? [
|
||||
alutExit drop
|
||||
alutExit 0 = [ "Could not close OpenAL" throw ] when
|
||||
f init set-global
|
||||
] unless ;
|
||||
|
||||
|
|
Loading…
Reference in New Issue