major win32 io cleanup, removed callcc1 quotation building at runtime

library/io/windows/io-internals.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2005 Mackenzie Straight.
+! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
 
 IN: win32-io-internals
 USING: alien arrays errors kernel kernel-internals math namespaces threads 
@@ -10,13 +10,13 @@ SYMBOL: io-queue
 TUPLE: io-queue free-list callbacks ;
 TUPLE: io-callback overlapped quotation stream ;
 
-GENERIC: expire
-
 : expected-error? ( -- bool )
     [ 
         ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS WAIT_TIMEOUT 
+        997
     ] member? ;
 
+USE: prettyprint
 : handle-io-error ( -- )
     GetLastError expected-error? [ win32-throw-error ] unless ;
 
@@ -86,6 +86,9 @@ C: io-callback ( -- callback )
         <alien> overlapped-ext-user-data get-io-callback
     ] if ;
 
+IN: win32-stream
+DEFER: expire
+IN: win32-io-internals
 : cancel-timedout ( -- )
     io-queue get 
     io-queue-callbacks [ io-callback-stream [ expire ] when* ] each ;

library/io/windows/io-last.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2003, 2004 Mackenzie Straight.
+! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
 
 IN: io
 USING: compiler namespaces kernel win32-io-internals win32-stream win32-api
@@ -6,12 +6,12 @@ USING: compiler namespaces kernel win32-io-internals win32-stream win32-api
 
 : <file-reader> <win32-file-reader> ;
 : <file-writer> <win32-file-writer> ;
-: <server> <win32-server> ;
+: <server> make-win32-server ;
 
 IN: io-internals
 
 : io-multiplex ( ms -- )
-    #! FIXME: needs to work given a timeout
+    #! FIXME: needs to work given a timeout (???)
     dup -1 = [ drop INFINITE ] when cancel-timedout wait-for-io 
     swap [ schedule-thread-with ] [ drop ] if* ;
 

library/io/windows/server.factor

@@ -5,14 +5,9 @@ USING: alien errors generic kernel kernel-internals math namespaces
        prettyprint sequences io strings threads win32-api
        win32-io-internals io-internals ;
 
-TUPLE: win32-server this ;
+TUPLE: win32-client-stream host port ;
-TUPLE: win32-client-stream host port this ;
-SYMBOL: socket
-SYMBOL: stream
-SYMBOL: timeout
-SYMBOL: cutoff
 
-: (handle-socket-error)
+: (handle-socket-error) ( -- )
     WSAGetLastError [ ERROR_IO_PENDING ERROR_SUCCESS ] member?
     [ WSAGetLastError error_message throw ] unless ;
 
@@ -25,7 +20,6 @@ SYMBOL: cutoff
 : init-winsock ( -- )
     HEX: 0202 <wsadata> WSAStartup handle-socket-error!=0/f ;
 
-
 : new-socket ( -- socket )
     AF_INET SOCK_STREAM 0 f f WSA_FLAG_OVERLAPPED
     WSASocket dup INVALID_SOCKET = [ (handle-socket-error) ] when ;
@@ -39,7 +33,7 @@ SYMBOL: cutoff
 : bind-socket ( port socket -- )
     swap setup-sockaddr "sockaddr-in" c-size wsa-bind handle-socket-error!=0/f ;
 
-: listen-backlog 20 ; inline
+: listen-backlog ( -- n ) 20 ; inline
 
 : listen-socket ( socket -- )
     listen-backlog wsa-listen handle-socket-error!=0/f ;
@@ -59,27 +53,14 @@ C: win32-client-stream ( buf stream -- stream )
     [ set-win32-client-stream-host ] keep 
     [ set-win32-client-stream-port ] keep ;
 
-M: win32-client-stream client-stream-host win32-client-stream-host ;
+M: win32-client-stream client-stream-host ( win32-client-stream -- host )
-M: win32-client-stream client-stream-port win32-client-stream-port ;
+    win32-client-stream-host ;
+M: win32-client-stream client-stream-port ( win32-client-stream -- port )
+    win32-client-stream-port ;
 
-C: win32-server ( port -- server )
+: make-win32-server ( port -- win32-stream )
-    swap [ 
+    new-socket tuck bind-socket dup listen-socket dup add-completion
-        new-socket tuck bind-socket dup listen-socket 
+    <win32-stream> <win32-duplex-stream> ;
-        dup add-completion
-        socket set
-        dup stream set
-    ] make-hash over set-win32-server-this ;
-
-M: win32-server stream-close
-    win32-server-this [ socket get CloseHandle drop ] bind ;
-
-M: win32-server set-timeout
-    win32-server-this [ timeout set ] bind ;
-
-M: win32-server expire
-    win32-server-this [
-        timeout get [ millis cutoff get > [ socket get CancelIo ] when ] when
-    ] bind ;
 
 : client-sockaddr ( host port -- sockaddr )
     setup-sockaddr [
@@ -88,21 +69,26 @@ M: win32-server expire
     ] keep ;
 
 IN: io 
+
+USE: interpreter
+SYMBOL: serv
 : accept ( server -- client )
-    win32-server-this [
-        update-timeout new-socket 64 <buffer>
     [
-            stream get alloc-io-callback init-overlapped
+        duplex-stream-in
-            >r >r >r socket get r> r> 
+        serv set
+        serv get update-timeout new-socket 64 <buffer>
+        [
+            serv get alloc-io-callback f swap init-overlapped
+            >r >r >r serv get win32-stream-handle r> r> 
             buffer-ptr <alien> 0 32 32 f r> AcceptEx
             handle-socket-error!=0/f stop
-        ] callcc1 pending-error drop
+        ] callcc1 drop
-        swap dup add-completion <win32-stream> <line-reader> 
+        swap dup add-completion <win32-stream> <win32-duplex-stream>
         dupd <win32-client-stream> swap buffer-free
-    ] bind ;
+    ] with-scope ;
 
 : <client> ( host port -- stream )
     client-sockaddr new-socket
     [ swap "sockaddr-in" c-size connect handle-socket-error!=0/f ] keep 
-    dup add-completion <win32-stream> <line-reader> ;
+    dup add-completion <win32-stream> <win32-duplex-stream> ;
 

library/io/windows/stream.factor

@@ -1,17 +1,19 @@
 ! Copyright (C) 2004, 2006 Mackenzie Straight, Doug Coleman.
 
 IN: win32-stream
-USING: alien generic hashtables io-internals kernel
+USING: alien errors generic hashtables io-internals kernel
 kernel-internals math namespaces prettyprint sequences
 io strings threads win32-api win32-io-internals ;
+USE: interpreter
 
-TUPLE: win32-stream handle in-buffer out-buffer fileptr file-size timeout cutoff ;
+TUPLE: win32-stream handle timeout cutoff fileptr file-size ;
+TUPLE: win32-stream-reader in ;
+TUPLE: win32-stream-writer out ;
+TUPLE: win32-duplex-stream ;
+SYMBOL: stream
 
 : win32-buffer-size 16384 ; inline
 
-: pending-error ( len/status -- len/status )
-    dup [ win32-throw-error ] unless ;
-
 : init-overlapped ( fileptr overlapped -- overlapped )
     0 over set-overlapped-ext-internal
     0 over set-overlapped-ext-internal-high
@@ -36,28 +38,21 @@ TUPLE: win32-stream handle in-buffer out-buffer fileptr file-size timeout cutoff
 ! Read
 : fill-input ( stream -- )
     dup update-timeout
-    dup unit
     [
-        [ alloc-io-callback ] keep
+        over alloc-io-callback
-        win32-stream-fileptr swap init-overlapped >r
+        over win32-stream-fileptr swap init-overlapped >r
-    ] append
+        dup win32-stream-handle
-    over win32-stream-handle unit append
+        over win32-stream-reader-in
-    over win32-stream-in-buffer unit append
+        [ buffer@ ] keep buffer-capacity
-    [
+        >r pick r> swap dup win32-stream-file-size
-        [ buffer@ ] keep 
+        [ swap win32-stream-fileptr - min ] when*
-        buffer-capacity
+        f r> ReadFile zero? [ handle-io-error ] when stop
-    ] append
+    ] callcc1 [ over win32-stream-reader-in n>buffer ] keep
-    over win32-stream-file-size unit append
-    over win32-stream-fileptr [ - min ] curry
-    [ when* f r> ReadFile [ handle-io-error ] unless stop ]
-    curry append
-    callcc1 pending-error
-    [ over win32-stream-in-buffer n>buffer ] keep
     swap update-file-pointer ;
 
 : consume-input ( count stream -- str ) 
-    dup win32-stream-in-buffer buffer-length zero? [ dup fill-input ] when
+    dup win32-stream-reader-in buffer-length zero? [ dup fill-input ] when
-    win32-stream-in-buffer
+    win32-stream-reader-in
     [ buffer-size min ] keep
     [ buffer-first-n ] 2keep
     buffer-consume ;
@@ -79,34 +74,29 @@ TUPLE: win32-stream handle in-buffer out-buffer fileptr file-size timeout cutoff
 ! Write
 : flush-output ( stream -- ) 
     dup update-timeout 
-    dup unit
-    [
-        [ alloc-io-callback ] keep
-        win32-stream-fileptr swap init-overlapped >r
-    ] append
-    over win32-stream-handle unit append
-    over win32-stream-out-buffer unit append
     [
+        over alloc-io-callback
+        over win32-stream-fileptr swap init-overlapped >r
+        dup win32-stream-handle
+        over win32-stream-writer-out
         [ buffer@ ] keep buffer-length
-        f r> WriteFile [ handle-io-error ] unless stop
+        f r> WriteFile zero? [ handle-io-error ] when stop
-    ] append
+    ] callcc1 [ over update-file-pointer ] keep
-    callcc1 pending-error
+    over win32-stream-writer-out [ buffer-consume ] keep 
-    dup pick update-file-pointer
-    over win32-stream-out-buffer [ buffer-consume ] keep 
     buffer-length 0 > [ flush-output ] [ drop ] if ;
 
 : maybe-flush-output ( stream -- )
-    dup win32-stream-out-buffer buffer-length 0 > [ flush-output ] [ drop ] if ;
+    dup win32-stream-writer-out buffer-length 0 > [ flush-output ] [ drop ] if ;
 
 G: do-write 1 standard-combination ;
 M: integer do-write ( integer stream -- )
-    dup win32-stream-out-buffer buffer-capacity zero?
+    dup win32-stream-writer-out buffer-capacity zero?
     [ dup flush-output ] when
-    >r ch>string r> win32-stream-out-buffer >buffer ;
+    >r ch>string r> win32-stream-writer-out >buffer ;
 
 M: string do-write ( string stream -- )
-    over length over win32-stream-out-buffer 2dup buffer-capacity <= [
+    over length over win32-stream-writer-out 2dup buffer-capacity <= [
-        2drop win32-stream-out-buffer >buffer
+        2drop win32-stream-writer-out >buffer
     ] [
         2dup buffer-size > [
             extend-buffer 
@@ -115,24 +105,30 @@ M: string do-write ( string stream -- )
         ] if do-write
     ] if ;
 
-M: win32-stream stream-close ( stream -- )
-    dup maybe-flush-output
-    dup win32-stream-handle CloseHandle 0 = [ win32-throw-error ] when
-    dup win32-stream-in-buffer buffer-free
-    win32-stream-out-buffer buffer-free ;
 
-M: win32-stream stream-read1 ( stream -- ch/f )
+M: win32-stream-reader stream-close ( stream -- )
+    dup win32-stream-reader-in buffer-free
+    win32-stream-handle CloseHandle 0 = [ win32-throw-error ] when ;
+
+M: win32-stream-reader stream-read1 ( stream -- ch/f )
     >r 1 r> consume-input >string-or-f first ;
-M: win32-stream stream-read ( n stream -- str/f )
+
+M: win32-stream-reader stream-read ( n stream -- str/f )
     >r [ <sbuf> ] keep r> -rot do-read-count ;
 
-M: win32-stream stream-flush ( stream -- ) maybe-flush-output ;
+
-M: win32-stream stream-write1 ( ch stream -- ) >r >fixnum r> do-write ;
+M: win32-stream-writer stream-close ( stream -- )
-M: win32-stream stream-write ( str stream -- ) do-write ;
+    dup maybe-flush-output
+    dup win32-stream-writer-out buffer-free
+    win32-stream-handle CloseHandle 0 = [ win32-throw-error ] when ;
+
+M: win32-stream-writer stream-flush ( stream -- ) maybe-flush-output ;
+M: win32-stream-writer stream-write1 ( ch stream -- ) >r >fixnum r> do-write ;
+M: win32-stream-writer stream-write ( str stream -- ) do-write ;
 
 M: win32-stream set-timeout ( n stream -- ) set-win32-stream-timeout ;
 
-M: win32-stream expire ( stream -- )
+: expire ( stream -- )
     dup win32-stream-timeout millis pick win32-stream-cutoff > and [
         win32-stream-handle CancelIo [ win32-throw-error ] unless
     ] [
@@ -141,17 +137,40 @@ M: win32-stream expire ( stream -- )
 
 C: win32-stream ( handle -- stream )
     [ set-win32-stream-handle ] keep
-    win32-buffer-size <buffer> swap [ set-win32-stream-in-buffer ] keep
-    win32-buffer-size <buffer> swap [ set-win32-stream-out-buffer ] keep
-    0 swap [ set-win32-stream-fileptr ] keep
-    dup win32-stream-handle f GetFileSize dup -1 = [ drop f ] when
-        swap [ set-win32-stream-file-size ] keep
     f swap [ set-win32-stream-timeout ] keep
-    0 swap [ set-win32-stream-cutoff ] keep ;
+    0 swap [ set-win32-stream-cutoff ] keep
+    dup win32-stream-handle f GetFileSize dup -1 = [ drop f ] when
+    over set-win32-stream-file-size
+    0 swap [ set-win32-stream-fileptr ] keep ;
+
+C: win32-stream-reader ( stream -- stream )
+    [ set-delegate ] keep
+    win32-buffer-size <buffer> swap [ set-win32-stream-reader-in ] keep ;
+
+C: win32-stream-writer ( stream -- stream )
+    [ set-delegate ] keep
+    win32-buffer-size <buffer> swap [ set-win32-stream-writer-out ] keep ;
+
+: make-win32-file-reader ( stream -- stream )
+    <win32-stream-reader> <line-reader> ;
 
 : <win32-file-reader> ( path -- stream )
-    t f win32-open-file <win32-stream> <line-reader> ;
+    t f win32-open-file <win32-stream> make-win32-file-reader ;
+
+: make-win32-file-writer ( stream -- stream )
+    <win32-stream-writer> <plain-writer> ;
 
 : <win32-file-writer> ( path -- stream )
-    f t win32-open-file <win32-stream> <plain-writer> ;
+    f t win32-open-file <win32-stream> make-win32-file-writer ;
+
+C: win32-duplex-stream ( stream -- stream )
+    >r [ make-win32-file-reader ] keep make-win32-file-writer <duplex-stream> r>
+    [ set-delegate ] keep ;
+
+M: win32-duplex-stream stream-close ( stream -- )
+    dup duplex-stream-out maybe-flush-output
+    dup duplex-stream-out win32-stream-writer-out buffer-free
+    dup duplex-stream-in win32-stream-reader-in buffer-free
+    duplex-stream-in
+    win32-stream-handle CloseHandle drop ; ! 0 = [ win32-throw-error ] when ;