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 -- )
+:: %boolean ( dst temp cc -- )
cc negate-cc order-cc {
{ cc< [ dst temp \ BLT f (%boolean) ] }
{ cc<= [ dst temp \ BLE f (%boolean) ] }
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 ;
\r
: make-token-privileges ( name ? -- obj )\r
"TOKEN_PRIVILEGES" <c-object>\r
- 1 [ over set-TOKEN_PRIVILEGES-PrivilegeCount ] keep\r
- "LUID_AND_ATTRIBUTES" malloc-array &free\r
+ 1 over set-TOKEN_PRIVILEGES-PrivilegeCount\r
+ "LUID_AND_ATTRIBUTES" malloc-object &free\r
over set-TOKEN_PRIVILEGES-Privileges\r
\r
swap [\r
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
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
- dup class heap-size >>nLength ;
+ SECURITY_ATTRIBUTES heap-size >>nLength ;
! 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
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
projects / factor.git / commitdiff