diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index 039633bafc..a7b4c477db 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/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 diff --git a/library/bootstrap/init-stage2.factor b/library/bootstrap/init-stage2.factor index 753e8ca479..bf2a459fa2 100644 --- 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 fbd6fa5097..561adcd24f 100644 --- a/library/bootstrap/win32-io.factor +++ b/library/bootstrap/win32-io.factor @@ -54,6 +54,7 @@ USE: win32-api : ; : ; +: ; : init-stdio ( -- ) win32-init-stdio ; diff --git a/library/compiler/alien-types.factor b/library/compiler/alien-types.factor index 937c6fb05c..5abf6963b9 100644 --- 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 swap extend r> set ] bind ; inline diff --git a/library/io/io-internals.factor b/library/io/io-internals.factor index b0e55c2f83..aa0f840320 100644 --- 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 e2b8334d03..2350719fed 100644 --- 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 dup fflush ; -: accept ( server -- client ) +M: server accept ( server -- client ) #! Accept a connection from a server socket. "socket" swap hash blocking-accept ; + diff --git a/library/io/win32-server.factor b/library/io/win32-server.factor new file mode 100644 index 0000000000..24004b5913 --- /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 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 ) + 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 ; + +: ( buf stream -- stream ) + [ + buffer-ptr 0 32 32 + dup >r 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 "buf" set + [ + alloc-io-task init-overlapped >r + socket get "ns" get "buf" get buffer-ptr 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 + + "buf" get buffer-free + ] with-scope + ] bind ; + diff --git a/library/io/win32-stream.factor b/library/io/win32-stream.factor index fd30f49d2f..34ffd52fa3 100644 --- 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 aac1b58903..94d70a57ae 100644 --- a/library/sdl/console.factor +++ b/library/sdl/console.factor @@ -252,7 +252,7 @@ SYMBOL: escape-continuation : start-console ( -- ) [ - 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 90f4a0e99f..c9d2471ea1 100644 --- 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 index 0000000000..27f1d83faf --- /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 + +: HEX: 190 ; + +: 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 9e865f9aac..34dae3ffd3 100644 --- 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); } }