steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Clean up Windows I/O a bit, remove classes.tuple.lib

db4
Slava Pestov 2008-09-01 04:32:16 -05:00
parent 92e3fc7e43
commit 8bf37558d4
7 changed files with 112 additions and 120 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/io/windows/launcher/launcher.factor
View File

@ -6,7 +6,7 @@ windows.types math windows.kernel32
namespaces io.launcher kernel sequences windows.errors namespaces io.launcher kernel sequences windows.errors
splitting system threads init strings combinators splitting system threads init strings combinators
io.backend accessors concurrency.flags io.files assocs io.backend accessors concurrency.flags io.files assocs
io.files.private windows destructors classes.tuple.lib ; io.files.private windows destructors ;
IN: io.windows.launcher IN: io.windows.launcher
TUPLE: CreateProcess-args TUPLE: CreateProcess-args
@ -30,7 +30,19 @@ TUPLE: CreateProcess-args
0 >>dwCreateFlags ; 0 >>dwCreateFlags ;
: call-CreateProcess ( CreateProcess-args -- ) : call-CreateProcess ( CreateProcess-args -- )
CreateProcess-args >tuple< CreateProcess win32-error=0/f ; {
[ lpApplicationName>> ]
[ lpCommandLine>> ]
[ lpProcessAttributes>> ]
[ lpThreadAttributes>> ]
[ bInheritHandles>> ]
[ dwCreateFlags>> ]
[ lpEnvironment>> ]
[ lpCurrentDirectory>> ]
[ lpStartupInfo>> ]
[ lpProcessInformation>> ]
} cleave
CreateProcess win32-error=0/f ;
: count-trailing-backslashes ( str n -- str n ) : count-trailing-backslashes ( str n -- str n )
>r "\\" ?tail r> swap [ >r "\\" ?tail r> swap [

5
basis/io/windows/nt/backend/backend.factor
View File

@ -1,9 +1,8 @@
USING: alien alien.c-types arrays assocs combinators USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.ports io.timeouts continuations destructors io io.backend io.ports io.timeouts
io.windows io.windows.files libc kernel math namespaces io.windows io.windows.files libc kernel math namespaces
sequences threads classes.tuple.lib windows windows.errors sequences threads windows windows.errors windows.kernel32
windows.kernel32 strings splitting io.files strings splitting io.files io.buffers qualified ascii system
io.buffers qualified ascii system
accessors locals ; accessors locals ;
QUALIFIED: windows.winsock QUALIFIED: windows.winsock
IN: io.windows.nt.backend IN: io.windows.nt.backend

155
basis/io/windows/nt/sockets/sockets.factor
View File

@ -1,9 +1,8 @@
USING: alien alien.accessors alien.c-types byte-arrays USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets continuations destructors io.ports io.timeouts io.sockets
io.sockets io namespaces io.streams.duplex io.windows io.sockets io namespaces io.streams.duplex io.windows
io.windows.sockets io.windows.sockets io.windows.nt.backend windows.winsock kernel
io.windows.nt.backend windows.winsock kernel libc math sequences libc math sequences threads system combinators accessors ;
threads classes.tuple.lib system combinators accessors ;
IN: io.windows.nt.sockets IN: io.windows.nt.sockets
: malloc-int ( object -- object ) : malloc-int ( object -- object )
@ -28,71 +27,89 @@ M: winnt WSASocket-flags ( -- DWORD )
] keep *void* ; ] keep *void* ;
TUPLE: ConnectEx-args port TUPLE: ConnectEx-args port
s* name* namelen* lpSendBuffer* dwSendDataLength* s name namelen lpSendBuffer dwSendDataLength
lpdwBytesSent* lpOverlapped* ptr* ; lpdwBytesSent lpOverlapped ptr ;
: wait-for-socket ( args -- n ) : wait-for-socket ( args -- n )
[ lpOverlapped*>> ] [ port>> ] bi twiddle-thumbs ; [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
: <ConnectEx-args> ( sockaddr size -- ConnectEx ) : <ConnectEx-args> ( sockaddr size -- ConnectEx )
ConnectEx-args new ConnectEx-args new
swap >>namelen* swap >>namelen
swap >>name* swap >>name
f >>lpSendBuffer* f >>lpSendBuffer
0 >>dwSendDataLength* 0 >>dwSendDataLength
f >>lpdwBytesSent* f >>lpdwBytesSent
(make-overlapped) >>lpOverlapped* ; (make-overlapped) >>lpOverlapped ; inline
: call-ConnectEx ( ConnectEx -- ) : call-ConnectEx ( ConnectEx -- )
ConnectEx-args >tuple*< {
[ s>> ]
[ name>> ]
[ namelen>> ]
[ lpSendBuffer>> ]
[ dwSendDataLength>> ]
[ lpdwBytesSent>> ]
[ lpOverlapped>> ]
[ ptr>> ]
} cleave
"int" "int"
{ "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" } { "SOCKET" "sockaddr_in*" "int" "PVOID" "DWORD" "LPDWORD" "void*" }
"stdcall" alien-indirect drop "stdcall" alien-indirect drop
winsock-error-string [ throw ] when* ; winsock-error-string [ throw ] when* ; inline
M: object establish-connection ( client-out remote -- ) M: object establish-connection ( client-out remote -- )
make-sockaddr/size <ConnectEx-args> make-sockaddr/size <ConnectEx-args>
swap >>port swap >>port
dup port>> handle>> handle>> >>s* dup port>> handle>> handle>> >>s
dup s*>> get-ConnectEx-ptr >>ptr* dup s>> get-ConnectEx-ptr >>ptr
dup call-ConnectEx dup call-ConnectEx
wait-for-socket drop ; wait-for-socket drop ;
TUPLE: AcceptEx-args port TUPLE: AcceptEx-args port
sListenSocket* sAcceptSocket* lpOutputBuffer* dwReceiveDataLength* sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
dwLocalAddressLength* dwRemoteAddressLength* lpdwBytesReceived* lpOverlapped* ; dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
: init-accept-buffer ( addr AcceptEx -- ) : init-accept-buffer ( addr AcceptEx -- )
swap sockaddr-type heap-size 16 + swap sockaddr-type heap-size 16 +
[ >>dwLocalAddressLength* ] [ >>dwRemoteAddressLength* ] bi [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
dup dwLocalAddressLength*>> 2 * malloc &free >>lpOutputBuffer* dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
drop ; drop ; inline
: <AcceptEx-args> ( server addr -- AcceptEx ) : <AcceptEx-args> ( server addr -- AcceptEx )
AcceptEx-args new AcceptEx-args new
2dup init-accept-buffer 2dup init-accept-buffer
swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket* swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
over handle>> handle>> >>sListenSocket* over handle>> handle>> >>sListenSocket
swap >>port swap >>port
0 >>dwReceiveDataLength* 0 >>dwReceiveDataLength
f >>lpdwBytesReceived* f >>lpdwBytesReceived
(make-overlapped) >>lpOverlapped* ; (make-overlapped) >>lpOverlapped ; inline
: call-AcceptEx ( AcceptEx -- ) : call-AcceptEx ( AcceptEx -- )
AcceptEx-args >tuple*< AcceptEx drop {
winsock-error-string [ throw ] when* ; [ sListenSocket>> ]
[ sAcceptSocket>> ]
[ lpOutputBuffer>> ]
[ dwReceiveDataLength>> ]
[ dwLocalAddressLength>> ]
[ dwRemoteAddressLength>> ]
[ lpdwBytesReceived>> ]
[ lpOverlapped>> ]
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
: extract-remote-address ( AcceptEx -- sockaddr ) : extract-remote-address ( AcceptEx -- sockaddr )
{ {
[ lpOutputBuffer*>> ] [ lpOutputBuffer>> ]
[ dwReceiveDataLength*>> ] [ dwReceiveDataLength>> ]
[ dwLocalAddressLength*>> ] [ dwLocalAddressLength>> ]
[ dwRemoteAddressLength*>> ] [ dwRemoteAddressLength>> ]
} cleave } cleave
f <void*> f <void*>
0 <int> 0 <int>
f <void*> f <void*>
[ 0 <int> GetAcceptExSockaddrs ] keep *void* ; [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
M: object (accept) ( server addr -- handle sockaddr ) M: object (accept) ( server addr -- handle sockaddr )
[ [
@ -100,39 +117,49 @@ M: object (accept) ( server addr -- handle sockaddr )
{ {
[ call-AcceptEx ] [ call-AcceptEx ]
[ wait-for-socket drop ] [ wait-for-socket drop ]
[ sAcceptSocket*>> <win32-socket> ] [ sAcceptSocket>> <win32-socket> ]
[ extract-remote-address ] [ extract-remote-address ]
} cleave } cleave
] with-destructors ; ] with-destructors ;
TUPLE: WSARecvFrom-args port TUPLE: WSARecvFrom-args port
s* lpBuffers* dwBufferCount* lpNumberOfBytesRecvd* s lpBuffers dwBufferCount lpNumberOfBytesRecvd
lpFlags* lpFrom* lpFromLen* lpOverlapped* lpCompletionRoutine* ; lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
: make-receive-buffer ( -- WSABUF ) : make-receive-buffer ( -- WSABUF )
"WSABUF" malloc-object &free "WSABUF" malloc-object &free
default-buffer-size get over set-WSABUF-len default-buffer-size get over set-WSABUF-len
default-buffer-size get malloc &free over set-WSABUF-buf ; default-buffer-size get malloc &free over set-WSABUF-buf ; inline
: <WSARecvFrom-args> ( datagram -- WSARecvFrom ) : <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new WSARecvFrom-args new
swap >>port swap >>port
dup port>> handle>> handle>> >>s* dup port>> handle>> handle>> >>s
dup port>> addr>> sockaddr-type heap-size dup port>> addr>> sockaddr-type heap-size
[ malloc &free >>lpFrom* ] [ malloc &free >>lpFrom ]
[ malloc-int &free >>lpFromLen* ] bi [ malloc-int &free >>lpFromLen ] bi
make-receive-buffer >>lpBuffers* make-receive-buffer >>lpBuffers
1 >>dwBufferCount* 1 >>dwBufferCount
0 malloc-int &free >>lpFlags* 0 malloc-int &free >>lpFlags
0 malloc-int &free >>lpNumberOfBytesRecvd* 0 malloc-int &free >>lpNumberOfBytesRecvd
(make-overlapped) >>lpOverlapped* ; (make-overlapped) >>lpOverlapped ; inline
: call-WSARecvFrom ( WSARecvFrom -- ) : call-WSARecvFrom ( WSARecvFrom -- )
WSARecvFrom-args >tuple*< WSARecvFrom socket-error* ; {
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesRecvd>> ]
[ lpFlags>> ]
[ lpFrom>> ]
[ lpFromLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSARecvFrom socket-error* ; inline
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr ) : parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers*>> WSABUF-buf swap memory>byte-array ] [ lpBuffers>> WSABUF-buf swap memory>byte-array ]
[ [ lpFrom*>> ] [ lpFromLen*>> *int ] bi memory>byte-array ] bi ; [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec ) M: winnt (receive) ( datagram -- packet addrspec )
[ [
@ -144,31 +171,41 @@ M: winnt (receive) ( datagram -- packet addrspec )
] with-destructors ; ] with-destructors ;
TUPLE: WSASendTo-args port TUPLE: WSASendTo-args port
s* lpBuffers* dwBufferCount* lpNumberOfBytesSent* s lpBuffers dwBufferCount lpNumberOfBytesSent
dwFlags* lpTo* iToLen* lpOverlapped* lpCompletionRoutine* ; dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
: make-send-buffer ( packet -- WSABUF ) : make-send-buffer ( packet -- WSABUF )
"WSABUF" malloc-object &free "WSABUF" malloc-object &free
[ >r malloc-byte-array &free r> set-WSABUF-buf ] [ >r malloc-byte-array &free r> set-WSABUF-buf ]
[ >r length r> set-WSABUF-len ] [ >r length r> set-WSABUF-len ]
[ nip ] [ nip ]
2tri ; 2tri ; inline
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo ) : <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new WSASendTo-args new
swap >>port swap >>port
dup port>> handle>> handle>> >>s* dup port>> handle>> handle>> >>s
swap make-sockaddr/size swap make-sockaddr/size
>r malloc-byte-array &free >r malloc-byte-array &free
r> [ >>lpTo* ] [ >>iToLen* ] bi* r> [ >>lpTo ] [ >>iToLen ] bi*
swap make-send-buffer >>lpBuffers* swap make-send-buffer >>lpBuffers
1 >>dwBufferCount* 1 >>dwBufferCount
0 >>dwFlags* 0 >>dwFlags
0 <uint> >>lpNumberOfBytesSent* 0 <uint> >>lpNumberOfBytesSent
(make-overlapped) >>lpOverlapped* ; (make-overlapped) >>lpOverlapped ; inline
: call-WSASendTo ( WSASendTo -- ) : call-WSASendTo ( WSASendTo -- )
WSASendTo-args >tuple*< WSASendTo socket-error* ; {
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesSent>> ]
[ dwFlags>> ]
[ lpTo>> ]
[ iToLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSASendTo socket-error* ; inline
M: winnt (send) ( packet addrspec datagram -- ) M: winnt (send) ( packet addrspec datagram -- )
[ [

1
extra/classes/tuple/lib/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

29
extra/classes/tuple/lib/lib-docs.factor
View File

@ -1,29 +0,0 @@
USING: help.syntax help.markup kernel prettyprint sequences ;
IN: classes.tuple.lib
HELP: >tuple<
{ $values { "class" "a tuple class" } }
{ $description "Explodes the tuple so that tuple slots are on the stack in the order listed in the tuple." }
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"IN: scratchpad"
"TUPLE: foo a b c ;"
"1 2 3 \\ foo boa \\ foo >tuple< .s"
"1\n2\n3"
}
{ $notes "Words using " { $snippet ">tuple<" } " may be compiled." }
{ $see-also >tuple*< } ;
HELP: >tuple*<
{ $values { "class" "a tuple class" } }
{ $description "Explodes the tuple so that tuple slots ending with '*' are on the stack in the order listed in the tuple." }
{ $example
"USING: kernel prettyprint classes.tuple.lib ;"
"IN: scratchpad"
"TUPLE: foo a bb* ccc dddd* ;"
"1 2 3 4 \\ foo boa \\ foo >tuple*< .s"
"2\n4"
}
{ $notes "Words using " { $snippet ">tuple*<" } " may be compiled." }
{ $see-also >tuple< } ;

8
extra/classes/tuple/lib/lib-tests.factor
View File

@ -1,8 +0,0 @@
USING: kernel tools.test classes.tuple.lib ;
IN: classes.tuple.lib.tests
TUPLE: foo a b* c d* e f* ;
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple< ] unit-test
[ 2 4 6 ] [ 1 2 3 4 5 6 \ foo boa \ foo >tuple*< ] unit-test

18
extra/classes/tuple/lib/lib.factor
View File

@ -1,18 +0,0 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros sequences slots words classes.tuple
quotations combinators accessors ;
IN: classes.tuple.lib
: reader-slots ( seq -- quot )
[ reader>> 1quotation ] map [ cleave ] curry ;
MACRO: >tuple< ( class -- )
all-slots rest-slice reader-slots ;
MACRO: >tuple*< ( class -- )
all-slots
[ slot-spec-name "*" tail? ] filter
reader-slots ;