Win32 sockets support

library/bootstrap/boot-stage2.factor

@@ -165,8 +165,10 @@ os "win32" = [
         "/library/io/buffer.factor"
         "/library/win32/win32-io.factor"
         "/library/win32/win32-errors.factor"
+        "/library/win32/winsock.factor"
         "/library/io/win32-io-internals.factor"
         "/library/io/win32-stream.factor"
+        "/library/io/win32-server.factor"
         "/library/io/win32-console.factor"
     ] [
         dup print

library/bootstrap/init-stage2.factor

@@ -118,7 +118,11 @@ os "win32" = "compile" get and [
     "kernel32" "kernel32.dll" "stdcall" add-library
     "user32"   "user32.dll"   "stdcall" add-library
     "gdi32"    "gdi32.dll"    "stdcall" add-library
+    "winsock"  "ws2_32.dll"   "stdcall" add-library
+    "mswsock"  "mswsock.dll"  "stdcall" add-library
     "libc"     "msvcrt.dll"   "cdecl"   add-library
+    "sdl"      "SDL.dll"      "cdecl"   add-library
+    "sdl-gfx"  "SDL_gfx.dll"  "cdecl"   add-library
 ] when
 
 ! FIXME: KLUDGE to get FFI-based IO going in Windows.

library/bootstrap/win32-io.factor

@@ -54,6 +54,7 @@ USE: win32-api
 
 : <filecr> <win32-filecr> ;
 : <filecw> <win32-filecw> ;
+: <server> <win32-server> ;
 
 : init-stdio ( -- )
     win32-init-stdio ;

library/compiler/alien-types.factor

@@ -79,6 +79,9 @@ USE: words
         ] ifte
     ] bind ;
 
+: size ( name -- size )
+    c-type [ "width" get ] bind ;
+
 : define-c-type ( quot name -- )
     c-types [ >r <c-type> swap extend r> set ] bind ; inline
 

library/io/io-internals.factor

@@ -76,3 +76,5 @@ BUILTIN: port 14
 : blocking-copy ( in out -- )
     [ add-copy-io-task (yield) ] callcc0
     pending-io-error pending-io-error ;
+
+

library/io/network.factor

@@ -37,6 +37,7 @@ USE: unparser
 USE: generic
 
 TRAITS: server
+GENERIC: accept
 
 M: server fclose ( stream -- )
     [ "socket" get close-port ] bind ;
@@ -54,6 +55,7 @@ C: server ( port -- stream )
     #! fflush yields until connection is established.
     2dup client-socket <client-stream> dup fflush ;
 
-: accept ( server -- client )
+M: server accept ( server -- client )
     #! Accept a connection from a server socket.
     "socket" swap hash blocking-accept <client-stream> ;
+

library/io/win32-server.factor

@@ -0,0 +1,114 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: win32-stream
+USE: alien
+USE: errors
+USE: generic
+USE: kernel
+USE: kernel-internals
+USE: lists
+USE: math
+USE: namespaces
+USE: prettyprint
+USE: stdio
+USE: streams
+USE: strings
+USE: threads
+USE: unparser
+USE: win32-api
+USE: win32-io-internals
+
+TRAITS: win32-server
+SYMBOL: winsock
+SYMBOL: socket
+
+: maybe-init-winsock ( -- )
+    winsock get [
+        HEX: 0202 <wsadata> WSAStartup drop winsock on
+    ] unless ;
+
+: handle-socket-error ( -- )
+    WSAGetLastError [
+      ERROR_IO_PENDING ERROR_SUCCESS
+    ] contains? [
+      win32-error-message throw 
+    ] unless ;
+
+: new-socket ( -- socket )
+    AF_INET SOCK_STREAM 0 NULL NULL WSA_FLAG_OVERLAPPED WSASocket ;
+
+: setup-sockaddr ( port -- sockaddr )
+    <sockaddr-in> swap
+    htons over set-sockaddr-in-port
+    INADDR_ANY over set-sockaddr-in-addr 
+    AF_INET over set-sockaddr-in-family ;
+
+: bind-socket ( port socket -- )
+    swap setup-sockaddr "sockaddr-in" size wsa-bind 0 = [
+        handle-socket-error
+    ] unless ;
+
+: listen-socket ( socket -- )
+    20 wsa-listen 0 = [ handle-socket-error ] unless ;
+
+: <win32-client-stream> ( buf stream -- stream )
+    [ 
+        buffer-ptr <alien> 0 32 32 
+        <sockaddr-in> dup >r <indirect-pointer> <sockaddr-in> dup >r over 
+        GetAcceptExSockaddrs r> r> drop
+        dup sockaddr-in-port ntohs swap sockaddr-in-addr inet-ntoa
+        [ , ":" , unparse , ] make-string "client" set
+    ] extend ;
+
+C: win32-server ( port -- server )
+    [ 
+        maybe-init-winsock new-socket swap over bind-socket dup listen-socket 
+        dup completion-port get NULL 1 CreateIoCompletionPort drop
+        socket set
+    ] extend ;
+
+M: win32-server fclose ( server -- )
+    [ socket get CloseHandle drop ] bind ;
+
+M: win32-server accept ( server -- client )
+    [
+        [
+            new-socket "ns" set 1024 <buffer> "buf" set
+            [
+                alloc-io-task init-overlapped >r
+                socket get "ns" get "buf" get buffer-ptr <alien> 0
+                "sockaddr-in" size 16 + dup NULL r> AcceptEx
+                [ handle-socket-error ] unless (yield)
+            ] callcc0
+            "buf" get "ns" get 
+            dup completion-port get NULL 1 CreateIoCompletionPort drop
+            <win32-stream> <win32-client-stream>
+            "buf" get buffer-free
+        ] with-scope
+    ] bind ;
+

library/io/win32-stream.factor

@@ -54,7 +54,7 @@ SYMBOL: file-size
 : init-overlapped ( overlapped -- overlapped )
     0 over set-overlapped-ext-internal
     0 over set-overlapped-ext-internal-high
-    fileptr get over set-overlapped-ext-offset
+    fileptr get dup 0 ? over set-overlapped-ext-offset
     0 over set-overlapped-ext-offset-high
     0 over set-overlapped-ext-event ;
 

library/sdl/console.factor

@@ -252,7 +252,7 @@ SYMBOL: escape-continuation
 
 : start-console ( -- )
     <namespace> [
-        640 480 32 SDL_HWSURFACE init-screen
+        800 600 32 SDL_HWSURFACE init-screen
         init-console
     ] extend console set
 

library/threads.factor

@@ -30,6 +30,7 @@ USE: io-internals
 USE: kernel
 USE: kernel-internals
 USE: lists
+USE: namespaces
 
 ! Core of the multitasker. Used by io-internals.factor and
 ! in-thread.factor.

library/win32/winsock.factor

@@ -0,0 +1,86 @@
+! :folding=indent:collapseFolds=1:
+
+! $Id$
+!
+! Copyright (C) 2004 Slava Pestov.
+! 
+! Redistribution and use in source and binary forms, with or without
+! modification, are permitted provided that the following conditions are met:
+! 
+! 1. Redistributions of source code must retain the above copyright notice,
+!    this list of conditions and the following disclaimer.
+! 
+! 2. Redistributions in binary form must reproduce the above copyright notice,
+!    this list of conditions and the following disclaimer in the documentation
+!    and/or other materials provided with the distribution.
+! 
+! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
+! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
+! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
+! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
+! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+IN: win32-api
+USE: alien
+USE: kernel
+
+: <wsadata> HEX: 190 <local-alien> ;
+
+: AF_INET 2 ;
+: SOCK_STREAM 1 ;
+: WSA_FLAG_OVERLAPPED 1 ;
+: INADDR_ANY 0 ;
+
+BEGIN-STRUCT: sockaddr-in
+    FIELD: short family
+    FIELD: short port
+    FIELD: int addr
+    FIELD: char pad
+    FIELD: char pad
+    FIELD: char pad
+    FIELD: char pad
+    FIELD: char pad
+    FIELD: char pad
+    FIELD: char pad
+    FIELD: char pad
+END-STRUCT
+
+: WSAStartup ( version out-data -- int )
+    "int" "winsock" "WSAStartup" [ "short" "void*" ] alien-invoke ;
+
+: WSASocket ( af type protocol protocol-info g flags -- socket )
+    "void*" "winsock" "WSASocketA" [ "int" "int" "int" "void*" "void*" "int" ]
+    alien-invoke ;
+
+: htons ( short -- short ) 
+    "short" "winsock" "htons" [ "short" ] alien-invoke ;
+
+: ntohs ( short -- short )
+    "short" "winsock" "ntohs" [ "short" ] alien-invoke ;
+
+: wsa-bind ( socket sockaddr len -- status )
+    "int" "winsock" "bind" [ "void*" "sockaddr-in*" "int" ] alien-invoke ;
+
+: wsa-listen ( socket backlog -- status )
+    "int" "winsock" "listen" [ "void*" "int" ] alien-invoke ;
+
+: WSAGetLastError ( -- error )
+    "int" "winsock" "WSAGetLastError" [ ] alien-invoke ;
+
+: inet-ntoa ( in-addr -- str )
+    "char*" "winsock" "inet_ntoa" [ "int" ] alien-invoke ; 
+
+: AcceptEx 
+( listen accept out-buf recv-len addr-len remote-len out-len overlapped -- ? )
+    "bool" "mswsock" "AcceptEx"
+    [ "void*" "void*" "void*" "int" "int" "int" "void*" "void*" ]
+    alien-invoke ;
+
+: GetAcceptExSockaddrs ( stack effect is too long to put here -- )
+    "void" "mswsock" "GetAcceptExSockaddrs"
+    [ "void*" "int" "int" "int" "void*" "void*" "void*" "void*" ] alien-invoke ;

native/error.c

@@ -43,6 +43,7 @@ void early_error(CELL error)
 		else if(type_of(error) == STRING_TYPE)
 			fprintf(stderr,"Error: %s\n",to_c_string(untag_string(error)));
 		fflush(stderr);
+
 		exit(1);
 	}
 }