diff --git a/library/dlists.factor b/library/dlists.factor index 9ec39c3898..67649f2c8f 100644 --- a/library/dlists.factor +++ b/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 ; diff --git a/library/io/buffer.factor b/library/io/buffer.factor index 6ea7cc3da3..86c793f4dc 100644 --- a/library/io/buffer.factor +++ b/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 -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 +TUPLE: buffer size ptr fill 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 ; -: ( size -- buffer ) - #! Allocates and returns a new buffer. - [ - dup buf-size set - imalloc buf-ptr set - 0 buf-fill set - 0 buf-pos set - ] extend ; +C: buffer ( size -- buffer ) + 2dup set-buffer-size + swap imalloc swap [ set-buffer-ptr ] keep + 0 swap [ set-buffer-fill ] keep + 0 swap [ set-buffer-pos ] keep ; : 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. - [ - buf-ptr get buf-pos get + - buf-fill get buf-pos get - - memory>string - ] bind ; + dup buffer-ptr over buffer-pos + + over buffer-fill pick buffer-pos - + memory>string nip ; : buffer-first-n ( count buffer -- string ) - [ - buf-fill get buf-pos get - min - buf-ptr get buf-pos get + - swap memory>string - ] bind ; + [ dup buffer-fill swap buffer-pos - min ] keep + dup buffer-ptr swap buffer-pos + swap memory>string ; : 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. - [ - buf-pos [ + buf-fill get min ] change - buf-pos get buf-fill get = [ - 0 buf-pos set 0 buf-fill set - ] when - ] bind ; + [ buffer-pos + ] keep [ buffer-fill min ] keep [ set-buffer-pos ] keep + dup buffer-pos over buffer-fill = [ + [ 0 swap set-buffer-pos ] keep [ 0 swap set-buffer-fill ] keep + ] when drop ; : buffer-length ( buffer -- length ) #! Returns the amount of unconsumed input in the buffer. - [ buf-fill get buf-pos get - 0 max ] bind ; - -: buffer-size ( buffer -- size ) - [ buf-size get ] bind ; + dup buffer-fill swap buffer-pos - 0 max ; : 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. - [ - dup buf-ptr get string>memory - str-length namespace buffer-reset - ] bind ; + 2dup buffer-ptr string>memory >r str-length r> buffer-reset ; + +: (check-overflow) ( string buffer -- ) + buffer-capacity swap str-length < [ "Buffer overflow" throw ] when ; : buffer-append ( string buffer -- ) - #! Appends a string to the end of the buffer. If it doesn't fit, - #! an error is thrown. - [ - 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 ; + 2dup (check-overflow) + [ dup buffer-ptr swap buffer-fill + string>memory ] 2keep + [ buffer-fill swap str-length + ] keep set-buffer-fill ; : buffer-append-char ( int buffer -- ) - #! Append a single character to a buffer. - [ - buf-ptr get buf-fill get + 0 set-alien-1 - buf-fill [ 1 + ] change - ] bind ; + #! Append a single character to a buffer + [ dup buffer-ptr swap buffer-fill + 0 set-alien-1 ] keep + [ buffer-fill 1 + ] keep set-buffer-fill ; : buffer-extend ( length buffer -- ) #! Increases the size of the buffer by length. - [ - buf-size get + dup buf-ptr get swap irealloc - buf-ptr set buf-size set - ] bind ; + [ buffer-size + dup ] keep [ buffer-ptr swap ] keep >r irealloc r> + [ set-buffer-ptr ] keep set-buffer-size ; -: 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 ) - #! Returns the memory address of the buffer area. - [ buf-ptr get ] bind ; - -: buffer-pos ( buffer -- int ) - [ buf-ptr get buf-pos get + ] bind ; +: buffer-pos+ptr ( buffer -- int ) + [ buffer-ptr ] keep buffer-pos + ; diff --git a/library/io/win32-io-internals.factor b/library/io/win32-io-internals.factor index 1664b87f19..8d2a730faa 100644 --- a/library/io/win32-io-internals.factor +++ b/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 ( -- ) - #! If a write or read call fails unexpectedly, throw an error. - GetLastError [ +: expected-error? ( -- bool ) + [ ERROR_IO_PENDING ERROR_HANDLE_EOF ERROR_SUCCESS WAIT_TIMEOUT - ] contains? [ - win32-throw-error - ] unless ; + ] contains? ; + +: 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 [ 0 swap set-indirect-pointer-value ] keep @@ -121,8 +124,8 @@ END-STRUCT ] ifte ; : wait-for-io ( timeout -- callback len ) - (wait-for-io) rot [ handle-io-error ] unless - overlapped>callback swap indirect-pointer-value ; + (wait-for-io) 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 + [ 32 callbacks set f free-list set diff --git a/library/io/win32-server.factor b/library/io/win32-server.factor index 59311659c1..31f02bd97b 100644 --- a/library/io/win32-server.factor +++ b/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 0 32 32 NULL r> AcceptEx [ handle-socket-error ] unless (yield) - ] callcc0 + ] callcc1 pending-error drop swap dup add-completion dupd swap buffer-free ] bind ; diff --git a/library/io/win32-stream.factor b/library/io/win32-stream.factor index a5edb9be70..fc855d973c 100644 --- a/library/io/win32-stream.factor +++ b/library/io/win32-stream.factor @@ -42,8 +42,7 @@ USE: threads USE: win32-api USE: win32-io-internals -TUPLE: win32-stream this ; -! handle in-buffer out-buffer fileptr file-size ; +TUPLE: win32-stream this ; ! FIXME: rewrite using tuples 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 diff --git a/library/test/buffer.factor b/library/test/buffer.factor new file mode 100644 index 0000000000..3cdcfd776f --- /dev/null +++ b/library/test/buffer.factor @@ -0,0 +1,16 @@ +IN: scratchpad USING: test kernel kernel-internals ; + +: with-buffer ( size quot -- ) + >r 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 diff --git a/library/test/test.factor b/library/test/test.factor index 9eaa372868..d7fdd643a0 100644 --- a/library/test/test.factor +++ b/library/test/test.factor @@ -107,7 +107,13 @@ USE: unparser ] [ test ] each - + + os "win32" = [ + [ + "buffer" + ] [ test ] each + ] when + cpu "x86" = [ [ "compiler/optimizer"