major win32 io cleanup, removed callcc1 quotation building at runtime
erg
parent
38f8050d34
commit
73f4de490a
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 this ;
|
||||
SYMBOL: socket
|
||||
SYMBOL: stream
|
||||
SYMBOL: timeout
|
||||
SYMBOL: cutoff
|
||||
TUPLE: win32-client-stream host port ;
|
||||
|
||||
: (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-port win32-client-stream-port ;
|
||||
M: win32-client-stream client-stream-host ( win32-client-stream -- host )
|
||||
win32-client-stream-host ;
|
||||
M: win32-client-stream client-stream-port ( win32-client-stream -- port )
|
||||
win32-client-stream-port ;
|
||||
|
||||
C: win32-server ( port -- server )
|
||||
swap [
|
||||
new-socket tuck bind-socket dup listen-socket
|
||||
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 ;
|
||||
: make-win32-server ( port -- win32-stream )
|
||||
new-socket tuck bind-socket dup listen-socket dup add-completion
|
||||
<win32-stream> <win32-duplex-stream> ;
|
||||
|
||||
: client-sockaddr ( host port -- sockaddr )
|
||||
setup-sockaddr [
|
||||
|
|
@ -87,22 +68,27 @@ M: win32-server expire
|
|||
r> set-sockaddr-in-addr
|
||||
] keep ;
|
||||
|
||||
IN: io
|
||||
IN: io
|
||||
|
||||
USE: interpreter
|
||||
SYMBOL: serv
|
||||
: accept ( server -- client )
|
||||
win32-server-this [
|
||||
update-timeout new-socket 64 <buffer>
|
||||
[
|
||||
duplex-stream-in
|
||||
serv set
|
||||
serv get update-timeout new-socket 64 <buffer>
|
||||
[
|
||||
stream get alloc-io-callback init-overlapped
|
||||
>r >r >r socket get r> r>
|
||||
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
|
||||
swap dup add-completion <win32-stream> <line-reader>
|
||||
] callcc1 drop
|
||||
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> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
win32-stream-fileptr swap init-overlapped >r
|
||||
] append
|
||||
over win32-stream-handle unit append
|
||||
over win32-stream-in-buffer unit append
|
||||
[
|
||||
[ buffer@ ] keep
|
||||
buffer-capacity
|
||||
] append
|
||||
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
|
||||
over alloc-io-callback
|
||||
over win32-stream-fileptr swap init-overlapped >r
|
||||
dup win32-stream-handle
|
||||
over win32-stream-reader-in
|
||||
[ buffer@ ] keep buffer-capacity
|
||||
>r pick r> swap dup win32-stream-file-size
|
||||
[ swap win32-stream-fileptr - min ] when*
|
||||
f r> ReadFile zero? [ handle-io-error ] when stop
|
||||
] callcc1 [ over win32-stream-reader-in n>buffer ] keep
|
||||
swap update-file-pointer ;
|
||||
|
||||
: consume-input ( count stream -- str )
|
||||
dup win32-stream-in-buffer buffer-length zero? [ dup fill-input ] when
|
||||
win32-stream-in-buffer
|
||||
dup win32-stream-reader-in buffer-length zero? [ dup fill-input ] when
|
||||
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
|
||||
] append
|
||||
callcc1 pending-error
|
||||
dup pick update-file-pointer
|
||||
over win32-stream-out-buffer [ buffer-consume ] keep
|
||||
f r> WriteFile zero? [ handle-io-error ] when stop
|
||||
] callcc1 [ over update-file-pointer ] keep
|
||||
over win32-stream-writer-out [ 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 <= [
|
||||
2drop win32-stream-out-buffer >buffer
|
||||
over length over win32-stream-writer-out 2dup buffer-capacity <= [
|
||||
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 stream-write ( str stream -- ) do-write ;
|
||||
|
||||
M: win32-stream-writer stream-close ( stream -- )
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue