win32 bug fixes

cvs
Mackenzie Straight 2005-02-12 07:23:38 +00:00
parent f5fe5fd692
commit a1d6e58851
7 changed files with 96 additions and 99 deletions

View File

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

View File

@ -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 ;
: <buffer> ( size -- buffer )
#! Allocates and returns a new buffer.
<namespace> [
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 + <alien> 0 set-alien-1
buf-fill [ 1 + ] change
] bind ;
#! Append a single character to a buffer
[ dup buffer-ptr swap buffer-fill + <alien> 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 + ;

View File

@ -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
<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
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
<namespace> [
32 <vector> callbacks set
f free-list set

View File

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

View File

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

View File

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

View File

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