win32 bug fixes

library/dlists.factor

@@ -53,10 +53,10 @@ C: dlist-node
         dlist-node-next (dlist-each)
     ] [
         drop
-    ] ifte* ;
+    ] ifte* ; inline
 
 : dlist-each ( dlist quot -- )
-    swap dlist-first (dlist-each) ;
+    swap dlist-first (dlist-each) ; inline
 
 : dlist-length ( dlist -- length )
     0 swap [ drop 1 + ] dlist-each ;

library/io/buffer.factor

@@ -1,8 +1,6 @@
-! :folding=indent:collapseFolds=1:
-
 ! $Id$
 !
-! Copyright (C) 2004 Mackenzie Straight.
+! Copyright (C) 2004, 2005 Mackenzie Straight.
 ! 
 ! Redistribution and use in source and binary forms, with or without
 ! modification, are permitted provided that the following conditions are met:
@@ -26,20 +24,10 @@
 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 
 IN: kernel-internals
+USING: alien errors generic kernel kernel-internals math namespaces strings
+       win32-api ;
 
-USE: alien
+TUPLE: buffer size ptr fill pos ;
-USE: errors
-USE: kernel
-USE: kernel-internals
-USE: math
-USE: namespaces
-USE: strings
-USE: win32-api
-
-SYMBOL: buf-size
-SYMBOL: buf-ptr
-SYMBOL: buf-fill
-SYMBOL: buf-pos
 
 : imalloc ( size -- address )
     "int" "libc" "malloc" [ "int" ] alien-invoke ;
@@ -50,97 +38,69 @@ SYMBOL: buf-pos
 : irealloc ( address size -- address )
     "int" "libc" "realloc" [ "int" "int" ] alien-invoke ;
 
-: <buffer> ( size -- buffer )
+C: buffer ( size -- buffer )
-    #! Allocates and returns a new buffer.
+    2dup set-buffer-size
-    <namespace> [
+    swap imalloc swap [ set-buffer-ptr ] keep
-        dup buf-size set
+    0 swap [ set-buffer-fill ] keep
-        imalloc buf-ptr set
+    0 swap [ set-buffer-pos ] keep ;
-        0 buf-fill set
-        0 buf-pos set
-    ] extend ;
 
 : buffer-free ( buffer -- )
     #! Frees the C memory associated with the buffer.
-    [ buf-ptr get ifree ] bind ;
+    buffer-ptr ifree ;
 
 : buffer-contents ( buffer -- string )
     #! Returns the current contents of the buffer.
-    [
+    dup buffer-ptr over buffer-pos +
-        buf-ptr get buf-pos get + 
+    over buffer-fill pick buffer-pos -
-        buf-fill get buf-pos get - 
+    memory>string nip ;
-        memory>string 
-    ] bind ;
 
 : buffer-first-n ( count buffer -- string )
-    [
+    [ dup buffer-fill swap buffer-pos - min ] keep
-        buf-fill get buf-pos get - min
+    dup buffer-ptr swap buffer-pos + swap memory>string ;
-        buf-ptr get buf-pos get +
-        swap memory>string
-    ] bind ;
 
 : buffer-reset ( count buffer -- )
     #! Reset the position to 0 and the fill pointer to count.
-    [ 0 buf-pos set buf-fill set ] bind ;
+    [ set-buffer-fill ] keep 0 swap set-buffer-pos ;
 
 : buffer-consume ( count buffer -- )
     #! Consume count characters from the beginning of the buffer.
-    [
+    [ buffer-pos + ] keep [ buffer-fill min ] keep [ set-buffer-pos ] keep
-        buf-pos [ + buf-fill get min ] change 
+    dup buffer-pos over buffer-fill = [
-        buf-pos get buf-fill get = [ 
+        [ 0 swap set-buffer-pos ] keep [ 0 swap set-buffer-fill ] keep
-            0 buf-pos set 0 buf-fill set 
+    ] when drop ;
-        ] when
-    ] bind ;
 
 : buffer-length ( buffer -- length )
     #! Returns the amount of unconsumed input in the buffer.
-    [ buf-fill get buf-pos get - 0 max ] bind ;
+    dup buffer-fill swap buffer-pos - 0 max ;
-
-: buffer-size ( buffer -- size )
-    [ buf-size get ] bind ;
 
 : buffer-capacity ( buffer -- int )
     #! Returns the amount of data that may be added to the buffer.
-    [ buf-size get buf-fill get - ] bind ;
+    dup buffer-size swap buffer-fill - ;
 
 : buffer-set ( string buffer -- )
-    #! Set the contents of a buffer to string.
+    2dup buffer-ptr string>memory >r str-length r> buffer-reset ;
-    [ 
+
-        dup buf-ptr get string>memory
+: (check-overflow) ( string buffer -- )
-        str-length namespace buffer-reset
+    buffer-capacity swap str-length < [ "Buffer overflow" throw ] when ;
-    ] bind ;
 
 : buffer-append ( string buffer -- )
-    #! Appends a string to the end of the buffer. If it doesn't fit,
+    2dup (check-overflow)
-    #! an error is thrown.
+    [ dup buffer-ptr swap buffer-fill + string>memory ] 2keep
-    [ 
+    [ buffer-fill swap str-length + ] keep set-buffer-fill ;
-        dup buf-size get buf-fill get - swap str-length < [
-            "Buffer overflow" throw
-        ] when
-        dup buf-ptr get buf-fill get + string>memory
-        buf-fill [ swap str-length + ] change
-    ] bind ;
 
 : buffer-append-char ( int buffer -- )
-    #! Append a single character to a buffer.
+    #! Append a single character to a buffer
-    [
+    [ dup buffer-ptr swap buffer-fill + <alien> 0 set-alien-1 ] keep
-        buf-ptr get buf-fill get + <alien> 0 set-alien-1
+    [ buffer-fill 1 + ] keep set-buffer-fill ;
-        buf-fill [ 1 + ] change
-    ] bind ;
 
 : buffer-extend ( length buffer -- )
     #! Increases the size of the buffer by length.
-    [
+    [ buffer-size + dup ] keep [ buffer-ptr swap ] keep >r irealloc r>
-        buf-size get + dup buf-ptr get swap irealloc 
+    [ set-buffer-ptr ] keep set-buffer-size ;
-        buf-ptr set buf-size set
-    ] bind ;
 
-: buffer-fill ( count buffer -- )
+: buffer-inc-fill ( count buffer -- )
     #! Increases the fill pointer by count.
-    [ buf-fill [ + ] change ] bind ;
+    [ buffer-fill + ] keep set-buffer-fill ;
 
-: buffer-ptr ( buffer -- pointer )
+: buffer-pos+ptr ( buffer -- int )
-    #! Returns the memory address of the buffer area.
+    [ buffer-ptr ] keep buffer-pos + ;
-    [ buf-ptr get ] bind ;
-
-: buffer-pos ( buffer -- int )
-    [ buf-ptr get buf-pos get + ] bind ;

library/io/win32-io-internals.factor

@@ -25,20 +25,23 @@
 
 IN: win32-io-internals
 USING: alien errors kernel kernel-internals lists math namespaces threads 
-       vectors win32-api ;
+       vectors win32-api stdio streams generic ;
 
 SYMBOL: completion-port
 SYMBOL: io-queue
 SYMBOL: free-list
 SYMBOL: callbacks
 
-: handle-io-error ( -- )
+: expected-error? ( -- bool )
-    #! If a write or read call fails unexpectedly, throw an error.
+    [ 
-    GetLastError [ 
         ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS WAIT_TIMEOUT 
-    ] contains? [ 
+    ] contains? ;
-        win32-throw-error 
+
-    ] unless ;
+: handle-io-error ( -- )
+    GetLastError expected-error? [ win32-throw-error ] unless ;
+
+: queue-error ( len/status -- len/status )
+    GetLastError expected-error? [ drop f ] unless ;
 
 : add-completion ( handle -- )
     completion-port get NULL 1 CreateIoCompletionPort drop ;
@@ -106,7 +109,7 @@ END-STRUCT
         callbacks get vector-nth cdr
     ] bind ;
 
-: (wait-for-io) ( timeout -- ? overlapped len )
+: (wait-for-io) ( timeout -- error overlapped len )
     >r completion-port get 
     <indirect-pointer> [ 0 swap set-indirect-pointer-value ] keep 
     <indirect-pointer> 
@@ -121,8 +124,8 @@ END-STRUCT
     ] ifte ;
 
 : wait-for-io ( timeout -- callback len )
-    (wait-for-io) rot [ handle-io-error ] unless
+    (wait-for-io) overlapped>callback swap indirect-pointer-value 
-    overlapped>callback swap indirect-pointer-value ;
+    rot [ queue-error ] unless ;
 
 : win32-next-io-task ( -- )
     INFINITE wait-for-io swap call ;
@@ -135,10 +138,20 @@ END-STRUCT
     ] ifte* 
     win32-io-thread ;
 
+TUPLE: null-stream ;
+M: null-stream fflush drop ;
+M: null-stream fauto-flush drop ;
+M: null-stream fread# 2drop f ;
+M: null-stream freadln drop f ;
+M: null-stream fwrite-attr 3drop ;
+M: null-stream fclose drop ;
+
 : win32-init-stdio ( -- )
     INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
     completion-port set 
     
+    << null-stream >> stdio set
+
     <namespace> [
         32 <vector> callbacks set
         f free-list set

library/io/win32-server.factor

@@ -105,7 +105,7 @@ M: win32-server accept ( server -- client )
             alloc-io-task init-overlapped >r >r >r socket get r> r> 
             buffer-ptr <alien> 0 32 32 NULL r> AcceptEx
             [ handle-socket-error ] unless (yield)
-        ] callcc0
+        ] callcc1 pending-error drop
         swap dup add-completion <win32-stream> dupd <win32-client-stream>
         swap buffer-free
     ] bind ;

library/io/win32-stream.factor

@@ -42,8 +42,7 @@ USE: threads
 USE: win32-api
 USE: win32-io-internals
 
-TUPLE: win32-stream this ;
+TUPLE: win32-stream this ; ! FIXME: rewrite using tuples
-! handle in-buffer out-buffer fileptr file-size ;
 GENERIC: win32-stream-handle
 GENERIC: do-write
 
@@ -53,6 +52,9 @@ SYMBOL: out-buffer
 SYMBOL: fileptr
 SYMBOL: file-size
 
+: pending-error ( len/status -- len/status )
+    dup [ win32-throw-error ] unless ;
+
 : init-overlapped ( overlapped -- overlapped )
     0 over set-overlapped-ext-internal
     0 over set-overlapped-ext-internal-high
@@ -66,9 +68,9 @@ SYMBOL: file-size
 : flush-output ( -- ) 
     [
         alloc-io-task init-overlapped >r
-        handle get out-buffer get [ buffer-pos ] keep buffer-length
+        handle get out-buffer get [ buffer-pos+ptr ] keep buffer-length
         NULL r> WriteFile [ handle-io-error ] unless (yield)
-    ] callcc1
+    ] callcc1 pending-error
 
     dup update-file-pointer
     out-buffer get [ buffer-consume ] keep 
@@ -93,13 +95,13 @@ M: string do-write ( str -- )
 : fill-input ( -- ) 
     [
         alloc-io-task init-overlapped >r
-        handle get in-buffer get [ buffer-pos ] keep 
+        handle get in-buffer get [ buffer-pos+ptr ] keep 
         buffer-capacity file-size get [ fileptr get - min ] when*
         NULL r>
         ReadFile [ handle-io-error ] unless (yield)
-    ] callcc1
+    ] callcc1 pending-error
 
-    dup in-buffer get buffer-fill update-file-pointer ;
+    dup in-buffer get buffer-inc-fill update-file-pointer ;
 
 : consume-input ( count -- str ) 
     in-buffer get buffer-length 0 = [ fill-input ] when

library/test/buffer.factor

@@ -0,0 +1,16 @@
+IN: scratchpad USING: test kernel kernel-internals ;
+
+: with-buffer ( size quot -- )
+    >r <buffer> r> keep buffer-free ;
+
+: buffer-test1 ( -- buffer )
+    "quux" swap [ buffer-append ] keep ;
+
+: buffer-test2 ( -- buffer )
+    6 [
+        "abcdef" swap [ buffer-append ] keep [ 3 swap buffer-consume ] keep
+        buffer-contents
+    ] with-buffer ;
+
+[ 8 ] [ 12 [ buffer-test1 buffer-capacity ] with-buffer ] unit-test
+[ "def" ] [ buffer-test2 ] unit-test 

library/test/test.factor

@@ -107,7 +107,13 @@ USE: unparser
     ] [
         test
     ] each
-    
+
+    os "win32" = [
+        [
+            "buffer"
+        ] [ test ] each
+    ] when    
+
     cpu "x86" = [
         [
             "compiler/optimizer"