Win32 sockets support

diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor
index 039633bafcfbce3406fcc20a25115c0c9353cc4b..a7b4c477dbe1fd8f5c7db791ebc4c175f530cd40 100644 (file)
--- a/library/bootstrap/boot-stage2.factor
+++ b/library/bootstrap/boot-stage2.factor
@@ -165,8 +165,10 @@ os "win32" = [
         "/library/io/buffer.factor"\r
         "/library/win32/win32-io.factor"\r
         "/library/win32/win32-errors.factor"\r
+        "/library/win32/winsock.factor"
         "/library/io/win32-io-internals.factor"\r
         "/library/io/win32-stream.factor"\r
+        "/library/io/win32-server.factor"
         "/library/io/win32-console.factor"\r
     ] [\r
         dup print\r

diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor
index 753e8ca4791242762790b1b99e3b8bf4bfbef81b..bf2a459fa2cb72f86a1df66478bfad1fdaaabf93 100644 (file)
--- a/library/bootstrap/init-stage2.factor
+++ b/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.

diff --git a/library/bootstrap/win32-io.factor b/library/bootstrap/win32-io.factor
index fbd6fa5097ca4acfcb90e44a77e01f5cf181bf60..561adcd24fd0fc10ba08cb31437171f7ec85bad0 100644 (file)
--- a/library/bootstrap/win32-io.factor
+++ b/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 ;

diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor
index 937c6fb05c995c4d8d95b1a8b1eba6142502156a..5abf6963b9b12ecaffd5df9b990264e280998fb6 100644 (file)
--- a/library/compiler/alien-types.factor
+++ b/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
 

diff --git a/library/io/io-internals.factor b/library/io/io-internals.factor
index b0e55c2f8341812b6048c1e63cdf1e0a30ca14c3..aa0f84032092c39411dcd0b4c27ed4876bfceb88 100644 (file)
--- a/library/io/io-internals.factor
+++ b/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 ;
+
+

diff --git a/library/io/network.factor b/library/io/network.factor
index e2b8334d0300d5f0cedb49ff79ebd7d16c295885..2350719fed1fccdbf671cd8593f9cb40cb05b35c 100644 (file)
--- a/library/io/network.factor
+++ b/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> ;
+

diff --git a/library/io/win32-server.factor b/library/io/win32-server.factor
new file mode 100644 (file)
index 0000000..24004b5
--- /dev/null
+++ b/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 ;
+

diff --git a/library/io/win32-stream.factor b/library/io/win32-stream.factor
index fd30f49d2f2f5d010de71751f9327e41e4a47471..34ffd52fa33f53354d2658b95a6926578509c622 100644 (file)
--- a/library/io/win32-stream.factor
+++ b/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 ;
 

diff --git a/library/sdl/console.factor b/library/sdl/console.factor
index aac1b589037e37649166e83d18b6ae29e67659ca..94d70a57ae652bcaba3cfdc962855841b38ee451 100644 (file)
--- a/library/sdl/console.factor
+++ b/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
 

diff --git a/library/threads.factor b/library/threads.factor
index 90f4a0e99fc0fbc8eba77c2287505901965eb323..c9d2471ea1f5c92edf44064456cc16432cce1aae 100644 (file)
--- a/library/threads.factor
+++ b/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.

diff --git a/library/win32/winsock.factor b/library/win32/winsock.factor
new file mode 100644 (file)
index 0000000..27f1d83
--- /dev/null
+++ b/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 ;

diff --git a/native/error.c b/native/error.c
index 9e865f9aaceb69e0fd35ead8a53e21d16fbbaffb..34dae3ffd3e4da0bb039020462b6b23285c573ce 100644 (file)
--- a/native/error.c
+++ b/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);
        }
 }