dup print\r
run-resource\r
] each\r
+
+os "win32" = [
+ [
+ "/library/io/buffer.factor"
+ "/library/win32/win32-io.factor"
+ "/library/win32/win32-errors.factor"
+ "/library/io/win32-io-internals.factor"
+ "/library/io/win32-stream.factor"
+ "/library/io/win32-console.factor"
+ ] [
+ dup print
+ run-resource
+ ] each
+] when
\r
cpu "x86" = [\r
[\r
IN: kernel
USE: ansi
+USE: win32-console
+USE: alien
USE: compiler
USE: errors
USE: inference
"ansi" get [ stdio [ <ansi-stream> ] change ] when
+ os "win32" = "compile" get and [
+ "kernel32" "kernel32.dll" "stdcall" add-library
+ "user32" "user32.dll" "stdcall" add-library
+ "gdi32" "gdi32.dll" "stdcall" add-library
+ "libc" "msvcrt.dll" "cdecl" add-library
+ ] when
+
"compile" get [ compile-all ] when
+ os "win32" = "compile" get and [
+ stdio [ <win32-console-stream> ] change
+ ] when
+
run-user-init ;
: auto-inline-count 5 ;
"dll" get dup [
drop "name" get dlopen dup "dll" set
] unless ;
-
+
+: add-library ( library name abi -- )
+ "libraries" get [
+ <namespace> [
+ "abi" set
+ "name" set
+ ] extend put
+ ] bind ;
+
SYMBOL: #c-invoke ( C ABI -- Unix and some Windows libs )
SYMBOL: #cleanup ( unwind stack by parameter )
global [
"libraries" get [ <namespace> "libraries" set ] unless
] bind
+
--- /dev/null
+! :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: buffer
+
+USE: alien
+USE: errors
+USE: kernel
+USE: kernel-internals
+USE: math
+USE: namespaces
+USE: strings
+USE: win32-api
+
+: imalloc ( size -- address )
+ "int" "libc" "malloc" [ "int" ] alien-invoke ;
+
+: ifree ( address -- )
+ "void" "libc" "free" [ "int" ] alien-invoke ;
+
+: <buffer> ( size -- buffer )
+ #! Allocates and returns a new buffer.
+ <namespace> [
+ dup "size" set
+ imalloc "buffer" set
+ 0 "fill" set
+ 0 "pos" set
+ ] extend ;
+
+: buffer-free ( buffer -- )
+ #! Frees the C memory associated with the buffer.
+ [ "buffer" get ifree ] bind ;
+
+: buffer-contents ( buffer -- string )
+ #! Returns the current contents of the buffer.
+ [
+ "buffer" get "pos" get +
+ "fill" get "pos" get -
+ memory>string
+ ] bind ;
+
+: buffer-reset ( count buffer -- )
+ #! Reset the position to 0 and the fill pointer to count.
+ [ 0 "pos" set "fill" set ] bind ;
+
+: buffer-consume ( count buffer -- )
+ #! Consume count characters from the beginning of the buffer.
+ [ "pos" [ + "fill" get min ] change ] bind ;
+
+: buffer-length ( buffer -- length )
+ #! Returns the amount of unconsumed input in the buffer.
+ [ "fill" get "pos" get - max ] bind ;
+
+: buffer-set ( string buffer -- )
+ #! Set the contents of a buffer to string.
+ [
+ dup "buffer" get string>memory
+ str-length namespace buffer-reset
+ ] bind ;
+
+: buffer-append ( string buffer -- )
+ #! Appends a string to the end of the buffer. If it doesn't fit,
+ #! an error is thrown.
+ [
+ dup "size" get "fill" get - swap str-length < [
+ "Buffer overflow" throw
+ ] when
+ dup "buffer" get "fill" get + string>memory
+ "fill" [ swap str-length + ] change
+ ] bind ;
+
+: buffer-fill ( buffer quot -- )
+ #! Execute quot with buffer as its argument, passing its result to
+ #! buffer-reset.
+ swap dup >r swap call r> buffer-reset ; inline
+
+: buffer-ptr ( buffer -- pointer )
+ #! Returns the memory address of the buffer area.
+ [ "buffer" get ] bind ;
+
--- /dev/null
+! :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-console
+
+USE: lists
+USE: vectors
+USE: math
+USE: kernel
+USE: namespaces
+USE: stdio
+USE: streams
+USE: presentation
+USE: generic
+USE: parser
+USE: compiler
+USE: win32-api
+
+TRAITS: win32-console-stream
+SYMBOL: handle
+
+: reset ( -- )
+ handle get 7 SetConsoleTextAttribute drop ;
+
+: ansi>win32 ( ansi-attr -- win32-attr )
+ #! Converts an ANSI color (0-based) to a combination of
+ #! _RED, _BLUE, and _GREEN bit flags.
+ { 0 4 2 6 1 5 3 7 } vector-nth ;
+
+: set-bold ( attr ? -- attr )
+ #! Set or unset the bold bit (bit 3).
+ [ 8 bitor ] [ 8 bitnot bitand ] ifte ;
+
+: set-fg ( attr n -- attr )
+ #! Set the foreground field (bits 0..2).
+ swap 7 bitnot bitand bitor ;
+
+: set-bg ( attr n -- attr )
+ #! Set the background field (bits 4..6).
+ 4 shift swap 112 bitnot bitand bitor ;
+
+: char-attrs ( style -- attrs )
+ #! Converts a style into a win32 text attribute bitfield.
+ 7 ! Default style is white FG, black BG, no extra bits
+ "bold" pick assoc [ set-bold ] when*
+ "ansi-fg" pick assoc [ str>number ansi>win32 set-fg ] when*
+ "ansi-bg" pick assoc [ str>number ansi>win32 set-bg ] when*
+ nip ;
+
+: set-attrs ( style -- )
+ char-attrs handle get swap SetConsoleTextAttribute drop ;
+
+M: win32-console-stream fwrite-attr ( string style stream -- )
+ [
+ [ default-style ] unless* set-attrs
+ delegate get fwrite
+ reset
+ ] bind ;
+
+C: win32-console-stream ( stream -- stream )
+ [ delegate set -11 GetStdHandle handle set ] extend ;
+
--- /dev/null
+! :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-io-internals
+USE: alien
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: win32-api
+
+: win32-init-stdio ( -- )
+ INVALID_HANDLE_VALUE NULL NULL 1 CreateIoCompletionPort
+ "completion-port" set ;
+
+: get-access ( -- file-mode )
+ 0 "file-mode" get uncons >r
+ [ GENERIC_WRITE ] [ 0 ] ifte bitor r>
+ [ GENERIC_READ ] [ 0 ] ifte bitor ;
+
+: get-sharemode ( -- share-mode )
+ FILE_SHARE_READ FILE_SHARE_WRITE bitor FILE_SHARE_DELETE bitor ;
+
+: get-create ( -- creation-disposition )
+ "file-mode" get uncons [
+ [ OPEN_ALWAYS ] [ CREATE_ALWAYS ] ifte
+ ] [
+ [ OPEN_EXISTING ] [ 0 ] ifte
+ ] ifte ;
+
+: win32-open-file ( file r w -- handle )
+ [
+ cons "file-mode" set
+ get-access get-sharemode NULL get-create FILE_FLAG_OVERLAPPED NULL
+ CreateFile dup INVALID_HANDLE_VALUE = [ win32-throw-error ] when
+ dup "completion-port" get NULL 1 CreateIoCompletionPort drop
+ ] with-scope ;
+
--- /dev/null
+! :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: buffer
+USE: generic
+USE: kernel
+USE: lists
+USE: math
+USE: namespaces
+USE: stdio
+USE: streams
+USE: win32-api
+USE: win32-io-internals
+
+TRAITS: win32-stream
+GENERIC: update-file-pointer
+
+M: win32-stream fwrite-attr ( str style stream -- )
+ nip fwrite ;
+
+M: win32-stream freadln ( stream -- str )
+ drop f ;
+
+M: win32-stream fread# ( count stream -- str )
+ drop f ;
+
+M: win32-stream fflush ( stream -- )
+ drop ;
+
+M: win32-stream fclose ( stream -- )
+ [ "handle" get CloseHandle drop "buffer" get buffer-free ] bind ;
+
+C: win32-stream ( handle -- stream )
+ [ "handle" set 4096 <buffer> "buffer" set 0 "fp" set ] extend ;
+
+: <win32-filecr> ( path -- stream )
+ t f win32-open-file <win32-stream> ;
+
--- /dev/null
+! :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: buffer
+USE: errors
+USE: kernel
+USE: math
+USE: alien
+
+: FORMAT_MESSAGE_ALLOCATE_BUFFER HEX: 00000100 ;
+: FORMAT_MESSAGE_IGNORE_INSERTS HEX: 00000200 ;
+: FORMAT_MESSAGE_FROM_STRING HEX: 00000400 ;
+: FORMAT_MESSAGE_FROM_HMODULE HEX: 00000800 ;
+: FORMAT_MESSAGE_FROM_SYSTEM HEX: 00001000 ;
+: FORMAT_MESSAGE_ARGUMENT_ARRAY HEX: 00002000 ;
+: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF ;
+
+: MAKELANGID ( primary sub -- lang )
+ 10 shift bitor ;
+
+: LANG_NEUTRAL 0 ;
+: SUBLANG_DEFAULT 1 ;
+
+: GetLastError ( -- int )
+ "int" "kernel32" "GetLastError" [ ] alien-invoke ;
+
+: FormatMessage ( flags source messageid langid buf size args -- int )
+ "int" "kernel32" "FormatMessageA"
+ [ "int" "void*" "int" "int" "void*" "int" "void*" ]
+ alien-invoke ;
+
+: win32-error-message ( id -- string )
+ 4096 <buffer> dup >r >r >r
+ FORMAT_MESSAGE_FROM_SYSTEM NULL r>
+ LANG_NEUTRAL SUBLANG_DEFAULT MAKELANGID r> buffer-ptr <alien> 4096 NULL
+ FormatMessage r> 2dup buffer-reset nip dup buffer-contents
+ swap buffer-free ;
+
+: win32-throw-error ( -- )
+ GetLastError win32-error-message throw ;
+
--- /dev/null
+! :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: kernel
+USE: alien
+
+BEGIN-STRUCT: overlapped-ext
+ FIELD: int internal
+ FIELD: int internal-high
+ FIELD: int offset
+ FIELD: int offset-high
+ FIELD: void* event
+ FIELD: int user-data
+END-STRUCT
+
+: GENERIC_READ HEX: 80000000 ;
+: GENERIC_WRITE HEX: 40000000 ;
+: GENERIC_EXECUTE HEX: 20000000 ;
+: GENERIC_ALL HEX: 10000000 ;
+
+: CREATE_NEW 1 ;
+: CREATE_ALWAYS 2 ;
+: OPEN_EXISTING 3 ;
+: OPEN_ALWAYS 4 ;
+: TRUNCATE_EXISTING 5 ;
+
+: FILE_SHARE_READ 1 ;
+: FILE_SHARE_WRITE 2 ;
+: FILE_SHARE_DELETE 4 ;
+
+: FILE_FLAG_WRITE_THROUGH HEX: 80000000 ;
+: FILE_FLAG_OVERLAPPED HEX: 40000000 ;
+: FILE_FLAG_NO_BUFFERING HEX: 20000000 ;
+: FILE_FLAG_RANDOM_ACCESS HEX: 10000000 ;
+: FILE_FLAG_SEQUENTIAL_SCAN HEX: 08000000 ;
+: FILE_FLAG_DELETE_ON_CLOSE HEX: 04000000 ;
+: FILE_FLAG_BACKUP_SEMANTICS HEX: 02000000 ;
+: FILE_FLAG_POSIX_SEMANTICS HEX: 01000000 ;
+: FILE_FLAG_OPEN_REPARSE_POINT HEX: 00200000 ;
+: FILE_FLAG_OPEN_NO_RECALL HEX: 00100000 ;
+: FILE_FLAG_FIRST_PIPE_INSTANCE HEX: 00080000 ;
+
+: STD_INPUT_HANDLE -10 ;
+: STD_OUTPUT_HANDLE -11 ;
+: STD_ERROR_HANDLE -12 ;
+
+: INVALID_HANDLE_VALUE -1 <alien> ;
+
+: GetStdHandle ( id -- handle )
+ "void*" "kernel32" "GetStdHandle" [ "int" ] alien-invoke ;
+
+: SetConsoleTextAttribute ( handle attrs -- ? )
+ "bool" "kernel32" "SetConsoleTextAttribute" [ "void*" "int" ]
+ alien-invoke ;
+
+: GetConsoleTitle ( buf size -- len )
+ "int" "kernel32" "GetConsoleTitleA" [ "int" "int" ] alien-invoke ;
+
+: SetConsoleTitle ( str -- ? )
+ "bool" "kernel32" "SetConsoleTitleA" [ "char*" ] alien-invoke ;
+
+: ReadFile ( handle buffer len out-len overlapped -- ? )
+ "bool" "kernel32" "ReadFile"
+ [ "void*" "int" "int" "void*" "overlapped-ext*" ]
+ alien-invoke ;
+
+: WriteFile ( handle buffer len out-len overlapped -- ? )
+ "bool" "kernel32" "WriteFile"
+ [ "void*" "int" "int" "void*" "overlapped-ext*" ]
+ alien-invoke ;
+
+: CreateIoCompletionPort ( handle existing-port key numthreads -- )
+ "void*" "kernel32" "CreateIoCompletionPort"
+ [ "void*" "void*" "void*" "int" ]
+ alien-invoke ;
+
+: CreateFile ( name access sharemode security create flags template -- handle )
+ "void*" "kernel32" "CreateFileA"
+ [ "char*" "int" "int" "void*" "int" "int" "void*" ]
+ alien-invoke ;
+
+: CloseHandle ( handle -- ? )
+ "bool" "kernel32" "CloseHandle" [ "void*" ] alien-invoke ;
+
projects / factor.git / commitdiff