Fix conflict

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
 
 [ ] [

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 ;
 

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

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." } ;

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 ]

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

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 )

extra/io/unix/sockets/secure/secure.factor

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

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 ;

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 ;

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 )
     [

extra/openal/openal.factor

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