] bi append ;
M: struct make-mirror <struct-mirror> ;
+
+INSTANCE: struct-mirror assoc
USING: assocs math.order sequences ;
IN: compiler.cfg.comparisons
-SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ;
+SYMBOL: +unordered+
+
+SYMBOLS:
+ cc< cc<= cc= cc> cc>= cc<> cc<>=
+ cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
: negate-cc ( cc -- cc' )
H{
- { cc< cc>= }
- { cc<= cc> }
- { cc> cc<= }
- { cc>= cc< }
- { cc= cc/= }
- { cc/= cc= }
+ { cc< cc/< }
+ { cc<= cc/<= }
+ { cc> cc/> }
+ { cc>= cc/>= }
+ { cc= cc/= }
+ { cc<> cc/<> }
+ { cc<>= cc/<>= }
+ { cc/< cc< }
+ { cc/<= cc<= }
+ { cc/> cc> }
+ { cc/>= cc>= }
+ { cc/= cc= }
+ { cc/<> cc<> }
+ { cc/<>= cc<>= }
} at ;
: swap-cc ( cc -- cc' )
H{
- { cc< cc> }
- { cc<= cc>= }
- { cc> cc< }
- { cc>= cc<= }
- { cc= cc= }
- { cc/= cc/= }
+ { cc< cc> }
+ { cc<= cc>= }
+ { cc> cc< }
+ { cc>= cc<= }
+ { cc= cc= }
+ { cc<> cc<> }
+ { cc<>= cc<>= }
+ { cc/< cc/> }
+ { cc/<= cc/>= }
+ { cc/> cc/< }
+ { cc/>= cc/<= }
+ { cc/= cc/= }
+ { cc/<> cc/<> }
+ { cc/<>= cc/<>= }
+ } at ;
+
+: order-cc ( cc -- cc' )
+ H{
+ { cc< cc< }
+ { cc<= cc<= }
+ { cc> cc> }
+ { cc>= cc>= }
+ { cc= cc= }
+ { cc<> cc/= }
+ { cc<>= t }
+ { cc/< cc>= }
+ { cc/<= cc> }
+ { cc/> cc<= }
+ { cc/>= cc< }
+ { cc/= cc/= }
+ { cc/<> cc= }
+ { cc/<>= f }
} at ;
: evaluate-cc ( result cc -- ? )
H{
- { cc< { +lt+ } }
- { cc<= { +lt+ +eq+ } }
- { cc= { +eq+ } }
- { cc>= { +eq+ +gt+ } }
- { cc> { +gt+ } }
- { cc/= { +lt+ +gt+ } }
- } at memq? ;
\ No newline at end of file
+ { cc< { +lt+ } }
+ { cc<= { +lt+ +eq+ } }
+ { cc= { +eq+ } }
+ { cc>= { +eq+ +gt+ } }
+ { cc> { +gt+ } }
+ { cc<> { +lt+ +gt+ } }
+ { cc<>= { +lt+ +eq+ +gt+ } }
+ { cc/< { +eq+ +gt+ +unordered+ } }
+ { cc/<= { +gt+ +unordered+ } }
+ { cc/= { +lt+ +gt+ +unordered+ } }
+ { cc/>= { +lt+ +unordered+ } }
+ { cc/> { +lt+ +eq+ +unordered+ } }
+ { cc/<> { +eq+ +unordered+ } }
+ { cc/<>= { +unordered+ } }
+ } at memq? ;
+
T{ ##load-reference f 1 + }
T{ ##peek f 2 D 0 }
T{ ##compare f 4 2 1 cc<= }
- T{ ##compare f 6 2 1 cc> }
+ T{ ##compare f 6 2 1 cc/<= }
T{ ##replace f 6 D 0 }
}
] [
T{ ##unbox-float f 10 8 }
T{ ##unbox-float f 11 9 }
T{ ##compare-float f 12 10 11 cc< }
- T{ ##compare-float f 14 10 11 cc>= }
+ T{ ##compare-float f 14 10 11 cc/< }
T{ ##replace f 14 D 0 }
}
] [
dst \ t %load-reference
"end" get resolve-label ; inline
-: %boolean ( dst temp cc -- )
- negate-cc {
- { cc< [ \ BLT (%boolean) ] }
- { cc<= [ \ BLE (%boolean) ] }
- { cc> [ \ BGT (%boolean) ] }
- { cc>= [ \ BGE (%boolean) ] }
- { cc= [ \ BEQ (%boolean) ] }
- { cc/= [ \ BNE (%boolean) ] }
+:: %boolean ( dst temp cc -- )
+ cc negate-cc order-cc {
+ { cc< [ dst temp \ BLT (%boolean) ] }
+ { cc<= [ dst temp \ BLE (%boolean) ] }
+ { cc> [ dst temp \ BGT (%boolean) ] }
+ { cc>= [ dst temp \ BGE (%boolean) ] }
+ { cc= [ dst temp \ BEQ (%boolean) ] }
+ { cc/= [ dst temp \ BNE (%boolean) ] }
} case ;
: (%compare) ( src1 src2 -- ) [ 0 ] dip CMP ; inline
M: ppc %compare-imm (%compare-imm) %boolean ;
M: ppc %compare-float (%compare-float) %boolean ;
-: %branch ( label cc -- )
- {
- { cc< [ BLT ] }
- { cc<= [ BLE ] }
- { cc> [ BGT ] }
- { cc>= [ BGE ] }
- { cc= [ BEQ ] }
- { cc/= [ BNE ] }
+:: %branch ( label cc -- )
+ cc order-cc {
+ { cc< [ label BLT ] }
+ { cc<= [ label BLE ] }
+ { cc> [ label BGT ] }
+ { cc>= [ label BGE ] }
+ { cc= [ label BEQ ] }
+ { cc/= [ label BNE ] }
} case ;
M: ppc %compare-branch (%compare) %branch ;
temp 0 MOV \ t rc-absolute-cell rel-immediate
dst temp word execute ; inline
-M: x86 %compare ( dst temp cc src1 src2 -- )
- CMP {
- { cc< [ \ CMOVL %boolean ] }
- { cc<= [ \ CMOVLE %boolean ] }
- { cc> [ \ CMOVG %boolean ] }
- { cc>= [ \ CMOVGE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
+M:: x86 %compare ( dst temp cc src1 src2 -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ dst temp \ CMOVL %boolean ] }
+ { cc<= [ dst temp \ CMOVLE %boolean ] }
+ { cc> [ dst temp \ CMOVG %boolean ] }
+ { cc>= [ dst temp \ CMOVGE %boolean ] }
+ { cc= [ dst temp \ CMOVE %boolean ] }
+ { cc/= [ dst temp \ CMOVNE %boolean ] }
} case ;
M: x86 %compare-imm ( dst temp cc src1 src2 -- )
%compare ;
-M: x86 %compare-float ( dst temp cc src1 src2 -- )
- UCOMISD {
- { cc< [ \ CMOVB %boolean ] }
- { cc<= [ \ CMOVBE %boolean ] }
- { cc> [ \ CMOVA %boolean ] }
- { cc>= [ \ CMOVAE %boolean ] }
- { cc= [ \ CMOVE %boolean ] }
- { cc/= [ \ CMOVNE %boolean ] }
+: %cmov-float= ( dst src -- )
+ [
+ "no-move" define-label
+
+ "no-move" get [ JNE ] [ JP ] bi
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
+
+: %cmov-float/= ( dst src -- )
+ [
+ "no-move" define-label
+ "move" define-label
+
+ "move" get JP
+ "no-move" get JE
+ "move" resolve-label
+ MOV
+ "no-move" resolve-label
+ ] with-scope ;
+
+M:: x86 %compare-float ( dst temp cc src1 src2 -- )
+ cc {
+ { cc< [ src2 src1 UCOMISD dst temp \ CMOVA %boolean ] }
+ { cc<= [ src2 src1 UCOMISD dst temp \ CMOVAE %boolean ] }
+ { cc> [ src1 src2 UCOMISD dst temp \ CMOVA %boolean ] }
+ { cc>= [ src1 src2 UCOMISD dst temp \ CMOVAE %boolean ] }
+ { cc= [ src1 src2 COMISD dst temp \ %cmov-float= %boolean ] }
+ { cc<> [ src1 src2 UCOMISD dst temp \ CMOVNE %boolean ] }
+ { cc<>= [ src1 src2 UCOMISD dst temp \ CMOVNP %boolean ] }
+ { cc/< [ src2 src1 COMISD dst temp \ CMOVBE %boolean ] }
+ { cc/<= [ src2 src1 COMISD dst temp \ CMOVB %boolean ] }
+ { cc/> [ src1 src2 COMISD dst temp \ CMOVBE %boolean ] }
+ { cc/>= [ src1 src2 COMISD dst temp \ CMOVB %boolean ] }
+ { cc/= [ src1 src2 COMISD dst temp \ %cmov-float/= %boolean ] }
+ { cc/<> [ src1 src2 COMISD dst temp \ CMOVE %boolean ] }
+ { cc/<>= [ src1 src2 COMISD dst temp \ CMOVP %boolean ] }
} case ;
-M: x86 %compare-branch ( label cc src1 src2 -- )
- CMP {
- { cc< [ JL ] }
- { cc<= [ JLE ] }
- { cc> [ JG ] }
- { cc>= [ JGE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+M:: x86 %compare-branch ( label cc src1 src2 -- )
+ src1 src2 CMP
+ cc order-cc {
+ { cc< [ label JL ] }
+ { cc<= [ label JLE ] }
+ { cc> [ label JG ] }
+ { cc>= [ label JGE ] }
+ { cc= [ label JE ] }
+ { cc/= [ label JNE ] }
} case ;
M: x86 %compare-imm-branch ( label src1 src2 cc -- )
%compare-branch ;
-M: x86 %compare-float-branch ( label cc src1 src2 -- )
- UCOMISD {
- { cc< [ JB ] }
- { cc<= [ JBE ] }
- { cc> [ JA ] }
- { cc>= [ JAE ] }
- { cc= [ JE ] }
- { cc/= [ JNE ] }
+: %jump-float= ( label -- )
+ [
+ "no-jump" define-label
+ "no-jump" get JP
+ JE
+ "no-jump" resolve-label
+ ] with-scope ;
+
+: %jump-float/= ( label -- )
+ [ JNE ] [ JP ] bi ;
+
+M:: x86 %compare-float-branch ( label cc src1 src2 -- )
+ cc {
+ { cc< [ src2 src1 UCOMISD label JA ] }
+ { cc<= [ src2 src1 UCOMISD label JAE ] }
+ { cc> [ src1 src2 UCOMISD label JA ] }
+ { cc>= [ src1 src2 UCOMISD label JAE ] }
+ { cc= [ src1 src2 COMISD label %jump-float= ] }
+ { cc<> [ src1 src2 UCOMISD label JNE ] }
+ { cc<>= [ src1 src2 UCOMISD label JNP ] }
+ { cc/< [ src2 src1 COMISD label JBE ] }
+ { cc/<= [ src2 src1 COMISD label JB ] }
+ { cc/> [ src1 src2 COMISD label JBE ] }
+ { cc/>= [ src1 src2 COMISD label JB ] }
+ { cc/= [ src1 src2 COMISD label %jump-float/= ] }
+ { cc/<> [ src1 src2 COMISD label JE ] }
+ { cc/<>= [ src1 src2 COMISD label JP ] }
} case ;
M: x86 %spill ( src n rep -- ) [ spill@ swap ] dip copy-register ;
io.streams.c io.streams.null libc kernel math namespaces sequences
threads windows windows.errors windows.kernel32 strings splitting
ascii system accessors locals classes.struct combinators.short-circuit ;
-QUALIFIED: windows.winsock
IN: io.backend.windows.nt
! Global variable with assoc mapping overlapped to threads
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
- H{ } clone pending-overlapped set-global
- windows.winsock:init-winsock ;
+ H{ } clone pending-overlapped set-global ;
ERROR: invalid-file-size n ;
USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.binary io.timeouts system
strings kernel math namespaces sequences windows.errors
-windows.kernel32 windows.shell32 windows.types windows.winsock
-splitting continuations math.bitwise accessors init sets assocs
+windows.kernel32 windows.shell32 windows.types splitting
+continuations math.bitwise accessors init sets assocs
classes.struct classes ;
IN: io.backend.windows
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel namespaces continuations
-destructors io debugger io.sockets sequences summary calendar
-delegate system vocabs.loader combinators present ;
+USING: accessors kernel namespaces continuations destructors io
+debugger io.sockets io.sockets.private sequences summary
+calendar delegate system vocabs.loader combinators present ;
IN: io.sockets.secure
SYMBOL: secure-socket-timeout
! Copyright (C) 2007, 2008, Slava Pestov, Elie CHAFTARI.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors unix byte-arrays kernel sequences
-namespaces math math.order combinators init alien alien.c-types
+USING: accessors unix byte-arrays kernel sequences namespaces
+math math.order combinators init alien alien.c-types
alien.strings libc continuations destructors openssl
openssl.libcrypto openssl.libssl io io.files io.ports
io.backend.unix io.sockets.unix io.encodings.ascii io.buffers
-io.sockets io.sockets.secure io.sockets.secure.openssl
-io.timeouts system summary fry ;
+io.sockets io.sockets.private io.sockets.secure
+io.sockets.secure.openssl io.timeouts system summary fry ;
FROM: io.ports => shutdown ;
IN: io.sockets.secure.unix
IN: io.sockets.tests
-USING: io.sockets sequences math tools.test namespaces accessors
-kernel destructors calendar io.timeouts io.encodings.utf8 io
-concurrency.promises threads io.streams.string ;
+USING: io.sockets io.sockets.private sequences math tools.test
+namespaces accessors kernel destructors calendar io.timeouts
+io.encodings.utf8 io concurrency.promises threads
+io.streams.string ;
[ B{ 1 2 3 4 } ]
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
} cond use-vocab >>
! Addressing
+<PRIVATE
+
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
-TUPLE: local path ;
+HOOK: sockaddr-of-family os ( alien af -- sockaddr )
-: <local> ( path -- addrspec )
- normalize-path local boa ;
+HOOK: addrspec-of-family os ( af -- addrspec )
-M: local present path>> "Unix domain socket: " prepend ;
+PRIVATE>
TUPLE: abstract-inet host port ;
M: abstract-inet present
[ host>> ":" ] [ port>> number>string ] bi 3append ;
+TUPLE: local path ;
+
+: <local> ( path -- addrspec )
+ normalize-path local boa ;
+
+M: local present path>> "Unix domain socket: " prepend ;
+
TUPLE: inet4 < abstract-inet ;
C: <inet4> inet4
[ [ addr>> ] dip inet-ntop ]
[ drop port>> ntohs ] 2bi <inet6> ;
-: addrspec-of-family ( af -- addrspec )
- {
- { AF_INET [ T{ inet4 } ] }
- { AF_INET6 [ T{ inet6 } ] }
- { AF_UNIX [ T{ local } ] }
- [ drop f ]
- } case ;
-
-: sockaddr-of-family ( af -- addrspec )
- {
- { AF_INET [ sockaddr-in ] }
- { AF_INET6 [ sockaddr-in6 ] }
- { AF_UNIX [ sockaddr-un ] }
- [ drop f ]
- } case ;
-
M: f parse-sockaddr nip ;
+<PRIVATE
+
GENERIC: (get-local-address) ( handle remote -- sockaddr )
: get-local-address ( handle remote -- local )
2bi
] with-destructors ;
+TUPLE: server-port < port addr encoding ;
+
+: check-server-port ( port -- port )
+ dup check-disposed
+ dup server-port? [ "Not a server port" throw ] unless ; inline
+
+GENERIC: (server) ( addrspec -- handle )
+
+GENERIC: (accept) ( server addrspec -- handle sockaddr )
+
+TUPLE: datagram-port < port addr ;
+
+HOOK: (datagram) io-backend ( addr -- datagram )
+
+: check-datagram-port ( port -- port )
+ dup check-disposed
+ dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
+
+HOOK: (receive) io-backend ( datagram -- packet addrspec )
+
+: check-datagram-send ( packet addrspec port -- packet addrspec port )
+ check-datagram-port
+ 2dup addr>> [ class ] bi@ assert=
+ pick class byte-array assert= ;
+
+HOOK: (send) io-backend ( packet addrspec datagram -- )
+
+: addrinfo>addrspec ( addrinfo -- addrspec )
+ [ [ addr>> ] [ family>> ] bi sockaddr-of-family ]
+ [ family>> addrspec-of-family ] bi
+ parse-sockaddr ;
+
+: parse-addrinfo-list ( addrinfo -- seq )
+ [ next>> dup [ addrinfo memory>struct ] when ] follow
+ [ addrinfo>addrspec ] map
+ sift ;
+
+HOOK: addrinfo-error io-backend ( n -- )
+
+: resolve-passive-host ( -- addrspecs )
+ { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
+
+: prepare-addrinfo ( -- addrinfo )
+ addrinfo <struct>
+ PF_UNSPEC >>family
+ IPPROTO_TCP >>protocol ;
+
+: fill-in-ports ( addrspecs port -- addrspecs )
+ '[ _ >>port ] map ;
+
+PRIVATE>
+
: <client> ( remote encoding -- stream local )
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
] dip with-stream
] with-scope ; inline
-TUPLE: server-port < port addr encoding ;
-
-: check-server-port ( port -- port )
- dup check-disposed
- dup server-port? [ "Not a server port" throw ] unless ; inline
-
-GENERIC: (server) ( addrspec -- handle )
-
: <server> ( addrspec encoding -- server )
[
[ (server) ] keep
>>addr
] dip >>encoding ;
-GENERIC: (accept) ( server addrspec -- handle sockaddr )
-
: accept ( server -- client remote )
[
dup addr>>
<ports>
] keep encoding>> <encoder-duplex> swap ;
-TUPLE: datagram-port < port addr ;
-
-HOOK: (datagram) io-backend ( addr -- datagram )
-
: <datagram> ( addrspec -- datagram )
[
[ (datagram) |dispose ] keep
>>addr
] with-destructors ;
-: check-datagram-port ( port -- port )
- dup check-disposed
- dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
-
-HOOK: (receive) io-backend ( datagram -- packet addrspec )
-
: receive ( datagram -- packet addrspec )
check-datagram-port
[ (receive) ] [ addr>> ] bi parse-sockaddr ;
-: check-datagram-send ( packet addrspec port -- packet addrspec port )
- check-datagram-port
- 2dup addr>> [ class ] bi@ assert=
- pick class byte-array assert= ;
-
-HOOK: (send) io-backend ( packet addrspec datagram -- )
-
: send ( packet addrspec datagram -- )
check-datagram-send (send) ;
-: addrinfo>addrspec ( addrinfo -- addrspec )
- [ [ addr>> ] [ family>> sockaddr-of-family ] bi memory>struct ]
- [ family>> addrspec-of-family ] bi
- parse-sockaddr ;
-
-: parse-addrinfo-list ( addrinfo -- seq )
- [ next>> dup [ addrinfo memory>struct ] when ] follow
- [ addrinfo>addrspec ] map
- sift ;
-
-HOOK: addrinfo-error io-backend ( n -- )
-
GENERIC: resolve-host ( addrspec -- seq )
TUPLE: inet < abstract-inet ;
C: <inet> inet
-: resolve-passive-host ( -- addrspecs )
- { T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
-
-: prepare-addrinfo ( -- addrinfo )
- addrinfo <struct>
- PF_UNSPEC >>family
- IPPROTO_TCP >>protocol ;
-
-: fill-in-ports ( addrspecs port -- addrspecs )
- '[ _ >>port ] map ;
-
M: inet resolve-host
[ port>> ] [ host>> ] bi [
f prepare-addrinfo f <void*>
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings generic kernel math threads
-sequences byte-arrays io.binary io.backend.unix io.streams.duplex
-io.backend io.pathnames io.files.private io.encodings.utf8 math.parser
-continuations libc combinators system accessors destructors unix
-locals init classes.struct ;
+USING: alien alien.c-types alien.strings generic kernel math
+threads sequences byte-arrays io.binary io.backend.unix
+io.streams.duplex io.backend io.pathnames io.sockets.private
+io.files.private io.encodings.utf8 math.parser continuations
+libc combinators system accessors destructors unix locals init
+classes.struct ;
EXCLUDE: namespaces => bind ;
EXCLUDE: io => read write ;
M: unix addrinfo-error ( n -- )
[ gai_strerror throw ] unless-zero ;
+M: unix sockaddr-of-family ( alien af -- addrspec )
+ {
+ { AF_INET [ sockaddr-in memory>struct ] }
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }
+ { AF_UNIX [ sockaddr-un memory>struct ] }
+ [ 2drop f ]
+ } case ;
+
+M: unix addrspec-of-family ( af -- addrspec )
+ {
+ { AF_INET [ T{ inet4 } ] }
+ { AF_INET6 [ T{ inet6 } ] }
+ { AF_UNIX [ T{ local } ] }
+ [ drop f ]
+ } case ;
+
! Client sockets - TCP and Unix domain
M: object (get-local-address) ( handle remote -- sockaddr )
[ handle-fd ] dip empty-sockaddr/size <int>
[ packet-size malloc receive-buffer set-global ] "io.sockets.unix" add-init-hook
:: do-receive ( port -- packet sockaddr )
- port addr>> empty-sockaddr/size [| sockaddr len |
- port handle>> handle-fd ! s
- receive-buffer get-global ! buf
- packet-size ! nbytes
- 0 ! flags
- sockaddr ! from
- len <int> ! fromlen
- recvfrom dup 0 >= [
- receive-buffer get-global swap memory>byte-array sockaddr
- ] [
- drop f f
- ] if
- ] call ;
+ port addr>> empty-sockaddr/size :> len :> sockaddr
+ port handle>> handle-fd ! s
+ receive-buffer get-global ! buf
+ packet-size ! nbytes
+ 0 ! flags
+ sockaddr ! from
+ len <int> ! fromlen
+ recvfrom dup 0 >=
+ [ receive-buffer get-global swap memory>byte-array sockaddr ]
+ [ drop f f ]
+ if ;
M: unix (receive) ( datagram -- packet sockaddr )
dup do-receive dup [ [ drop ] 2dip ] [
USING: alien alien.accessors alien.c-types byte-arrays
continuations destructors io.ports io.timeouts io.sockets
-io namespaces io.streams.duplex io.backend.windows
-io.sockets.windows io.backend.windows.nt windows.winsock kernel
-libc math sequences threads system combinators accessors
-classes.struct windows.kernel32 ;
+io.sockets.private io namespaces io.streams.duplex
+io.backend.windows io.sockets.windows io.backend.windows.nt
+windows.winsock kernel libc math sequences threads system
+combinators accessors classes.struct windows.kernel32 ;
IN: io.sockets.windows.nt
-: malloc-int ( object -- object )
- "int" heap-size malloc [ nip ] [ 0 set-alien-signed-4 ] 2bi ; inline
+: malloc-int ( n -- alien )
+ <int> malloc-byte-array ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
+ f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
+
: extract-remote-address ( AcceptEx -- sockaddr )
- {
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- } cleave
- f <void*>
- 0 <int>
- f <void*>
- [ 0 <int> GetAcceptExSockaddrs ] keep *void* ; inline
+ [
+ {
+ [ lpOutputBuffer>> ]
+ [ dwReceiveDataLength>> ]
+ [ dwLocalAddressLength>> ]
+ [ dwRemoteAddressLength>> ]
+ } cleave
+ (extract-remote-address)
+ ] [ port>> addr>> protocol-family ] bi
+ sockaddr-of-family ; inline
M: object (accept) ( server addr -- handle sockaddr )
[
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers>> buf>> swap memory>byte-array ]
- [ [ lpFrom>> ] [ lpFromLen>> *int ] bi memory>byte-array ] bi ; inline
+ [
+ [ port>> addr>> empty-sockaddr dup ]
+ [ lpFrom>> ]
+ [ lpFromLen>> *int ]
+ tri memcpy
+ ] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
[
-USING: kernel accessors io.sockets io.backend.windows io.backend\r
-windows.winsock system destructors alien.c-types ;\r
+USING: kernel accessors io.sockets io.sockets.private\r
+io.backend.windows io.backend windows.winsock system destructors\r
+alien.c-types classes.struct combinators ;\r
IN: io.sockets.windows\r
\r
+M: windows addrinfo-error ( n -- )\r
+ winsock-return-check ;\r
+\r
+M: windows sockaddr-of-family ( alien af -- addrspec )\r
+ {\r
+ { AF_INET [ sockaddr-in memory>struct ] }\r
+ { AF_INET6 [ sockaddr-in6 memory>struct ] }\r
+ [ 2drop f ]\r
+ } case ;\r
+\r
+M: windows addrspec-of-family ( af -- addrspec )\r
+ {\r
+ { AF_INET [ T{ inet4 } ] }\r
+ { AF_INET6 [ T{ inet6 } ] }\r
+ [ drop f ]\r
+ } case ;\r
+\r
HOOK: WSASocket-flags io-backend ( -- DWORD )\r
\r
TUPLE: win32-socket < win32-file ;\r
handle>> closesocket drop ;\r
\r
: unspecific-sockaddr/size ( addrspec -- sockaddr len )\r
- [ empty-sockaddr/size ] [ protocol-family ] bi\r
- pick set-sockaddr-in-family ;\r
+ [ empty-sockaddr/size ] [ protocol-family ] bi pick (>>family) ;\r
\r
: opened-socket ( handle -- win32-socket )\r
<win32-socket> |dispose dup add-completion ;\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
-\r
-M: windows addrinfo-error ( n -- )\r
- winsock-return-check ;\r
dup length zero? not [ rest ] [ drop f ] if ;
: (match-first) ( seq pattern-seq -- bindings leftover/f )
- 2dup [ length ] bi@ < [ 2drop f f ]
- [
+ 2dup shorter? [ 2drop f f ] [
2dup length head over match
- [ nip swap ?1-tail ] [ [ rest ] dip (match-first) ] if*
+ [ swap ?1-tail ] [ [ rest ] dip (match-first) ] ?if
] if ;
: match-first ( seq pattern-seq -- bindings )
: (match-all) ( seq pattern-seq -- )
[ nip ] [ (match-first) swap ] 2bi
- [
- , [ swap (match-all) ] [ drop ] if*
- ] [ 2drop ] if* ;
+ [ , [ swap (match-all) ] [ drop ] if* ] [ 2drop ] if* ;
: match-all ( seq pattern-seq -- bindings-seq )
[ (match-all) ] { } make ;
-
! Copyright (C) 2006 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax arrays
-byte-arrays kernel math sequences windows.types windows.kernel32
-windows.errors math.bitwise io.encodings.utf16n classes.struct
-literals windows.com.syntax ;
+byte-arrays kernel literals math sequences windows.types
+windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
+classes.struct windows.com.syntax init ;
IN: windows.winsock
-USE: libc
-: alien>byte-array ( alien str -- byte-array )
- heap-size dup <byte-array> [ -rot memcpy ] keep ;
-
TYPEDEF: void* SOCKET
: <wsadata> ( -- byte-array )
CONSTANT: SO_USELOOPBACK HEX: 40
CONSTANT: SO_LINGER HEX: 80
CONSTANT: SO_OOBINLINE HEX: 100
-CONSTANT: SO_DONTLINGER $[ SO_LINGER bitnot ]
+: SO_DONTLINGER ( -- n ) SO_LINGER bitnot ; inline
CONSTANT: SO_SNDBUF HEX: 1001
CONSTANT: SO_RCVBUF HEX: 1002
CONSTANT: AI_PASSIVE 1
CONSTANT: AI_CANONNAME 2
CONSTANT: AI_NUMERICHOST 4
-CONSTANT: AI_MASK $[ { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ]
+
+: AI_MASK ( -- n )
+ { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
CONSTANT: NI_NUMERICHOST 1
CONSTANT: NI_NUMERICSERV 2
CONSTANT: INADDR_ANY 0
-CONSTANT: INVALID_SOCKET $[ -1 <alien> ]
+: INVALID_SOCKET ( -- n ) -1 <alien> ; inline
+
CONSTANT: SOCKET_ERROR -1
CONSTANT: SD_RECV 0
CONSTANT: SOL_SOCKET HEX: ffff
-! TYPEDEF: uint in_addr_t
-! C-STRUCT: in_addr
- ! { "in_addr_t" "s_addr" } ;
-
STRUCT: sockaddr-in
{ family short }
{ port ushort }
! Not in Windows CE
FUNCTION: int AcceptEx ( void* listen, void* accept, void* out-buf, int recv-len, int addr-len, int remote-len, void* out-len, void* overlapped ) ;
-FUNCTION: void GetAcceptExSockaddrs ( void* a, int b, int c, int d, void* e, void* f, void* g, void* h ) ;
+
+FUNCTION: void GetAcceptExSockaddrs (
+ PVOID lpOutputBuffer,
+ DWORD dwReceiveDataLength,
+ DWORD dwLocalAddressLength,
+ DWORD dwRemoteAddressLength,
+ LPSOCKADDR* LocalSockaddr,
+ LPINT LocalSockaddrLength,
+ LPSOCKADDR* RemoteSockaddr,
+ LPINT RemoteSockaddrLength
+) ;
CONSTANT: SIO_GET_EXTENSION_FUNCTION_POINTER -939524090
: init-winsock ( -- )
HEX: 0202 <wsadata> WSAStartup winsock-return-check ;
+
+[ init-winsock ] "windows.winsock" add-init-hook
[ -0.0 ] [ 0.0 prev-float ] unit-test
[ t ] [ 1.0 dup prev-float > ] unit-test
[ t ] [ -1.0 dup prev-float > ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 0/0. 1.0 = ] unit-test
+[ f ] [ 0/0. 1/0. = ] unit-test
+[ f ] [ 0/0. -1/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. = ] unit-test
+[ f ] [ 1.0 0/0. = ] unit-test
+[ f ] [ -1/0. 0/0. = ] unit-test
+[ f ] [ 1/0. 0/0. = ] unit-test
+
+[ f ] [ 0/0. 0/0. < ] unit-test
+[ f ] [ 0/0. 1.0 < ] unit-test
+[ f ] [ 0/0. 1/0. < ] unit-test
+[ f ] [ 0/0. -1/0. < ] unit-test
+
+[ f ] [ 0/0. 0/0. <= ] unit-test
+[ f ] [ 0/0. 1.0 <= ] unit-test
+[ f ] [ 0/0. 1/0. <= ] unit-test
+[ f ] [ 0/0. -1/0. <= ] unit-test
+
+[ f ] [ 0/0. 0/0. > ] unit-test
+[ f ] [ 1.0 0/0. > ] unit-test
+[ f ] [ -1/0. 0/0. > ] unit-test
+[ f ] [ 1/0. 0/0. > ] unit-test
+
+[ f ] [ 0/0. 0/0. >= ] unit-test
+[ f ] [ 1.0 0/0. >= ] unit-test
+[ f ] [ -1/0. 0/0. >= ] unit-test
+[ f ] [ 1/0. 0/0. >= ] unit-test
+
+
combinators ;
IN: opengl.glu
+<<
+
os {
{ [ dup macosx? ] [ drop ] }
{ [ dup windows? ] [ drop ] }
{ [ dup unix? ] [ drop "glu" "libGLU.so.1" "cdecl" add-library ] }
} cond
+>>
+
LIBRARY: glu
! These are defined as structs in glu.h, but we only ever use pointers to them