steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Started work on win32 IO rewrite

cvs
Mackenzie Straight 2004-12-23 11:51:42 +00:00
parent 1683ff9b3c
commit 9591506f13
9 changed files with 528 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
library/bootstrap/boot-stage2.factor
View File

@ -154,6 +154,20 @@ USE: stdio
dup print
run-resource
] each
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
cpu "x86" = [
[

13
library/bootstrap/init-stage2.factor
View File

@ -27,6 +27,8 @@
IN: kernel
USE: ansi
USE: win32-console
USE: alien
USE: compiler
USE: errors
USE: inference
@ -67,8 +69,19 @@ USE: unparser
"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 ;

11
library/compiler/alien.factor
View File

@ -63,7 +63,15 @@ M: alien = ( obj obj -- ? )
"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 )
@ -148,3 +156,4 @@ SYMBOL: alien-parameters
global [
"libraries" get [ <namespace> "libraries" set ] unless
] bind

104
library/io/buffer.factor Normal file
View File

@ -0,0 +1,104 @@
! :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 ;

86
library/io/win32-console.factor Normal file
View File

@ -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-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 ;

62
library/io/win32-io-internals.factor Normal file
View File

@ -0,0 +1,62 @@
! :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 ;

64
library/io/win32-stream.factor Normal file
View File

@ -0,0 +1,64 @@
! :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> ;

66
library/win32/win32-errors.factor Normal file
View File

@ -0,0 +1,66 @@
! :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 ;

109
library/win32/win32-io.factor Normal file
View File

@ -0,0 +1,109 @@
! :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 ;