diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor
index 14bc5fe2a2..f10bcef8a9 100755
--- a/core/io/files/files-tests.factor
+++ b/core/io/files/files-tests.factor
@@ -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
[ ] [
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index f80d9de5b5..365d5b7c5d 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -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 ;
diff --git a/extra/builder/benchmark/benchmark.factor b/extra/builder/benchmark/benchmark.factor
deleted file mode 100644
index afe277d30b..0000000000
--- a/extra/builder/benchmark/benchmark.factor
+++ /dev/null
@@ -1,43 +0,0 @@
-
-USING: kernel continuations arrays assocs sequences sorting math
- io io.styles prettyprint builder.util ;
-
-IN: builder.benchmark
-
-! : passing-benchmarks ( table -- table )
-! [ second first2 number? swap number? and ] filter ;
-
-: passing-benchmarks ( table -- table ) [ second number? ] filter ;
-
-! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
-
-: benchmark-difference ( old-table benchmark-result -- result-diff )
- first2 >r
- tuck swap at
- r>
- swap -
- 2array ;
-
-: compare-tables ( old new -- table )
- [ passing-benchmarks ] bi@
- [ benchmark-difference ] with map ;
-
-: benchmark-deltas ( -- table )
- "../benchmarks" "benchmarks" [ eval-file ] bi@
- compare-tables
- sort-values ;
-
-: benchmark-deltas. ( deltas -- )
- standard-table-style
- [
- [ [ "Benchmark" write ] with-cell [ "Delta (ms)" write ] with-cell ]
- with-row
- [ [ swap [ write ] with-cell pprint-cell ] with-row ]
- assoc-each
- ]
- tabular-output ;
-
-: show-benchmark-deltas ( -- )
- [ benchmark-deltas benchmark-deltas. ]
- [ drop "Error generating benchmark deltas" . ]
- recover ;
\ No newline at end of file
diff --git a/extra/builder/util/util.factor b/extra/builder/util/util.factor
index f9ab6c1d1d..db3b476365 100644
--- a/extra/builder/util/util.factor
+++ b/extra/builder/util/util.factor
@@ -41,12 +41,17 @@ DEFER: to-strings
: host-name* ( -- name ) host-name "." split first ;
+! : datestamp ( -- string )
+! now `{ ,[ dup timestamp-year ]
+! ,[ dup timestamp-month ]
+! ,[ dup timestamp-day ]
+! ,[ dup timestamp-hour ]
+! ,[ timestamp-minute ] }
+! [ pad-00 ] map "-" join ;
+
: datestamp ( -- string )
- now `{ ,[ dup timestamp-year ]
- ,[ dup timestamp-month ]
- ,[ dup timestamp-day ]
- ,[ dup timestamp-hour ]
- ,[ timestamp-minute ] }
+ now
+ { year>> month>> day>> hour>> minute>> } <arr>
[ pad-00 ] map "-" join ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
diff --git a/extra/io/monitors/monitors-tests.factor b/extra/io/monitors/monitors-tests.factor
old mode 100644
new mode 100755
index 6e7196960d..bd33954436
--- a/extra/io/monitors/monitors-tests.factor
+++ b/extra/io/monitors/monitors-tests.factor
@@ -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
diff --git a/extra/io/ports/ports-docs.factor b/extra/io/ports/ports-docs.factor
index 63d1507692..40890e877b 100755
--- a/extra/io/ports/ports-docs.factor
+++ b/extra/io/ports/ports-docs.factor
@@ -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." } ;
diff --git a/extra/io/ports/ports.factor b/extra/io/ports/ports.factor
index d345975441..128a8b788b 100755
--- a/extra/io/ports/ports.factor
+++ b/extra/io/ports/ports.factor
@@ -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 ]
diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor
index c411e30ae6..dfeb311312 100755
--- a/extra/io/sockets/sockets-tests.factor
+++ b/extra/io/sockets/sockets-tests.factor
@@ -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
diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor
index ae2b7872b9..a8ee5008af 100755
--- a/extra/io/sockets/sockets.factor
+++ b/extra/io/sockets/sockets.factor
@@ -217,7 +217,7 @@ TUPLE: datagram-port < port addr ;
HOOK: (datagram) io-backend ( addr -- datagram )
-: <datagram> ( addr -- datagram )
+: <datagram> ( addrspec -- datagram )
[
[ (datagram) |dispose ] keep
[ drop datagram-port <port> ] [ get-local-address ] 2bi
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
old mode 100644
new mode 100755
index 2d5ebb98ca..d43350e425
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -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 )
diff --git a/extra/io/unix/sockets/secure/secure.factor b/extra/io/unix/sockets/secure/secure.factor
old mode 100644
new mode 100755
index b4381de43b..28ecee7c1a
--- a/extra/io/unix/sockets/secure/secure.factor
+++ b/extra/io/unix/sockets/secure/secure.factor
@@ -111,7 +111,7 @@ M: ssl (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: ssl (accept)
[
@@ -144,5 +144,5 @@ M: ssl (accept)
M: unix ssl-shutdown
dup connected>> [
dup handle>> dup 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 ;
diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor
index 134a0c024a..73f4688ac9 100755
--- a/extra/io/windows/nt/backend/backend.factor
+++ b/extra/io/windows/nt/backend/backend.factor
@@ -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 ;
diff --git a/extra/io/windows/nt/monitors/monitors.factor b/extra/io/windows/nt/monitors/monitors.factor
index a509d1d5e7..fa4d19a46e 100755
--- a/extra/io/windows/nt/monitors/monitors.factor
+++ b/extra/io/windows/nt/monitors/monitors.factor
@@ -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 ;
diff --git a/extra/io/windows/nt/sockets/sockets.factor b/extra/io/windows/nt/sockets/sockets.factor
index c680d18077..a31c41942f 100755
--- a/extra/io/windows/nt/sockets/sockets.factor
+++ b/extra/io/windows/nt/sockets/sockets.factor
@@ -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 )
[
diff --git a/extra/shell/parser/parser.factor b/extra/shell/parser/parser.factor
index 46548bb34f..2ecca6199c 100644
--- a/extra/shell/parser/parser.factor
+++ b/extra/shell/parser/parser.factor
@@ -23,8 +23,8 @@ TUPLE: factor-expr expr ;
pipeline-expr new
over [ 1st ] [ 4th [ 1st ] map ] [ 5th ] tri suffix prefix-on >>commands
over 2nd >>stdin
- over 5th >>stdout
- swap 6th >>background ;
+ over 6th >>stdout
+ swap 7th >>background ;
: ast>single-quoted-expr ( ast -- obj )
2nd >string single-quoted-expr boa ;