Windows CE I/O cleanup
Slava Pestov
parent
6d3d12667b
commit
d74db3abb9
|
|
@ -0,0 +1,22 @@
|
|||
USING: io.nonblocking io.windows threads.private kernel
|
||||
io.backend windows.winsock windows ;
|
||||
IN: io.windows.ce.backend
|
||||
|
||||
: port-errored ( port -- )
|
||||
win32-error-string swap set-port-error ;
|
||||
|
||||
M: windows-ce-io io-multiplex ( ms -- ) (sleep) ;
|
||||
M: windows-ce-io add-completion ( port -- ) drop ;
|
||||
|
||||
GENERIC: wince-read ( port port-handle -- )
|
||||
|
||||
M: input-port (wait-to-read) ( port -- )
|
||||
dup port-handle wince-read ;
|
||||
|
||||
GENERIC: wince-write ( port port-handle -- )
|
||||
|
||||
M: windows-ce-io flush-output ( port -- )
|
||||
dup port-handle wince-write ;
|
||||
|
||||
M: windows-ce-io init-io ( -- )
|
||||
init-winsock ;
|
||||
|
|
@ -1,235 +1,5 @@
|
|||
USING: alien alien.c-types combinators
|
||||
io io.backend io.buffers io.files io.nonblocking io.sockets
|
||||
io.sockets.impl io.windows kernel libc math namespaces
|
||||
prettyprint qualified sequences strings threads threads.private
|
||||
windows windows.kernel32 ;
|
||||
QUALIFIED: windows.winsock
|
||||
USING: io.backend io.windows io.windows.ce.backend
|
||||
io.windows.ce.files io.windows.ce.sockets namespaces ;
|
||||
IN: io.windows.ce
|
||||
|
||||
! M: windows-ce-io normalize-pathname ( string -- string )
|
||||
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
|
||||
|
||||
M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
|
||||
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
|
||||
M: windows-ce-io io-multiplex ( ms -- ) (sleep) ;
|
||||
M: windows-ce-io add-completion ( port -- ? ) drop f ;
|
||||
|
||||
: port-errored ( port -- )
|
||||
win32-error-string swap set-port-error ;
|
||||
|
||||
GENERIC: wince-read ( port port-handle -- )
|
||||
|
||||
M: win32-file wince-read
|
||||
drop dup make-FileArgs dup setup-read ReadFile zero? [
|
||||
drop port-errored
|
||||
] [
|
||||
FileArgs-lpNumberOfBytesRet *uint dup zero? [
|
||||
drop
|
||||
t swap set-port-eof?
|
||||
] [
|
||||
swap n>buffer
|
||||
] if
|
||||
] if ;
|
||||
|
||||
TUPLE: WSAArgs
|
||||
s
|
||||
lpBuffers
|
||||
dwBufferCount
|
||||
lpNumberOfBytesRet
|
||||
lpFlags
|
||||
lpOverlapped
|
||||
lpCompletionRoutine ;
|
||||
C: <WSAArgs> WSAArgs
|
||||
|
||||
: make-WSAArgs ( port -- <WSARecv> )
|
||||
[ port-handle win32-file-handle ] keep
|
||||
delegate 1 "DWORD" <c-object> f f f <WSAArgs> ;
|
||||
|
||||
: setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
|
||||
[ WSAArgs-s ] keep
|
||||
[
|
||||
WSAArgs-lpBuffers [ buffer-capacity ] keep
|
||||
buffer-end
|
||||
"WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
] keep
|
||||
[ WSAArgs-dwBufferCount ] keep
|
||||
[ WSAArgs-lpNumberOfBytesRet ] keep
|
||||
[ WSAArgs-lpFlags ] keep
|
||||
[ WSAArgs-lpOverlapped ] keep
|
||||
WSAArgs-lpCompletionRoutine ;
|
||||
|
||||
! M: win32-socket wince-read ( port port-handle -- )
|
||||
! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [
|
||||
! drop port-errored
|
||||
! ] [
|
||||
! WSAArgs-lpNumberOfBytesRet *uint dup zero? [
|
||||
! drop
|
||||
! t swap set-port-eof?
|
||||
! ] [
|
||||
! swap n>buffer
|
||||
! ] if
|
||||
! ] if ;
|
||||
|
||||
M: win32-socket wince-read ( port port-handle -- )
|
||||
win32-file-handle over
|
||||
delegate [ buffer-end ] keep buffer-capacity 0
|
||||
windows.winsock:recv dup windows.winsock:SOCKET_ERROR = [
|
||||
drop port-errored
|
||||
] [
|
||||
dup zero? [
|
||||
drop
|
||||
t swap set-port-eof?
|
||||
] [
|
||||
swap n>buffer
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: input-port (wait-to-read) ( port -- )
|
||||
dup port-handle wince-read ;
|
||||
|
||||
GENERIC: wince-write ( port port-handle -- )
|
||||
|
||||
M: win32-file wince-write ( port port-handle -- )
|
||||
drop dup make-FileArgs dup setup-write WriteFile zero? [
|
||||
drop port-errored
|
||||
] [
|
||||
FileArgs-lpNumberOfBytesRet *uint ! *DWORD
|
||||
over delegate [ buffer-consume ] keep
|
||||
buffer-length 0 > [
|
||||
flush-output
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: setup-WSASend ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
|
||||
[ WSAArgs-s ] keep
|
||||
[
|
||||
WSAArgs-lpBuffers [ buffer-length ] keep
|
||||
buffer@
|
||||
"WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
] keep
|
||||
[ WSAArgs-dwBufferCount ] keep
|
||||
[ WSAArgs-lpNumberOfBytesRet ] keep
|
||||
[ WSAArgs-lpFlags ] keep
|
||||
[ WSAArgs-lpOverlapped ] keep
|
||||
WSAArgs-lpCompletionRoutine ;
|
||||
|
||||
! M: win32-socket wince-write ( port port-handle -- )
|
||||
! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [
|
||||
! drop port-errored
|
||||
! ] [
|
||||
! FileArgs-lpNumberOfBytesRet *uint ! *DWORD
|
||||
! over delegate [ buffer-consume ] keep
|
||||
! buffer-length 0 > [
|
||||
! flush-output
|
||||
! ] [
|
||||
! drop
|
||||
! ] if
|
||||
! ] if ;
|
||||
|
||||
M: win32-socket wince-write ( port port-handle -- )
|
||||
win32-file-handle over
|
||||
delegate [ buffer@ ] keep
|
||||
buffer-length 0 windows.winsock:send dup windows.winsock:SOCKET_ERROR = [
|
||||
drop port-errored
|
||||
] [
|
||||
over delegate [ buffer-consume ] keep
|
||||
buffer-length 0 > [
|
||||
flush-output
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: windows-ce-io flush-output ( port -- )
|
||||
dup port-handle wince-write ;
|
||||
|
||||
M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
|
||||
|
||||
: do-connect ( addrspec -- socket )
|
||||
[ tcp-socket dup ] keep
|
||||
make-sockaddr/size
|
||||
f f f f windows.winsock:WSAConnect zero? [
|
||||
winsock-error-string throw
|
||||
] unless ;
|
||||
|
||||
M: windows-ce-io (client) ( addrspec -- duplex-stream )
|
||||
do-connect <win32-socket> dup handle>duplex-stream ;
|
||||
|
||||
M: windows-ce-io <server> ( addrspec -- duplex-stream )
|
||||
[
|
||||
windows.winsock:SOCK_STREAM server-fd
|
||||
dup listen-on-socket
|
||||
<win32-socket> f <port>
|
||||
] keep <server-port> ;
|
||||
|
||||
M: windows-ce-io accept ( server -- client )
|
||||
dup check-server-port
|
||||
[
|
||||
[ touch-port ] keep
|
||||
[ port-handle win32-file-handle ] keep
|
||||
server-port-addr sockaddr-type heap-size
|
||||
[ "char" <c-array> ] keep [
|
||||
<int>
|
||||
f 0
|
||||
windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET = [
|
||||
winsock-error-string throw
|
||||
] when
|
||||
] keep
|
||||
] keep server-port-addr parse-sockaddr swap
|
||||
<win32-socket> dup handle>duplex-stream <client-stream> ;
|
||||
|
||||
T{ windows-ce-io } io-backend set-global
|
||||
|
||||
M: windows-ce-io init-io ( -- )
|
||||
init-winsock ;
|
||||
|
||||
M: windows-ce-io <datagram> ( addrspec -- datagram )
|
||||
[
|
||||
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
|
||||
] keep <datagram-port> ;
|
||||
|
||||
M: windows-ce-io receive ( datagram -- packet addrspec )
|
||||
dup check-datagram-port
|
||||
[
|
||||
port-handle delegate win32-file-handle
|
||||
"WSABUF" <c-object>
|
||||
default-buffer-size over windows.winsock:set-WSABUF-len
|
||||
default-buffer-size "char" <c-array> over windows.winsock:set-WSABUF-buf
|
||||
[
|
||||
1
|
||||
0 <uint> [
|
||||
0 <uint>
|
||||
64 "char" <c-array> [
|
||||
64 <int>
|
||||
f
|
||||
f
|
||||
windows.winsock:WSARecvFrom zero? [
|
||||
winsock-error-string throw
|
||||
] unless
|
||||
] keep
|
||||
] keep *uint
|
||||
] keep
|
||||
] keep
|
||||
! sockaddr count buf datagram
|
||||
>r windows.winsock:WSABUF-buf swap memory>string swap r>
|
||||
datagram-port-addr parse-sockaddr ;
|
||||
|
||||
M: windows-ce-io send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
delegate port-handle delegate win32-file-handle
|
||||
rot dup length "WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
|
||||
rot make-sockaddr/size
|
||||
>r >r 1 0 <uint> 0 r> r> f f
|
||||
windows.winsock:WSASendTo zero? [
|
||||
winsock-error-string throw
|
||||
] unless ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,36 @@
|
|||
USING: alien alien.c-types combinators io io.backend io.buffers
|
||||
io.files io.nonblocking io.windows kernel libc math namespaces
|
||||
prettyprint sequences strings threads threads.private
|
||||
windows windows.kernel32 io.windows.ce.backend ;
|
||||
IN: windows.ce.files
|
||||
|
||||
! M: windows-ce-io normalize-pathname ( string -- string )
|
||||
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
|
||||
|
||||
M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
|
||||
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
|
||||
|
||||
M: win32-file wince-read
|
||||
drop dup make-FileArgs dup setup-read ReadFile zero? [
|
||||
drop port-errored
|
||||
] [
|
||||
FileArgs-lpNumberOfBytesRet *uint dup zero? [
|
||||
drop
|
||||
t swap set-port-eof?
|
||||
] [
|
||||
swap n>buffer
|
||||
] if
|
||||
] if ;
|
||||
|
||||
M: win32-file wince-write ( port port-handle -- )
|
||||
drop dup make-FileArgs dup setup-write WriteFile zero? [
|
||||
drop port-errored
|
||||
] [
|
||||
FileArgs-lpNumberOfBytesRet *uint ! *DWORD
|
||||
over delegate [ buffer-consume ] keep
|
||||
buffer-length 0 > [
|
||||
flush-output
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] if ;
|
||||
|
|
@ -0,0 +1,178 @@
|
|||
USING: alien alien.c-types combinators io io.backend io.buffers
|
||||
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
|
||||
math namespaces prettyprint qualified sequences strings threads
|
||||
threads.private windows windows.kernel32 io.windows.ce.backend ;
|
||||
QUALIFIED: windows.winsock
|
||||
IN: io.windows.ce
|
||||
|
||||
M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
|
||||
|
||||
TUPLE: WSAArgs
|
||||
s
|
||||
lpBuffers
|
||||
dwBufferCount
|
||||
lpNumberOfBytesRet
|
||||
lpFlags
|
||||
lpOverlapped
|
||||
lpCompletionRoutine ;
|
||||
C: <WSAArgs> WSAArgs
|
||||
|
||||
: make-WSAArgs ( port -- <WSARecv> )
|
||||
[ port-handle win32-file-handle ] keep
|
||||
delegate 1 "DWORD" <c-object> f f f <WSAArgs> ;
|
||||
|
||||
: setup-WSARecv ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
|
||||
[ WSAArgs-s ] keep
|
||||
[
|
||||
WSAArgs-lpBuffers [ buffer-capacity ] keep
|
||||
buffer-end
|
||||
"WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
] keep
|
||||
[ WSAArgs-dwBufferCount ] keep
|
||||
[ WSAArgs-lpNumberOfBytesRet ] keep
|
||||
[ WSAArgs-lpFlags ] keep
|
||||
[ WSAArgs-lpOverlapped ] keep
|
||||
WSAArgs-lpCompletionRoutine ;
|
||||
|
||||
! M: win32-socket wince-read ( port port-handle -- )
|
||||
! drop dup make-WSAArgs dup setup-WSARecv WSARecv zero? [
|
||||
! drop port-errored
|
||||
! ] [
|
||||
! WSAArgs-lpNumberOfBytesRet *uint dup zero? [
|
||||
! drop
|
||||
! t swap set-port-eof?
|
||||
! ] [
|
||||
! swap n>buffer
|
||||
! ] if
|
||||
! ] if ;
|
||||
|
||||
M: win32-socket wince-read ( port port-handle -- )
|
||||
win32-file-handle over
|
||||
delegate [ buffer-end ] keep buffer-capacity 0
|
||||
windows.winsock:recv dup windows.winsock:SOCKET_ERROR = [
|
||||
drop port-errored
|
||||
] [
|
||||
dup zero? [
|
||||
drop
|
||||
t swap set-port-eof?
|
||||
] [
|
||||
swap n>buffer
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: setup-WSASend ( <WSAArgs> -- s lpBuffers dwBufferCount lpNumberOfBytesRet lpFlags lpOverlapped lpCompletionRoutine )
|
||||
[ WSAArgs-s ] keep
|
||||
[
|
||||
WSAArgs-lpBuffers [ buffer-length ] keep
|
||||
buffer@
|
||||
"WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
] keep
|
||||
[ WSAArgs-dwBufferCount ] keep
|
||||
[ WSAArgs-lpNumberOfBytesRet ] keep
|
||||
[ WSAArgs-lpFlags ] keep
|
||||
[ WSAArgs-lpOverlapped ] keep
|
||||
WSAArgs-lpCompletionRoutine ;
|
||||
|
||||
! M: win32-socket wince-write ( port port-handle -- )
|
||||
! drop dup make-WSAArgs dup setup-WSASend WSASend zero? [
|
||||
! drop port-errored
|
||||
! ] [
|
||||
! FileArgs-lpNumberOfBytesRet *uint ! *DWORD
|
||||
! over delegate [ buffer-consume ] keep
|
||||
! buffer-length 0 > [
|
||||
! flush-output
|
||||
! ] [
|
||||
! drop
|
||||
! ] if
|
||||
! ] if ;
|
||||
|
||||
M: win32-socket wince-write ( port port-handle -- )
|
||||
win32-file-handle over
|
||||
delegate [ buffer@ ] keep
|
||||
buffer-length 0 windows.winsock:send dup windows.winsock:SOCKET_ERROR = [
|
||||
drop port-errored
|
||||
] [
|
||||
over delegate [ buffer-consume ] keep
|
||||
buffer-length 0 > [
|
||||
flush-output
|
||||
] [
|
||||
drop
|
||||
] if
|
||||
] if ;
|
||||
|
||||
: do-connect ( addrspec -- socket )
|
||||
[ tcp-socket dup ] keep
|
||||
make-sockaddr/size
|
||||
f f f f windows.winsock:WSAConnect zero?
|
||||
[ windows.winsock:winsock-error ] unless ;
|
||||
|
||||
M: windows-ce-io (client) ( addrspec -- duplex-stream )
|
||||
do-connect <win32-socket> dup handle>duplex-stream ;
|
||||
|
||||
M: windows-ce-io <server> ( addrspec -- duplex-stream )
|
||||
[
|
||||
windows.winsock:SOCK_STREAM server-fd
|
||||
dup listen-on-socket
|
||||
<win32-socket> f <port>
|
||||
] keep <server-port> ;
|
||||
|
||||
M: windows-ce-io accept ( server -- client )
|
||||
dup check-server-port
|
||||
[
|
||||
[ touch-port ] keep
|
||||
[ port-handle win32-file-handle ] keep
|
||||
server-port-addr sockaddr-type heap-size
|
||||
[ "char" <c-array> ] keep [
|
||||
<int>
|
||||
f 0
|
||||
windows.winsock:WSAAccept dup windows.winsock:INVALID_SOCKET =
|
||||
[ windows.winsock:winsock-error ] when
|
||||
] keep
|
||||
] keep server-port-addr parse-sockaddr swap
|
||||
<win32-socket> dup handle>duplex-stream <client-stream> ;
|
||||
|
||||
M: windows-ce-io <datagram> ( addrspec -- datagram )
|
||||
[
|
||||
windows.winsock:SOCK_DGRAM server-fd <win32-socket> f <port>
|
||||
] keep <datagram-port> ;
|
||||
|
||||
M: windows-ce-io receive ( datagram -- packet addrspec )
|
||||
dup check-datagram-port
|
||||
[
|
||||
port-handle delegate win32-file-handle
|
||||
"WSABUF" <c-object>
|
||||
default-buffer-size over windows.winsock:set-WSABUF-len
|
||||
default-buffer-size "char" <c-array> over windows.winsock:set-WSABUF-buf
|
||||
[
|
||||
1
|
||||
0 <uint> [
|
||||
0 <uint>
|
||||
64 "char" <c-array> [
|
||||
64 <int>
|
||||
f
|
||||
f
|
||||
windows.winsock:WSARecvFrom zero?
|
||||
[ windows.winsock:winsock-error ] unless
|
||||
] keep
|
||||
] keep *uint
|
||||
] keep
|
||||
] keep
|
||||
! sockaddr count buf datagram
|
||||
>r windows.winsock:WSABUF-buf swap memory>string swap r>
|
||||
datagram-port-addr parse-sockaddr ;
|
||||
|
||||
M: windows-ce-io send ( packet addrspec datagram -- )
|
||||
3dup check-datagram-send
|
||||
delegate port-handle delegate win32-file-handle
|
||||
rot dup length "WSABUF" <c-object>
|
||||
[ windows.winsock:set-WSABUF-len ] keep
|
||||
[ windows.winsock:set-WSABUF-buf ] keep
|
||||
|
||||
rot make-sockaddr/size
|
||||
>r >r 1 0 <uint> 0 r> r> f f
|
||||
windows.winsock:WSASendTo zero?
|
||||
[ windows.winsock:winsock-error ] unless ;
|
||||
|
|
@ -166,9 +166,8 @@ FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ;
|
|||
FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ;
|
||||
FUNCTION: int closesocket ( SOCKET s ) ;
|
||||
FUNCTION: int shutdown ( SOCKET s, int how ) ;
|
||||
! FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
|
||||
! FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
|
||||
|
||||
FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ;
|
||||
FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ;
|
||||
|
||||
TYPEDEF: uint SERVICETYPE
|
||||
TYPEDEF: OVERLAPPED WSAOVERLAPPED
|
||||
|
|
@ -405,6 +404,9 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
|
|||
: winsock-error-string ( -- string/f )
|
||||
WSAGetLastError (winsock-error-string) ;
|
||||
|
||||
: winsock-error ( -- )
|
||||
winsock-error-string [ throw ] when* ;
|
||||
|
||||
: winsock-error=0/f ( n/f -- )
|
||||
{ 0 f } member? [
|
||||
winsock-error-string throw
|
||||
|
|
@ -428,7 +430,7 @@ FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, voi
|
|||
] when ;
|
||||
|
||||
: socket-error ( n -- )
|
||||
SOCKET_ERROR = [ winsock-error-string throw ] when ;
|
||||
SOCKET_ERROR = [ winsock-error ] when ;
|
||||
|
||||
: init-winsock ( -- )
|
||||
HEX: 0202 <wsadata> WSAStartup winsock-error!=0/f ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue