New timeout implementation

extra/io/nonblocking/nonblocking.factor

@@ -77,7 +77,7 @@ M: object expire-port drop ;
         [ pop-back expire-port expire-timeouts ] [ drop ] if
     ] if ;
 
-: touch-port ( port -- )
+: begin-timeout ( port -- )
     dup port-timeout dup zero? [
         2drop
     ] [
@@ -85,8 +85,13 @@ M: object expire-port drop ;
         dup unqueue-timeout queue-timeout
     ] if ;
 
-M: port set-timeout
-    [ set-port-timeout ] keep touch-port ;
+: end-timeout ( port -- )
+    unqueue-timeout ;
+
+: with-port-timeout ( port quot -- )
+    over begin-timeout keep end-timeout ; inline
+
+M: port set-timeout set-port-timeout ;
 
 GENERIC: (wait-to-read) ( port -- )
 

extra/io/unix/backend/backend.factor

@@ -57,7 +57,11 @@ GENERIC: wait-for-events ( ms mx -- )
 M: mx register-io-task ( task mx -- )
     2dup check-io-task fd/container set-at ;
 
-: add-io-task ( task -- ) mx get-global register-io-task ;
+: add-io-task ( task -- )
+    mx get-global register-io-task stop ;
+
+: with-port-continuation ( port quot -- port )
+    [ callcc0 ] curry with-port-timeout ; inline
 
 M: mx unregister-io-task ( task mx -- )
     fd/container delete-at drop ;
@@ -98,7 +102,6 @@ M: integer close-handle ( fd -- )
     io-task-callbacks [ schedule-thread ] each ;
 
 : handle-io-task ( mx task -- )
-    dup io-task-port touch-port
     dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
 
 : handle-timeout ( mx task -- )
@@ -133,7 +136,8 @@ M: read-task do-io-task
     [ [ reader-eof ] [ drop ] if ] keep ;
 
 M: input-port (wait-to-read)
-    [ <read-task> add-io-task stop ] callcc0 pending-error ;
+    [ <read-task> add-io-task ] with-port-continuation
+    pending-error ;
 
 ! Writers
 : write-step ( port -- ? )
@@ -151,11 +155,11 @@ M: write-task do-io-task
 
 : add-write-io-task ( port continuation -- )
     over port-handle mx get-global mx-writes at*
-    [ io-task-callbacks push drop ]
+    [ io-task-callbacks push stop ]
     [ drop <write-task> add-io-task ] if ;
 
 : (wait-to-write) ( port -- )
-    [ add-write-io-task stop ] callcc0 drop ;
+    [ add-write-io-task ] with-port-continuation drop ;
 
 M: port port-flush ( port -- )
     dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;

extra/io/unix/sockets/sockets.factor

@@ -40,7 +40,7 @@ M: connect-task do-io-task
     0 < [ defer-error ] [ drop t ] if ;
 
 : wait-to-connect ( port -- )
-    [ <connect-task> add-io-task stop ] callcc0 drop ;
+    [ <connect-task> add-io-task ] with-port-continuation drop ;
 
 M: unix-io (client) ( addrspec -- stream )
     dup make-sockaddr/size >r >r
@@ -82,7 +82,7 @@ M: accept-task do-io-task
     over 0 >= [ do-accept t ] [ 2drop defer-error ] if ;
 
 : wait-to-accept ( server -- )
-    [ <accept-task> add-io-task stop ] callcc0 drop ;
+    [ <accept-task> add-io-task ] with-port-continuation drop ;
 
 USE: io.sockets
 
@@ -147,7 +147,7 @@ M: receive-task do-io-task
     ] if ;
 
 : wait-receive ( stream -- )
-    [ <receive-task> add-io-task stop ] callcc0 drop ;
+    [ <receive-task> add-io-task ] with-port-continuation drop ;
 
 M: unix-io receive ( datagram -- packet addrspec )
     dup check-datagram-port
@@ -178,7 +178,8 @@ M: send-task do-io-task
     swap 0 < [ io-task-port defer-error ] [ drop t ] if ;
 
 : wait-send ( packet sockaddr len stream -- )
-    [ <send-task> add-io-task stop ] callcc0 2drop 2drop ;
+    [ <send-task> add-io-task ] with-port-continuation
+    2drop 2drop ;
 
 M: unix-io send ( packet addrspec datagram -- )
     3dup check-datagram-send

extra/io/windows/ce/sockets/sockets.factor

@@ -42,9 +42,9 @@ M: windows-ce-io <server> ( addrspec -- duplex-stream )
     ] keep <server-port> ;
 
 M: windows-ce-io accept ( server -- client )
+    [
         dup check-server-port
         [
-        dup touch-port
             dup port-handle win32-file-handle
             swap server-port-addr sockaddr-type heap-size
             dup <byte-array> [
@@ -54,7 +54,8 @@ M: windows-ce-io accept ( server -- client )
                 [ windows.winsock:winsock-error ] when
             ] keep
         ] keep server-port-addr parse-sockaddr swap
-    <win32-socket> dup handle>duplex-stream <client-stream> ;
+        <win32-socket> dup handle>duplex-stream <client-stream>
+    ] with-port-timeout ;
 
 M: windows-ce-io <datagram> ( addrspec -- datagram )
     [

extra/io/windows/nt/files/files.factor

@@ -24,7 +24,6 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
     swap buffer-consume ;
 
 : (flush-output) ( port -- )
-    dup touch-port
     dup make-FileArgs
     tuck setup-write WriteFile
     dupd overlapped-error? [
@@ -37,7 +36,7 @@ M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
     ] if ;
 
 : flush-output ( port -- )
-    [ (flush-output) ] with-destructors ;
+    [ [ (flush-output) ] with-port-timeout ] with-destructors ;
 
 M: port port-flush
     dup buffer-empty? [ dup flush-output ] unless drop ;
@@ -52,17 +51,13 @@ M: port port-flush
     ] if ;
 
 : ((wait-to-read)) ( port -- )
-    dup touch-port
     dup make-FileArgs
     tuck setup-read ReadFile
     dupd overlapped-error? [
         >r FileArgs-lpOverlapped r>
         [ save-callback ] 2keep
         finish-read
-    ] [
-        2drop
-    ] if ;
+    ] [ 2drop ] if ;
 
 M: input-port (wait-to-read) ( port -- )
-    [ ((wait-to-read)) ] with-destructors ;
-
+    [ [ ((wait-to-read)) ] with-port-timeout ] with-destructors ;

extra/io/windows/nt/monitor/monitor.factor

@@ -46,8 +46,11 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
 
 : read-changes ( monitor -- bytes )
     [
-        dup begin-reading-changes swap [ save-callback ] 2keep
+        [
+            dup begin-reading-changes
+            swap [ save-callback ] 2keep
             get-overlapped-result
+        ] with-port-timeout
     ] with-destructors ;
 
 : parse-action-flag ( action mask symbol -- action )

extra/io/windows/nt/sockets/sockets.factor

@@ -128,9 +128,9 @@ TUPLE: AcceptEx-args port
     <client-stream> ;
 
 M: windows-nt-io accept ( server -- client )
+    [
         [
             dup check-server-port
-        dup touch-port
             \ AcceptEx-args construct-empty
             [ init-accept ] keep
             [ (accept) ] keep
@@ -138,6 +138,7 @@ M: windows-nt-io accept ( server -- client )
             AcceptEx-args-port pending-error
             dup duplex-stream-in pending-error
             dup duplex-stream-out pending-error
+        ] with-port-timeout
     ] with-destructors ;
 
 M: windows-nt-io <server> ( addrspec -- server )