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

Squashed commit of the following: 

commit 197dbe9a6733775ac0ea19b3da4bd4dc3c85418c
Author: Doug Coleman <doug.coleman@gmail.com>
Date:   Sat Sep 18 19:01:38 2010 -0500

    Fix bootstrap, move privileges to windows.privileges

commit 521c622f8afb15bf42d263c738cb990560dc29cb
Author: Doug Coleman <doug.coleman@gmail.com>
Date:   Sat Sep 18 18:26:30 2010 -0500

    Hopefully fix bootstrap

commit eb3f22928b59758b9505430034044b5b94705da2
Author: Doug Coleman <doug.coleman@gmail.com>
Date:   Sat Sep 18 18:19:05 2010 -0500

    Remove wince from factor codebase

commit 619d6c99415f46208a7ede6a04b0ccda46b15360
Author: Doug Coleman <doug.coleman@gmail.com>
Date:   Sat Sep 18 16:07:46 2010 -0500

    Remove Windows CE from vm/
db4
Doug Coleman 2010-09-19 14:02:32 -05:00
parent 87ec88ff6c
commit f791c8c5d2
96 changed files with 1080 additions and 1654 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
GNUmakefile
View File

@ -96,7 +96,6 @@ help:
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
@ -162,9 +161,6 @@ winnt-x86-64:
$(MAKE) $(ALL) CONFIG=vm/Config.windows.nt.x86.64
$(MAKE) factor-console CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(ALL) CONFIG=vm/Config.windows.ce.arm
ifdef CONFIG
macosx.app: factor

11
Nmakefile
View File

@ -14,18 +14,17 @@ CL_FLAGS = $(CL_FLAGS) /Zi /DFACTOR_DEBUG
!IF "$(PLATFORM)" == "x86-32"
LINK_FLAGS = $(LINK_FLAGS) /safeseh
PLAF_DLL_OBJS = vm\os-windows-nt-x86.32.obj vm\safeseh.obj
PLAF_DLL_OBJS = vm\os-windows-x86.32.obj vm\safeseh.obj
!ELSEIF "$(PLATFORM)" == "x86-64"
PLAF_DLL_OBJS = vm\os-windows-nt-x86.64.obj
PLAF_DLL_OBJS = vm\os-windows-x86.64.obj
!ENDIF
ML_FLAGS = /nologo /safeseh
EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
EXE_OBJS = vm/main-windows.obj vm\factor.res
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm\os-windows.obj \
vm\os-windows-nt.obj \
vm\aging_collector.obj \
vm\alien.obj \
vm\arrays.obj \
@ -56,7 +55,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm\jit.obj \
vm\math.obj \
vm\mvm.obj \
vm\mvm-windows-nt.obj \
vm\mvm-windows.obj \
vm\nursery_collector.obj \
vm\object_start_map.obj \
vm\objects.obj \
@ -68,7 +67,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm\to_tenured_collector.obj \
vm\tuples.obj \
vm\utilities.obj \
vm\vm.obj \
vm\vm.obj \
vm\words.obj
.cpp.obj:

2
basis/bootstrap/io/io.factor
View File

@ -6,6 +6,6 @@ IN: bootstrap.io
"io.backend." {
{ [ "io-backend" get ] [ "io-backend" get ] }
{ [ os unix? ] [ "unix." os name>> append ] }
{ [ os winnt? ] [ "windows.nt" ] }
{ [ os windows? ] [ "windows" ] }
} cond append require
] when

3
basis/bootstrap/stage2.factor
View File

@ -72,8 +72,7 @@ SYMBOL: bootstrap-time
(command-line) parse-command-line
! Set dll paths
os wince? [ "windows.ce" require ] when
os winnt? [ "windows.nt" require ] when
os windows? [ "windows" require ] when
"staging" get "deploy-vocab" get or [
"stage2: deployment mode" print

148
basis/io/backend/windows/nt/nt.factor
View File

@ -1,148 +0,0 @@
USING: accessors alien alien.c-types alien.data alien.syntax
arrays assocs classes.struct combinators
combinators.short-circuit destructors io io.backend
io.backend.windows io.buffers io.files.windows io.ports
io.streams.c io.streams.null io.timeouts kernel libc locals
math namespaces sequences system threads vocabs.loader
windows.errors windows.handles windows.kernel32 ;
IN: io.backend.windows.nt
! Global variable with assoc mapping overlapped to threads
SYMBOL: pending-overlapped
TUPLE: io-callback port thread ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
OVERLAPPED malloc-struct &free ;
: make-overlapped ( port -- overlapped-ext )
[ (make-overlapped) ] dip
handle>> ptr>> [ >>offset ] when* ;
M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
: <completion-port> ( handle existing -- handle )
f 1 CreateIoCompletionPort dup win32-error=0/f ;
SYMBOL: master-completion-port
: <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ;
M: winnt add-completion ( win32-handle -- win32-handle )
dup handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
{ [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
drop
[ self ] dip >c-ptr pending-overlapped get-global set-at
"I/O" suspend {
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
[ drop 0 ] [ n>win32-error-string throw ] if
] }
} cond
] with-timeout ;
:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
master-completion-port get-global
{ int void* pointer: OVERLAPPED }
[ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
:> ( error? bytes key overlapped )
bytes overlapped error? ;
: resume-callback ( result overlapped -- )
>c-ptr pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( nanos -- ? )
wait-for-overlapped [
[
[ drop GetLastError 1array ] dip resume-callback t
] [ drop f ] if*
] [ resume-callback t ] if ;
M: win32-handle cancel-operation
[ handle>> CancelIo win32-error=0/f ] unless-disposed ;
M: winnt io-multiplex ( nanos -- )
handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone pending-overlapped set-global ;
ERROR: invalid-file-size n ;
: handle>file-size ( handle -- n )
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- )
[ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
M: winnt tell-handle ( handle -- n ) ptr>> ;
M: winnt seek-handle ( n seek-type handle -- )
swap {
{ seek-absolute [ set-seek-ptr ] }
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
{ seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
[ bad-seek-type ]
} case ;
: file-error? ( n -- eof? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
[ n>win32-error-string throw ]
} cond
] [ f ] if ;
: wait-for-file ( FileArgs n port -- n )
swap file-error?
[ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
: update-file-ptr ( n port -- )
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
: finish-write ( n port -- )
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
M: winnt (wait-to-write)
[
[ make-FileArgs dup setup-write WriteFile ]
[ wait-for-file ]
[ finish-write ]
tri
] with-destructors ;
: finish-read ( n port -- )
[ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
M: winnt (wait-to-read) ( port -- )
[
[ make-FileArgs dup setup-read ReadFile ]
[ wait-for-file ]
[ finish-read ]
tri
] with-destructors ;
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
M: winnt init-stdio
console-app?
[ init-c-stdio ]
[ null-reader null-writer null-writer set-stdio ] if ;
"io.files.windows.nt" require
winnt set-io-backend

4
basis/io/backend/windows/privileges/privileges-tests.factor
View File

@ -1,4 +0,0 @@
USING: io.backend.windows.privileges tools.test ;
IN: io.backend.windows.privileges.tests
[ [ ] with-privileges ] must-infer

15
basis/io/backend/windows/privileges/privileges.factor
View File

@ -1,15 +0,0 @@
USING: io.backend kernel continuations sequences
system vocabs.loader combinators fry ;
IN: io.backend.windows.privileges
HOOK: set-privilege io-backend ( name ? -- )
: with-privileges ( seq quot -- )
[ '[ _ [ t set-privilege ] each @ ] ]
[ drop '[ _ [ f set-privilege ] each ] ]
2bi [ ] cleanup ; inline
{
{ [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }
{ [ os wince? ] [ "io.backend.windows.ce.privileges" require ] }
} cond

32
basis/io/backend/windows/windows.factor
View File

@ -1,34 +1,8 @@
! Copyright (C) 2004, 2010 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types classes.struct destructors
io.backend io.timeouts kernel literals windows.errors
windows.handles windows.kernel32 vocabs.loader ;
USING: io.backend namespaces system vocabs.loader ;
IN: io.backend.windows
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- port )
"io.files.windows" require
TUPLE: win32-file < win32-handle ptr ;
: <win32-file> ( handle -- win32-file )
win32-file new-win32-handle ;
M: win32-file dispose
[ cancel-operation ] [ call-next-method ] bi ;
: opened-file ( handle -- win32-file )
check-invalid-handle <win32-file> |dispose add-completion ;
CONSTANT: share-mode
flags{
FILE_SHARE_READ
FILE_SHARE_WRITE
FILE_SHARE_DELETE
}
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
SECURITY_ATTRIBUTES heap-size >>nLength ;
"io.files.windows" require
winnt set-io-backend

2
basis/io/files/info/windows/windows.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays math io.backend io.files.info
io.files.windows io.files.windows.nt kernel windows.kernel32
io.files.windows kernel windows.kernel32
windows.time windows.types windows accessors alien.c-types
combinators generalizations system alien.strings
io.encodings.utf16n sequences splitting windows.errors fry

5
basis/io/files/unique/windows/windows.factor
View File

@ -1,6 +1,5 @@
USING: kernel system windows.kernel32 io.backend.windows
io.files.windows io.ports windows destructors environment
io.files.unique ;
USING: destructors environment io.files.unique io.files.windows
system windows.kernel32 ;
IN: io.files.unique.windows
M: windows (touch-unique-file) ( path -- )

3
basis/io/files/windows/nt/authors.txt
View File

@ -1,3 +0,0 @@
Doug Coleman
Slava Pestov
Mackenzie Straight

65
basis/io/files/windows/nt/nt.factor
View File

@ -1,65 +0,0 @@
USING: accessors alien.c-types alien.strings classes.struct
combinators combinators.short-circuit continuations environment
io.backend io.backend.windows io.encodings.utf16n
io.files.private io.files.windows io.pathnames kernel math
sequences specialized-arrays system tr
windows windows.errors windows.kernel32 windows.shell32
windows.time ;
SPECIALIZED-ARRAY: ushort
IN: io.files.windows.nt
M: winnt cwd
MAX_UNICODE_PATH dup <ushort-array>
[ GetCurrentDirectory win32-error=0/f ] keep
utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
CONSTANT: unicode-prefix "\\\\?\\"
M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ drop f ] }
{ [ dup [ path-separator? ] all? ] [ drop t ] }
{ [ dup trim-tail-separators { [ length 2 = ]
[ second CHAR: : = ] } 1&& ] [ drop t ] }
{ [ dup unicode-prefix head? ]
[ trim-tail-separators length unicode-prefix length 2 + = ] }
[ drop f ]
} cond ;
: prepend-prefix ( string -- string' )
dup unicode-prefix head? [
unicode-prefix prepend
] unless ;
TR: normalize-separators "/" "\\" ;
M: winnt normalize-path ( string -- string' )
absolute-path
normalize-separators
prepend-prefix ;
M: winnt CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
<PRIVATE
: windows-file-size ( path -- size )
normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
[ GetFileAttributesEx win32-error=0/f ] keep
[ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
PRIVATE>
M: winnt open-append
[ dup windows-file-size ] [ drop 0 ] recover
[ (open-append) ] dip >>ptr ;
M: winnt home
{
[ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
[ "USERPROFILE" os-env ]
[ my-documents ]
} 0|| ;

1
basis/io/files/windows/nt/platforms.txt
View File

@ -1 +0,0 @@
winnt

6
basis/io/files/windows/nt/nt-tests.factor → basis/io/files/windows/windows-tests.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files io.pathnames kernel tools.test io.backend
io.files.windows.nt splitting sequences io.pathnames.private ;
IN: io.files.windows.nt.tests
io.files.windows splitting sequences io.pathnames.private ;
IN: io.files.windows.tests
[ f ] [ "\\foo" absolute-path? ] unit-test
[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test

306
basis/io/files/windows/windows.factor
View File

@ -1,12 +1,216 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data combinators
destructors io.backend.windows io.binary io.buffers io.files
io.files.types io.ports kernel literals make
math.bitwise system windows.errors windows.handles
windows.kernel32 windows.time windows.types vocabs.loader ;
USING: accessors alien alien.c-types alien.data alien.strings
alien.syntax arrays assocs classes.struct combinators
combinators.short-circuit continuations destructors environment
io io.backend io.binary io.buffers
io.encodings.utf16n io.files io.files.private io.files.types
io.pathnames io.ports io.streams.c io.streams.null io.timeouts
kernel libc literals locals make math math.bitwise namespaces
sequences specialized-arrays system
threads tr windows windows.errors windows.handles
windows.kernel32 windows.shell32 windows.time windows.types ;
SPECIALIZED-ARRAY: ushort
IN: io.files.windows
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- port )
HOOK: open-append os ( path -- win32-file )
TUPLE: win32-file < win32-handle ptr ;
: <win32-file> ( handle -- win32-file )
win32-file new-win32-handle ;
M: win32-file dispose
[ cancel-operation ] [ call-next-method ] bi ;
: opened-file ( handle -- win32-file )
check-invalid-handle <win32-file> |dispose add-completion ;
CONSTANT: share-mode
flags{
FILE_SHARE_READ
FILE_SHARE_WRITE
FILE_SHARE_DELETE
}
: default-security-attributes ( -- obj )
SECURITY_ATTRIBUTES <struct>
SECURITY_ATTRIBUTES heap-size >>nLength ;
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead
lpNumberOfBytesRet lpOverlapped ;
C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
{
[ handle>> check-disposed ]
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]
[ drop DWORD <c-object> ]
[ FileArgs-overlapped ]
} cleave <FileArgs> ;
! Global variable with assoc mapping overlapped to threads
SYMBOL: pending-overlapped
TUPLE: io-callback port thread ;
C: <io-callback> io-callback
: (make-overlapped) ( -- overlapped-ext )
OVERLAPPED malloc-struct &free ;
: make-overlapped ( port -- overlapped-ext )
[ (make-overlapped) ] dip
handle>> ptr>> [ >>offset ] when* ;
M: winnt FileArgs-overlapped ( port -- overlapped )
make-overlapped ;
: <completion-port> ( handle existing -- handle )
f 1 CreateIoCompletionPort dup win32-error=0/f ;
SYMBOL: master-completion-port
: <master-completion-port> ( -- handle )
INVALID_HANDLE_VALUE f <completion-port> ;
M: winnt add-completion ( win32-handle -- win32-handle )
dup handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
{ [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
drop
[ self ] dip >c-ptr pending-overlapped get-global set-at
"I/O" suspend {
{ [ dup integer? ] [ ] }
{ [ dup array? ] [
first dup eof?
[ drop 0 ] [ n>win32-error-string throw ] if
] }
} cond
] with-timeout ;
:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
master-completion-port get-global
{ int void* pointer: OVERLAPPED }
[ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
:> ( error? bytes key overlapped )
bytes overlapped error? ;
: resume-callback ( result overlapped -- )
>c-ptr pending-overlapped get-global delete-at* drop resume-with ;
: handle-overlapped ( nanos -- ? )
wait-for-overlapped [
[
[ drop GetLastError 1array ] dip resume-callback t
] [ drop f ] if*
] [ resume-callback t ] if ;
M: win32-handle cancel-operation
[ handle>> CancelIo win32-error=0/f ] unless-disposed ;
M: winnt io-multiplex ( nanos -- )
handle-overlapped [ 0 io-multiplex ] when ;
M: winnt init-io ( -- )
<master-completion-port> master-completion-port set-global
H{ } clone pending-overlapped set-global ;
ERROR: invalid-file-size n ;
: handle>file-size ( handle -- n )
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
ERROR: seek-before-start n ;
: set-seek-ptr ( n handle -- )
[ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
M: winnt tell-handle ( handle -- n ) ptr>> ;
M: winnt seek-handle ( n seek-type handle -- )
swap {
{ seek-absolute [ set-seek-ptr ] }
{ seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
{ seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
[ bad-seek-type ]
} case ;
: file-error? ( n -- eof? )
zero? [
GetLastError {
{ [ dup expected-io-error? ] [ drop f ] }
{ [ dup eof? ] [ drop t ] }
[ n>win32-error-string throw ]
} cond
] [ f ] if ;
: wait-for-file ( FileArgs n port -- n )
swap file-error?
[ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
: update-file-ptr ( n port -- )
handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
: finish-write ( n port -- )
[ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
{
[ hFile>> ]
[ lpBuffer>> buffer-end ]
[ lpBuffer>> buffer-capacity ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
{
[ hFile>> ]
[ lpBuffer>> buffer@ ]
[ lpBuffer>> buffer-length ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
M: winnt (wait-to-write)
[
[ make-FileArgs dup setup-write WriteFile ]
[ wait-for-file ]
[ finish-write ]
tri
] with-destructors ;
: finish-read ( n port -- )
[ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
M: winnt (wait-to-read) ( port -- )
[
[ make-FileArgs dup setup-read ReadFile ]
[ wait-for-file ]
[ finish-read ]
tri
] with-destructors ;
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
M: winnt init-stdio
console-app?
[ init-c-stdio ]
[ null-reader null-writer null-writer set-stdio ] if ;
: open-file ( path access-mode create-mode flags -- handle )
[
[ share-mode default-security-attributes ] 2dip
@ -48,42 +252,6 @@ IN: io.files.windows
[ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
HOOK: open-append os ( path -- win32-file )
TUPLE: FileArgs
hFile lpBuffer nNumberOfBytesToRead
lpNumberOfBytesRet lpOverlapped ;
C: <FileArgs> FileArgs
: make-FileArgs ( port -- <FileArgs> )
{
[ handle>> check-disposed ]
[ handle>> handle>> ]
[ buffer>> ]
[ buffer>> buffer-length ]
[ drop DWORD <c-object> ]
[ FileArgs-overlapped ]
} cleave <FileArgs> ;
: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
{
[ hFile>> ]
[ lpBuffer>> buffer-end ]
[ lpBuffer>> buffer-capacity ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
{
[ hFile>> ]
[ lpBuffer>> buffer@ ]
[ lpBuffer>> buffer-length ]
[ lpNumberOfBytesRet>> ]
[ lpOverlapped>> ]
} cleave ;
M: windows (file-reader) ( path -- stream )
open-read <input-port> ;
@ -128,4 +296,58 @@ SYMBOLS: +read-only+ +hidden+ +system+
[ timestamp>FILETIME ] tri@
SetFileTime win32-error=0/f ;
"io.files.windows.nt" require
M: winnt cwd
MAX_UNICODE_PATH dup <ushort-array>
[ GetCurrentDirectory win32-error=0/f ] keep
utf16n alien>string ;
M: winnt cd
SetCurrentDirectory win32-error=0/f ;
CONSTANT: unicode-prefix "\\\\?\\"
M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ drop f ] }
{ [ dup [ path-separator? ] all? ] [ drop t ] }
{ [ dup trim-tail-separators { [ length 2 = ]
[ second CHAR: : = ] } 1&& ] [ drop t ] }
{ [ dup unicode-prefix head? ]
[ trim-tail-separators length unicode-prefix length 2 + = ] }
[ drop f ]
} cond ;
: prepend-prefix ( string -- string' )
dup unicode-prefix head? [
unicode-prefix prepend
] unless ;
TR: normalize-separators "/" "\\" ;
M: winnt normalize-path ( string -- string' )
absolute-path
normalize-separators
prepend-prefix ;
M: winnt CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
<PRIVATE
: windows-file-size ( path -- size )
normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
[ GetFileAttributesEx win32-error=0/f ] keep
[ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
PRIVATE>
M: winnt open-append
[ dup windows-file-size ] [ drop 0 ] recover
[ (open-append) ] dip >>ptr ;
M: winnt home
{
[ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
[ "USERPROFILE" os-env ]
[ my-documents ]
} 0|| ;

2
basis/io/launcher/launcher.factor
View File

@ -272,6 +272,6 @@ M: output-process-error error.
{
{ [ os unix? ] [ "io.launcher.unix" require ] }
{ [ os winnt? ] [ "io.launcher.windows.nt" require ] }
{ [ os windows? ] [ "io.launcher.windows" require ] }
[ ]
} cond

3
basis/io/launcher/windows/nt/authors.txt
View File

@ -1,3 +0,0 @@
Doug Coleman
Slava Pestov
Mackenzie Straight

196
basis/io/launcher/windows/nt/nt-tests.factor
View File

@ -1,196 +0,0 @@
USING: io.launcher tools.test calendar accessors environment
namespaces kernel system arrays io io.files io.encodings.ascii
sequences parser assocs hashtables math continuations eval
io.files.temp io.directories io.pathnames splitting ;
IN: io.launcher.windows.nt.tests
[ ] [
<process>
"notepad" >>command
1/2 seconds >>timeout
"notepad" set
] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[ f ] [ "notepad" get process-started? ] unit-test
[ ] [ "notepad" [ run-detached ] change ] unit-test
[ "notepad" get wait-for-process ] must-fail
[ t ] [ "notepad" get killed>> ] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[
<process>
"notepad" >>command
1/2 seconds >>timeout
try-process
] must-fail
[
<process>
"notepad" >>command
1/2 seconds >>timeout
try-output-process
] must-fail
: console-vm ( -- path )
vm ".exe" ?tail [ ".com" append ] when ;
[ ] [
<process>
console-vm "-quiet" "-run=hello-world" 3array >>command
"out.txt" temp-file >>stdout
try-process
] unit-test
[ "Hello world" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "( scratchpad ) " ] [
<process>
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
ascii [ lines last ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
"resource:basis/io/launcher/windows/nt/test" ;
[ ] [
launcher-test-path [
<process>
console-vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
"err.txt" temp-file >>stderr
try-process
] with-directory
] unit-test
[ "output" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "error" ] [
"err.txt" temp-file ascii file-lines first
] unit-test
[ ] [
launcher-test-path [
<process>
console-vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
+stdout+ >>stderr
try-process
] with-directory
] unit-test
[ "outputerror" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "output" ] [
launcher-test-path [
<process>
console-vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
ascii <process-reader> stream-lines first
] with-directory
] unit-test
[ "error" ] [
"err2.txt" temp-file ascii file-lines first
] unit-test
[ t ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
] unit-test
[ t ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
] unit-test
[ "B" ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"A" swap at
] unit-test
[ f ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test
2 [
[ ] [
<process>
"cmd.exe /c dir" >>command
"dir.txt" temp-file >>stdout
try-process
] unit-test
[ ] [ "dir.txt" temp-file delete-file ] unit-test
] times
[ "append-test" temp-file delete-file ] ignore-errors
[ "Hello appender\r\nHello appender\r\n" ] [
2 [
launcher-test-path [
<process>
console-vm "-script" "append.factor" 3array >>command
"append-test" temp-file <appender> >>stdout
try-process
] with-directory
] times
"append-test" temp-file ascii file-contents
] unit-test
[ "( scratchpad ) " ] [
console-vm "-run=listener" 2array
ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
] unit-test
[ ] [
console-vm "-run=listener" 2array
ascii [ "USE: system 0 exit" print ] with-process-writer
] unit-test
[ ] [
<process>
console-vm "-run=listener" 2array >>command
"vocab:io/launcher/windows/nt/test/input.txt" >>stdin
try-process
] unit-test

109
basis/io/launcher/windows/nt/nt.factor
View File

@ -1,109 +0,0 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types combinators destructors
io.backend io.backend.windows io.files.windows io.launcher
io.launcher.windows io.pipes io.ports kernel locals strings
system windows.errors windows.handles windows.kernel32
windows.types ;
IN: io.launcher.windows.nt
: duplicate-handle ( handle -- handle' )
GetCurrentProcess ! source process
swap handle>> ! handle
GetCurrentProcess ! target process
f <void*> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
0 ! options
DuplicateHandle win32-error=0/f
] keep *void* <win32-handle> &dispose ;
! /dev/null simulation
: null-input ( -- pipe )
(pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
: null-output ( -- pipe )
(pipe) [ out>> &dispose ] [ in>> dispose ] bi ;
: null-pipe ( mode -- pipe )
{
{ GENERIC_READ [ null-input ] }
{ GENERIC_WRITE [ null-output ] }
} case ;
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: redirect-default ( obj access-mode create-mode -- handle )
3drop f ;
: redirect-closed ( obj access-mode create-mode -- handle )
drop nip null-pipe ;
:: redirect-file ( path access-mode create-mode -- handle )
path normalize-path
access-mode
share-mode
default-security-attributes
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile check-invalid-handle <win32-file> &dispose ;
: redirect-append ( path access-mode create-mode -- handle )
[ path>> ] 2dip
drop OPEN_ALWAYS
redirect-file
dup 0 FILE_END set-file-pointer ;
: redirect-handle ( handle access-mode create-mode -- handle )
2drop ;
: redirect-stream ( stream access-mode create-mode -- handle )
[ underlying-handle ] 2dip redirect-handle ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ redirect-default ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-append ] }
{ [ pick win32-file? ] [ redirect-handle ] }
[ redirect-stream ]
} cond
dup [ dup t set-inherit handle>> ] when ;
: redirect-stdout ( process args -- handle )
drop
stdout>>
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_OUTPUT_HANDLE GetStdHandle or ;
: redirect-stderr ( process args -- handle )
over stderr>> +stdout+ eq? [
nip
lpStartupInfo>> hStdOutput>>
] [
drop
stderr>>
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_ERROR_HANDLE GetStdHandle or
] if ;
: redirect-stdin ( process args -- handle )
drop
stdin>>
GENERIC_READ
OPEN_EXISTING
redirect
STD_INPUT_HANDLE GetStdHandle or ;
M: winnt fill-redirection ( process args -- )
dup lpStartupInfo>>
[ [ redirect-stdout ] dip hStdOutput<< ]
[ [ redirect-stderr ] dip hStdError<< ]
[ [ redirect-stdin ] dip hStdInput<< ] 3tri ;

1
basis/io/launcher/windows/nt/platforms.txt
View File

@ -1 +0,0 @@
winnt

4
basis/io/launcher/windows/nt/test/append.factor → basis/io/launcher/windows/test/append.factor
View File

@ -1,2 +1,2 @@
USE: io
"Hello appender" print
USE: io
"Hello appender" print

0
basis/io/launcher/windows/nt/test/env.factor → basis/io/launcher/windows/test/env.factor
View File

2
basis/io/launcher/windows/nt/test/input.txt → basis/io/launcher/windows/test/input.txt Executable file → Normal file
View File

@ -1 +1 @@
USE: system 0 exit
USE: system 0 exit

10
basis/io/launcher/windows/nt/test/stderr.factor → basis/io/launcher/windows/test/stderr.factor
View File

@ -1,5 +1,5 @@
USE: io
USE: namespaces
"output" write flush
"error" error-stream get stream-write error-stream get stream-flush
USE: io
USE: namespaces
"output" write flush
"error" error-stream get stream-write error-stream get stream-flush

197
basis/io/launcher/windows/windows-tests.factor
View File

@ -1,5 +1,9 @@
USING: accessors arrays assocs calendar continuations
environment eval hashtables io io.directories
io.encodings.ascii io.files io.files.temp io.launcher
io.launcher.windows io.pathnames kernel math namespaces parser
sequences splitting system tools.test ;
IN: io.launcher.windows.tests
USING: tools.test io.launcher.windows ;
[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test
@ -8,3 +12,194 @@ USING: tools.test io.launcher.windows ;
[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test
[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test
[ ] [
<process>
"notepad" >>command
1/2 seconds >>timeout
"notepad" set
] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[ f ] [ "notepad" get process-started? ] unit-test
[ ] [ "notepad" [ run-detached ] change ] unit-test
[ "notepad" get wait-for-process ] must-fail
[ t ] [ "notepad" get killed>> ] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[
<process>
"notepad" >>command
1/2 seconds >>timeout
try-process
] must-fail
[
<process>
"notepad" >>command
1/2 seconds >>timeout
try-output-process
] must-fail
: console-vm ( -- path )
vm ".exe" ?tail [ ".com" append ] when ;
[ ] [
<process>
console-vm "-quiet" "-run=hello-world" 3array >>command
"out.txt" temp-file >>stdout
try-process
] unit-test
[ "Hello world" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "( scratchpad ) " ] [
<process>
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
+stdout+ >>stderr
ascii [ lines last ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
"resource:basis/io/launcher/windows/test" ;
[ ] [
launcher-test-path [
<process>
console-vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
"err.txt" temp-file >>stderr
try-process
] with-directory
] unit-test
[ "output" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "error" ] [
"err.txt" temp-file ascii file-lines first
] unit-test
[ ] [
launcher-test-path [
<process>
console-vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
+stdout+ >>stderr
try-process
] with-directory
] unit-test
[ "outputerror" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "output" ] [
launcher-test-path [
<process>
console-vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
ascii <process-reader> stream-lines first
] with-directory
] unit-test
[ "error" ] [
"err2.txt" temp-file ascii file-lines first
] unit-test
[ t ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
] unit-test
[ t ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
os-envs =
] unit-test
[ "B" ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"A" swap at
] unit-test
[ f ] [
launcher-test-path [
<process>
console-vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> stream-contents
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test
2 [
[ ] [
<process>
"cmd.exe /c dir" >>command
"dir.txt" temp-file >>stdout
try-process
] unit-test
[ ] [ "dir.txt" temp-file delete-file ] unit-test
] times
[ "append-test" temp-file delete-file ] ignore-errors
[ "Hello appender\r\nHello appender\r\n" ] [
2 [
launcher-test-path [
<process>
console-vm "-script" "append.factor" 3array >>command
"append-test" temp-file <appender> >>stdout
try-process
] with-directory
] times
"append-test" temp-file ascii file-contents
] unit-test
[ "( scratchpad ) " ] [
console-vm "-run=listener" 2array
ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
] unit-test
[ ] [
console-vm "-run=listener" 2array
ascii [ "USE: system 0 exit" print ] with-process-writer
] unit-test
[ ] [
<process>
console-vm "-run=listener" 2array >>command
"vocab:io/launcher/windows/test/input.txt" >>stdin
try-process
] unit-test

118
basis/io/launcher/windows/windows.factor
View File

@ -1,13 +1,14 @@
! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.data arrays continuations io
io.backend.windows io.pipes.windows.nt io.pathnames libc
io.ports windows.types math windows.kernel32 namespaces make
io.launcher kernel sequences windows.errors splitting system
threads init strings combinators io.backend accessors
concurrency.flags io.files assocs io.files.private windows
destructors classes classes.struct specialized-arrays
debugger prettyprint ;
USING: accessors alien alien.c-types alien.data arrays assocs
classes classes.struct combinators concurrency.flags
continuations debugger destructors init io io.backend
io.backend.windows io.files io.files.private io.files.windows
io.launcher io.pathnames io.pipes io.pipes.windows io.ports
kernel libc locals make math namespaces prettyprint sequences
specialized-arrays splitting
strings system threads windows windows.errors windows.handles
windows.kernel32 windows.types ;
SPECIALIZED-ARRAY: ushort
SPECIALIZED-ARRAY: void*
IN: io.launcher.windows
@ -174,3 +175,104 @@ M: windows wait-for-processes ( -- ? )
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
: duplicate-handle ( handle -- handle' )
GetCurrentProcess ! source process
swap handle>> ! handle
GetCurrentProcess ! target process
f <void*> [ ! target handle
DUPLICATE_SAME_ACCESS ! desired access
TRUE ! inherit handle
0 ! options
DuplicateHandle win32-error=0/f
] keep *void* <win32-handle> &dispose ;
! /dev/null simulation
: null-input ( -- pipe )
(pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
: null-output ( -- pipe )
(pipe) [ out>> &dispose ] [ in>> dispose ] bi ;
: null-pipe ( mode -- pipe )
{
{ GENERIC_READ [ null-input ] }
{ GENERIC_WRITE [ null-output ] }
} case ;
! The below code is based on the example given in
! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
: redirect-default ( obj access-mode create-mode -- handle )
3drop f ;
: redirect-closed ( obj access-mode create-mode -- handle )
drop nip null-pipe ;
:: redirect-file ( path access-mode create-mode -- handle )
path normalize-path
access-mode
share-mode
default-security-attributes
create-mode
FILE_ATTRIBUTE_NORMAL ! flags and attributes
f ! template file
CreateFile check-invalid-handle <win32-file> &dispose ;
: redirect-append ( path access-mode create-mode -- handle )
[ path>> ] 2dip
drop OPEN_ALWAYS
redirect-file
dup 0 FILE_END set-file-pointer ;
: redirect-handle ( handle access-mode create-mode -- handle )
2drop ;
: redirect-stream ( stream access-mode create-mode -- handle )
[ underlying-handle ] 2dip redirect-handle ;
: redirect ( obj access-mode create-mode -- handle )
{
{ [ pick not ] [ redirect-default ] }
{ [ pick +closed+ eq? ] [ redirect-closed ] }
{ [ pick string? ] [ redirect-file ] }
{ [ pick appender? ] [ redirect-append ] }
{ [ pick win32-file? ] [ redirect-handle ] }
[ redirect-stream ]
} cond
dup [ dup t set-inherit handle>> ] when ;
: redirect-stdout ( process args -- handle )
drop
stdout>>
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_OUTPUT_HANDLE GetStdHandle or ;
: redirect-stderr ( process args -- handle )
over stderr>> +stdout+ eq? [
nip
lpStartupInfo>> hStdOutput>>
] [
drop
stderr>>
GENERIC_WRITE
CREATE_ALWAYS
redirect
STD_ERROR_HANDLE GetStdHandle or
] if ;
: redirect-stdin ( process args -- handle )
drop
stdin>>
GENERIC_READ
OPEN_EXISTING
redirect
STD_INPUT_HANDLE GetStdHandle or ;
M: winnt fill-redirection ( process args -- )
dup lpStartupInfo>>
[ [ redirect-stdout ] dip hStdOutput<< ]
[ [ redirect-stderr ] dip hStdError<< ]
[ [ redirect-stdin ] dip hStdInput<< ] 3tri ;

2
basis/io/mmap/windows/windows.factor
View File

@ -1,4 +1,4 @@
USING: accessors destructors io.backend.windows.privileges
USING: accessors destructors windows.privileges
io.files.windows io.mmap io.mmap.private kernel literals locals
math math.bitwise system windows.errors windows.handles
windows.kernel32 ;

2
basis/io/monitors/monitors-tests.factor
View File

@ -1,9 +1,9 @@
IN: io.monitors.tests
USING: io.monitors tools.test io.files system sequences
continuations namespaces concurrency.count-downs kernel io
threads calendar prettyprint destructors io.timeouts
io.files.temp io.directories io.directories.hierarchy
io.pathnames accessors concurrency.promises ;
IN: io.monitors.tests
os { winnt linux macosx } member? [
[

2
basis/io/monitors/monitors.factor
View File

@ -77,6 +77,6 @@ SYMBOL: +rename-file+
{
{ [ os macosx? ] [ "io.monitors.macosx" require ] }
{ [ os linux? ] [ "io.monitors.linux" require ] }
{ [ os winnt? ] [ "io.monitors.windows.nt" require ] }
{ [ os windows? ] [ "io.monitors.windows" require ] }
{ [ os bsd? ] [ ] }
} cond

0
basis/io/monitors/windows/nt/authors.txt → basis/io/monitors/windows/authors.txt Executable file → Normal file
View File

4
basis/io/monitors/windows/nt/nt-tests.factor
View File

@ -1,4 +0,0 @@
IN: io.monitors.windows.nt.tests
USING: io.monitors.windows.nt tools.test ;

1
basis/io/monitors/windows/nt/platforms.txt
View File

@ -1 +0,0 @@
winnt

0
basis/io/backend/windows/nt/platforms.txt → basis/io/monitors/windows/platforms.txt
View File

6
basis/io/monitors/windows/nt/nt.factor → basis/io/monitors/windows/windows.factor
View File

@ -3,12 +3,12 @@
USING: alien alien.c-types alien.data alien.strings libc destructors
locals kernel math assocs namespaces make continuations sequences
hashtables sorting arrays combinators math.bitwise strings
system accessors threads splitting io.backend io.backend.windows
io.backend.windows.nt io.files.windows.nt io.monitors io.ports
system accessors threads splitting io.backend
io.files.windows io.monitors io.ports
io.buffers io.files io.timeouts io.encodings.string literals
io.encodings.utf16n io windows.errors windows.kernel32 windows.types
io.pathnames classes.struct ;
IN: io.monitors.windows.nt
IN: io.monitors.windows
: open-directory ( path -- handle )
normalize-path

2
basis/io/pipes/pipes.factor
View File

@ -60,6 +60,6 @@ PRIVATE>
{
{ [ os unix? ] [ "io.pipes.unix" require ] }
{ [ os winnt? ] [ "io.pipes.windows.nt" require ] }
{ [ os windows? ] [ "io.pipes.windows" require ] }
[ ]
} cond

0
basis/io/pipes/windows/nt/authors.txt → basis/io/pipes/windows/authors.txt Executable file → Normal file
View File

1
basis/io/pipes/windows/nt/platforms.txt
View File

@ -1 +0,0 @@
winnt

0
basis/io/backend/windows/nt/privileges/platforms.txt → basis/io/pipes/windows/platforms.txt
View File

11
basis/io/pipes/windows/nt/nt.factor → basis/io/pipes/windows/windows.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.backend.windows libc
windows.types math.bitwise windows.kernel32 windows namespaces
make kernel sequences windows.errors assocs math.parser system
random combinators accessors io.pipes io.ports literals ;
IN: io.pipes.windows.nt
USING: accessors alien alien.c-types arrays assocs combinators
destructors io io.files.windows io.pipes
io.ports kernel libc literals make math.bitwise math.parser
namespaces random sequences system windows windows.errors
windows.kernel32 windows.types ;
IN: io.pipes.windows
! This code is based on
! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py

2
basis/io/sockets/sockets.factor
View File

@ -382,5 +382,5 @@ M: invalid-local-address summary
{
{ [ os unix? ] [ "io.sockets.unix" require ] }
{ [ os winnt? ] [ "io.sockets.windows.nt" require ] }
{ [ os windows? ] [ "io.sockets.windows" require ] }
} cond

0
basis/io/backend/windows/nt/authors.txt → basis/io/sockets/windows/authors.txt Executable file → Normal file
View File

3
basis/io/sockets/windows/nt/authors.txt
View File

@ -1,3 +0,0 @@
Doug Coleman
Slava Pestov
Mackenzie Straight

224
basis/io/sockets/windows/nt/nt.factor
View File

@ -1,224 +0,0 @@
USING: alien alien.accessors alien.c-types alien.data byte-arrays
continuations destructors io.ports io.timeouts io.sockets
io.sockets.private io namespaces io.streams.duplex
io.backend.windows io.sockets.windows io.backend.windows.nt
windows.winsock kernel libc math sequences threads system
combinators accessors classes.struct windows.kernel32
windows.types ;
IN: io.sockets.windows.nt
: malloc-int ( n -- alien )
<int> malloc-byte-array ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
GUID heap-size
{ void* }
[
void* heap-size
DWORD <c-object>
f
f
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
] with-out-parameters ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength
lpdwBytesSent lpOverlapped ptr ;
: wait-for-socket ( args -- n )
[ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
: <ConnectEx-args> ( sockaddr size -- ConnectEx )
ConnectEx-args new
swap >>namelen
swap >>name
f >>lpSendBuffer
0 >>dwSendDataLength
f >>lpdwBytesSent
(make-overlapped) >>lpOverlapped ; inline
: call-ConnectEx ( ConnectEx -- )
{
[ s>> ]
[ name>> ]
[ namelen>> ]
[ lpSendBuffer>> ]
[ dwSendDataLength>> ]
[ lpdwBytesSent>> ]
[ lpOverlapped>> ]
[ ptr>> ]
} cleave
int
{ SOCKET void* int PVOID DWORD LPDWORD void* }
stdcall alien-indirect drop
winsock-error-string [ throw ] when* ; inline
M: object establish-connection ( client-out remote -- )
make-sockaddr/size <ConnectEx-args>
swap >>port
dup port>> handle>> handle>> >>s
dup s>> get-ConnectEx-ptr >>ptr
dup call-ConnectEx
wait-for-socket drop ;
TUPLE: AcceptEx-args port
sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
: init-accept-buffer ( addr AcceptEx -- )
swap sockaddr-size 16 +
[ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
drop ; inline
: <AcceptEx-args> ( server addr -- AcceptEx )
AcceptEx-args new
2dup init-accept-buffer
swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
over handle>> handle>> >>sListenSocket
swap >>port
0 >>dwReceiveDataLength
f >>lpdwBytesReceived
(make-overlapped) >>lpOverlapped ; inline
: call-AcceptEx ( AcceptEx -- )
{
[ sListenSocket>> ]
[ sAcceptSocket>> ]
[ lpOutputBuffer>> ]
[ dwReceiveDataLength>> ]
[ dwLocalAddressLength>> ]
[ dwRemoteAddressLength>> ]
[ lpdwBytesReceived>> ]
[ lpOverlapped>> ]
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
: extract-remote-address ( AcceptEx -- sockaddr )
[
{
[ lpOutputBuffer>> ]
[ dwReceiveDataLength>> ]
[ dwLocalAddressLength>> ]
[ dwRemoteAddressLength>> ]
} cleave
(extract-remote-address)
] [ port>> addr>> protocol-family ] bi
sockaddr-of-family ; inline
M: object (accept) ( server addr -- handle sockaddr )
[
<AcceptEx-args>
{
[ call-AcceptEx ]
[ wait-for-socket drop ]
[ sAcceptSocket>> <win32-socket> ]
[ extract-remote-address ]
} cleave
] with-destructors ;
TUPLE: WSARecvFrom-args port
s lpBuffers dwBufferCount lpNumberOfBytesRecvd
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
: make-receive-buffer ( -- WSABUF )
WSABUF malloc-struct &free
default-buffer-size get
[ >>len ] [ malloc &free >>buf ] bi ; inline
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new
swap >>port
dup port>> handle>> handle>> >>s
dup port>> addr>> sockaddr-size
[ malloc &free >>lpFrom ]
[ malloc-int &free >>lpFromLen ] bi
make-receive-buffer >>lpBuffers
1 >>dwBufferCount
0 malloc-int &free >>lpFlags
0 malloc-int &free >>lpNumberOfBytesRecvd
(make-overlapped) >>lpOverlapped ; inline
: call-WSARecvFrom ( WSARecvFrom -- )
{
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesRecvd>> ]
[ lpFlags>> ]
[ lpFrom>> ]
[ lpFromLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSARecvFrom socket-error* ; inline
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers>> buf>> swap memory>byte-array ]
[
[ port>> addr>> empty-sockaddr dup ]
[ lpFrom>> ]
[ lpFromLen>> *int ]
tri memcpy
] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
[
<WSARecvFrom-args>
[ call-WSARecvFrom ]
[ wait-for-socket ]
[ parse-WSARecvFrom ]
tri
] with-destructors ;
TUPLE: WSASendTo-args port
s lpBuffers dwBufferCount lpNumberOfBytesSent
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
: make-send-buffer ( packet -- WSABUF )
[ WSABUF malloc-struct &free ] dip
[ malloc-byte-array &free >>buf ]
[ length >>len ] bi ; inline
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new
swap >>port
dup port>> handle>> handle>> >>s
swap make-sockaddr/size
[ malloc-byte-array &free ] dip
[ >>lpTo ] [ >>iToLen ] bi*
swap make-send-buffer >>lpBuffers
1 >>dwBufferCount
0 >>dwFlags
0 <uint> >>lpNumberOfBytesSent
(make-overlapped) >>lpOverlapped ; inline
: call-WSASendTo ( WSASendTo -- )
{
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesSent>> ]
[ dwFlags>> ]
[ lpTo>> ]
[ iToLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSASendTo socket-error* ; inline
M: winnt (send) ( packet addrspec datagram -- )
[
<WSASendTo-args>
[ call-WSASendTo ]
[ wait-for-socket drop ]
bi
] with-destructors ;

1
basis/io/sockets/windows/nt/platforms.txt
View File

@ -1 +0,0 @@
winnt

225
basis/io/sockets/windows/windows.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types classes.struct combinators
destructors io.backend io.backend.windows io.sockets
io.sockets.private kernel system windows.handles
windows.winsock ;
USING: accessors alien alien.c-types alien.data classes.struct
combinators destructors io.backend io.ports
io.sockets io.sockets.private kernel libc math sequences system
windows.handles windows.kernel32 windows.types windows.winsock ;
FROM: namespaces => get ;
IN: io.sockets.windows
@ -81,3 +81,220 @@ M: object (server) ( addrspec -- handle )
M: windows (datagram) ( addrspec -- handle )
[ SOCK_DGRAM server-socket ] with-destructors ;
: malloc-int ( n -- alien )
<int> malloc-byte-array ; inline
M: winnt WSASocket-flags ( -- DWORD )
WSA_FLAG_OVERLAPPED ;
: get-ConnectEx-ptr ( socket -- void* )
SIO_GET_EXTENSION_FUNCTION_POINTER
WSAID_CONNECTEX
GUID heap-size
{ void* }
[
void* heap-size
DWORD <c-object>
f
f
WSAIoctl SOCKET_ERROR = [
winsock-error-string throw
] when
] with-out-parameters ;
TUPLE: ConnectEx-args port
s name namelen lpSendBuffer dwSendDataLength
lpdwBytesSent lpOverlapped ptr ;
: wait-for-socket ( args -- n )
[ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
: <ConnectEx-args> ( sockaddr size -- ConnectEx )
ConnectEx-args new
swap >>namelen
swap >>name
f >>lpSendBuffer
0 >>dwSendDataLength
f >>lpdwBytesSent
(make-overlapped) >>lpOverlapped ; inline
: call-ConnectEx ( ConnectEx -- )
{
[ s>> ]
[ name>> ]
[ namelen>> ]
[ lpSendBuffer>> ]
[ dwSendDataLength>> ]
[ lpdwBytesSent>> ]
[ lpOverlapped>> ]
[ ptr>> ]
} cleave
int
{ SOCKET void* int PVOID DWORD LPDWORD void* }
stdcall alien-indirect drop
winsock-error-string [ throw ] when* ; inline
M: object establish-connection ( client-out remote -- )
make-sockaddr/size <ConnectEx-args>
swap >>port
dup port>> handle>> handle>> >>s
dup s>> get-ConnectEx-ptr >>ptr
dup call-ConnectEx
wait-for-socket drop ;
TUPLE: AcceptEx-args port
sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
: init-accept-buffer ( addr AcceptEx -- )
swap sockaddr-size 16 +
[ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
drop ; inline
: <AcceptEx-args> ( server addr -- AcceptEx )
AcceptEx-args new
2dup init-accept-buffer
swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
over handle>> handle>> >>sListenSocket
swap >>port
0 >>dwReceiveDataLength
f >>lpdwBytesReceived
(make-overlapped) >>lpOverlapped ; inline
: call-AcceptEx ( AcceptEx -- )
{
[ sListenSocket>> ]
[ sAcceptSocket>> ]
[ lpOutputBuffer>> ]
[ dwReceiveDataLength>> ]
[ dwLocalAddressLength>> ]
[ dwRemoteAddressLength>> ]
[ lpdwBytesReceived>> ]
[ lpOverlapped>> ]
} cleave AcceptEx drop
winsock-error-string [ throw ] when* ; inline
: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
: extract-remote-address ( AcceptEx -- sockaddr )
[
{
[ lpOutputBuffer>> ]
[ dwReceiveDataLength>> ]
[ dwLocalAddressLength>> ]
[ dwRemoteAddressLength>> ]
} cleave
(extract-remote-address)
] [ port>> addr>> protocol-family ] bi
sockaddr-of-family ; inline
M: object (accept) ( server addr -- handle sockaddr )
[
<AcceptEx-args>
{
[ call-AcceptEx ]
[ wait-for-socket drop ]
[ sAcceptSocket>> <win32-socket> ]
[ extract-remote-address ]
} cleave
] with-destructors ;
TUPLE: WSARecvFrom-args port
s lpBuffers dwBufferCount lpNumberOfBytesRecvd
lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
: make-receive-buffer ( -- WSABUF )
WSABUF malloc-struct &free
default-buffer-size get
[ >>len ] [ malloc &free >>buf ] bi ; inline
: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
WSARecvFrom-args new
swap >>port
dup port>> handle>> handle>> >>s
dup port>> addr>> sockaddr-size
[ malloc &free >>lpFrom ]
[ malloc-int &free >>lpFromLen ] bi
make-receive-buffer >>lpBuffers
1 >>dwBufferCount
0 malloc-int &free >>lpFlags
0 malloc-int &free >>lpNumberOfBytesRecvd
(make-overlapped) >>lpOverlapped ; inline
: call-WSARecvFrom ( WSARecvFrom -- )
{
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesRecvd>> ]
[ lpFlags>> ]
[ lpFrom>> ]
[ lpFromLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSARecvFrom socket-error* ; inline
: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
[ lpBuffers>> buf>> swap memory>byte-array ]
[
[ port>> addr>> empty-sockaddr dup ]
[ lpFrom>> ]
[ lpFromLen>> *int ]
tri memcpy
] bi ; inline
M: winnt (receive) ( datagram -- packet addrspec )
[
<WSARecvFrom-args>
[ call-WSARecvFrom ]
[ wait-for-socket ]
[ parse-WSARecvFrom ]
tri
] with-destructors ;
TUPLE: WSASendTo-args port
s lpBuffers dwBufferCount lpNumberOfBytesSent
dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
: make-send-buffer ( packet -- WSABUF )
[ WSABUF malloc-struct &free ] dip
[ malloc-byte-array &free >>buf ]
[ length >>len ] bi ; inline
: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
WSASendTo-args new
swap >>port
dup port>> handle>> handle>> >>s
swap make-sockaddr/size
[ malloc-byte-array &free ] dip
[ >>lpTo ] [ >>iToLen ] bi*
swap make-send-buffer >>lpBuffers
1 >>dwBufferCount
0 >>dwFlags
0 <uint> >>lpNumberOfBytesSent
(make-overlapped) >>lpOverlapped ; inline
: call-WSASendTo ( WSASendTo -- )
{
[ s>> ]
[ lpBuffers>> ]
[ dwBufferCount>> ]
[ lpNumberOfBytesSent>> ]
[ dwFlags>> ]
[ lpTo>> ]
[ iToLen>> ]
[ lpOverlapped>> ]
[ lpCompletionRoutine>> ]
} cleave WSASendTo socket-error* ; inline
M: winnt (send) ( packet addrspec datagram -- )
[
<WSASendTo-args>
[ call-WSASendTo ]
[ wait-for-socket drop ]
bi
] with-destructors ;

33
basis/system-info/windows/ce/ce.factor
View File

@ -1,33 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.data system-info kernel math namespaces
windows windows.kernel32 system-info.backend system ;
IN: system-info.windows.ce
: memory-status ( -- MEMORYSTATUS )
"MEMORYSTATUS" <c-object>
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
dup GlobalMemoryStatus ;
M: wince cpus ( -- n ) 1 ;
M: wince memory-load ( -- n )
memory-status MEMORYSTATUS-dwMemoryLoad ;
M: wince physical-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalPhys ;
M: wince available-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailPhys ;
M: wince total-page-file ( -- n )
memory-status MEMORYSTATUS-dwTotalPageFile ;
M: wince available-page-file ( -- n )
memory-status MEMORYSTATUS-dwAvailPageFile ;
M: wince total-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwTotalVirtual ;
M: wince available-virtual-mem ( -- n )
memory-status MEMORYSTATUS-dwAvailVirtual ;

1
basis/system-info/windows/ce/platforms.txt
View File

@ -1 +0,0 @@
wince

1
basis/system-info/windows/nt/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

47
basis/system-info/windows/nt/nt.factor
View File

@ -1,47 +0,0 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings
kernel libc math namespaces system-info.backend
system-info.windows windows windows.advapi32
windows.kernel32 system byte-arrays windows.errors
classes classes.struct accessors ;
IN: system-info.windows.nt
M: winnt cpus ( -- n )
system-info dwNumberOfProcessors>> ;
: memory-status ( -- MEMORYSTATUSEX )
MEMORYSTATUSEX <struct>
MEMORYSTATUSEX heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ;
M: winnt memory-load ( -- n )
memory-status dwMemoryLoad>> ;
M: winnt physical-mem ( -- n )
memory-status ullTotalPhys>> ;
M: winnt available-mem ( -- n )
memory-status ullAvailPhys>> ;
M: winnt total-page-file ( -- n )
memory-status ullTotalPageFile>> ;
M: winnt available-page-file ( -- n )
memory-status ullAvailPageFile>> ;
M: winnt total-virtual-mem ( -- n )
memory-status ullTotalVirtual>> ;
M: winnt available-virtual-mem ( -- n )
memory-status ullAvailVirtual>> ;
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep <uint>
GetComputerName win32-error=0/f alien>native-string ;
: username ( -- string )
UNLEN 1 +
[ <byte-array> dup ] keep <uint>
GetUserName win32-error=0/f alien>native-string ;

1
basis/system-info/windows/nt/platforms.txt
View File

@ -1 +0,0 @@
winnt

5
basis/system-info/windows/nt/nt-tests.factor → basis/system-info/windows/windows-tests.factor Executable file → Normal file
View File

@ -1,7 +1,6 @@
USING: math.order strings system-info.backend
system-info.windows system-info.windows.nt
tools.test ;
IN: system-info.windows.nt.tests
system-info.windows tools.test ;
IN: system-info.windows.tests
[ t ] [ cpus 0 1024 between? ] unit-test
[ t ] [ username string? ] unit-test

52
basis/system-info/windows/windows.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types classes.struct accessors kernel
math namespaces windows windows.kernel32 windows.advapi32 words
combinators vocabs.loader system-info.backend system
alien.strings windows.errors specialized-arrays ;
USING: accessors alien alien.c-types alien.strings byte-arrays
classes.struct combinators kernel math namespaces
specialized-arrays system
system-info.backend vocabs.loader windows windows.advapi32
windows.errors windows.kernel32 words ;
SPECIALIZED-ARRAY: ushort
IN: system-info.windows
@ -63,8 +64,41 @@ IN: system-info.windows
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
<<
{
{ [ os wince? ] [ "system-info.windows.ce" ] }
{ [ os winnt? ] [ "system-info.windows.nt" ] }
} cond require >>
M: winnt cpus ( -- n )
system-info dwNumberOfProcessors>> ;
: memory-status ( -- MEMORYSTATUSEX )
MEMORYSTATUSEX <struct>
MEMORYSTATUSEX heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ;
M: winnt memory-load ( -- n )
memory-status dwMemoryLoad>> ;
M: winnt physical-mem ( -- n )
memory-status ullTotalPhys>> ;
M: winnt available-mem ( -- n )
memory-status ullAvailPhys>> ;
M: winnt total-page-file ( -- n )
memory-status ullTotalPageFile>> ;
M: winnt available-page-file ( -- n )
memory-status ullAvailPageFile>> ;
M: winnt total-virtual-mem ( -- n )
memory-status ullTotalVirtual>> ;
M: winnt available-virtual-mem ( -- n )
memory-status ullAvailVirtual>> ;
: computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 +
[ <byte-array> dup ] keep <uint>
GetComputerName win32-error=0/f alien>native-string ;
: username ( -- string )
UNLEN 1 +
[ <byte-array> dup ] keep <uint>
GetUserName win32-error=0/f alien>native-string ;

2
basis/tools/deploy/windows/windows.factor
View File

@ -6,7 +6,7 @@ sequences locals system splitting tools.deploy.backend
tools.deploy.config tools.deploy.config.editor assocs hashtables
prettyprint combinators windows.kernel32 windows.shell32 windows.user32
alien.c-types vocabs.metadata vocabs.loader tools.deploy.windows.ico
io.files.windows.nt ;
io.files.windows ;
IN: tools.deploy.windows
CONSTANT: app-icon-resource-id "APPICON"

2
basis/ui/backend/windows/windows.factor
View File

@ -7,7 +7,7 @@ ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
kernel math math.vectors namespaces make sequences strings
vectors words windows.dwmapi system-info.windows windows.kernel32
windows.gdi32 windows.user32 windows.opengl32 windows.messages
windows.types windows.offscreen windows.nt threads libc combinators
windows.types windows.offscreen windows threads libc combinators
fry combinators.short-circuit continuations command-line shuffle
opengl ui.render math.bitwise locals accessors math.rectangles
math.order calendar ascii sets io.encodings.utf16n

1
basis/windows/ce/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

14
basis/windows/ce/ce.factor
View File

@ -1,14 +0,0 @@
USING: alien sequences alien.libraries ;
{
{ "advapi32" "\\windows\\coredll.dll" stdcall }
{ "gdi32" "\\windows\\coredll.dll" stdcall }
{ "user32" "\\windows\\coredll.dll" stdcall }
{ "kernel32" "\\windows\\coredll.dll" stdcall }
{ "winsock" "\\windows\\ws2.dll" stdcall }
{ "mswsock" "\\windows\\ws2.dll" stdcall }
{ "libc" "\\windows\\coredll.dll" stdcall }
{ "libm" "\\windows\\coredll.dll" stdcall }
! { "gl" "libGLES_CM.dll" stdcall }
! { "glu" "libGLES_CM.dll" stdcall }
{ "ole32" "ole32.dll" stdcall }
} [ first3 add-library ] each

1
basis/windows/ce/platforms.txt
View File

@ -1 +0,0 @@
wince

1
basis/windows/nt/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

35
basis/windows/nt/nt.factor
View File

@ -1,35 +0,0 @@
USING: alien sequences alien.libraries ;
{
{ "advapi32" "advapi32.dll" stdcall }
{ "dinput" "dinput8.dll" stdcall }
{ "gdi32" "gdi32.dll" stdcall }
{ "user32" "user32.dll" stdcall }
{ "kernel32" "kernel32.dll" stdcall }
{ "winsock" "ws2_32.dll" stdcall }
{ "mswsock" "mswsock.dll" stdcall }
{ "shell32" "shell32.dll" stdcall }
{ "libc" "msvcrt.dll" cdecl }
{ "libm" "msvcrt.dll" cdecl }
{ "gl" "opengl32.dll" stdcall }
{ "glu" "glu32.dll" stdcall }
{ "ole32" "ole32.dll" stdcall }
{ "usp10" "usp10.dll" stdcall }
{ "psapi" "psapi.dll" stdcall }
{ "xinput" "xinput1_3.dll" stdcall }
{ "dxgi" "dxgi.dll" stdcall }
{ "d2d1" "d2d1.dll" stdcall }
{ "d3d9" "d3d9.dll" stdcall }
{ "d3d10" "d3d10.dll" stdcall }
{ "d3d10_1" "d3d10_1.dll" stdcall }
{ "d3d11" "d3d11.dll" stdcall }
{ "d3dcompiler" "d3dcompiler_42.dll" stdcall }
{ "d3dcsx" "d3dcsx_42.dll" stdcall }
{ "d3dx9" "d3dx9_42.dll" stdcall }
{ "d3dx10" "d3dx10_42.dll" stdcall }
{ "d3dx11" "d3dx11_42.dll" stdcall }
{ "dwrite" "dwrite.dll" stdcall }
{ "x3daudio" "x3daudio1_6.dll" stdcall }
{ "xactengine" "xactengine3_5.dll" stdcall }
{ "xapofx" "xapofx1_3.dll" stdcall }
{ "xaudio2" "xaudio2_5.dll" stdcall }
} [ first3 add-library ] each

1
basis/windows/nt/platforms.txt
View File

@ -1 +0,0 @@
winnt

0
basis/system-info/windows/ce/authors.txt → basis/windows/privileges/authors.txt Executable file → Normal file
View File

0
basis/io/backend/windows/privileges/platforms.txt → basis/windows/privileges/platforms.txt
View File

4
basis/windows/privileges/privileges-tests.factor Normal file
View File

@ -0,0 +1,4 @@
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test windows.privileges ;
IN: windows.privileges.tests

21
basis/io/backend/windows/nt/privileges/privileges.factor → basis/windows/privileges/privileges.factor
View File

@ -1,11 +1,9 @@
USING: alien alien.c-types alien.data alien.syntax arrays
continuations destructors generic io.mmap io.ports
io.backend.windows io.files.windows kernel libc fry locals math
math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 windows.types io.backend
system accessors io.backend.windows.privileges classes.struct
windows.errors literals ;
IN: io.backend.windows.nt.privileges
! Copyright (C) 2010 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.data alien.syntax classes.struct
continuations fry kernel libc literals locals sequences
windows.advapi32 windows.errors windows.kernel32 windows.types ;
IN: windows.privileges
TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@ -40,7 +38,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
name lookup-privilege >>Luid
>>Privileges ;
M: winnt set-privilege ( name ? -- )
: set-privilege ( name ? -- )
'[
0
_ _ make-token-privileges
@ -49,3 +47,8 @@ M: winnt set-privilege ( name ? -- )
f
AdjustTokenPrivileges win32-error=0/f
] with-process-token ;
: with-privileges ( seq quot -- )
[ '[ _ [ t set-privilege ] each @ ] ]
[ drop '[ _ [ f set-privilege ] each ] ]
2bi [ ] cleanup ; inline

36
basis/windows/windows.factor
View File

@ -1,5 +1,41 @@
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien sequences alien.libraries ;
IN: windows
CONSTANT: MAX_UNICODE_PATH 32768
{
{ "advapi32" "advapi32.dll" stdcall }
{ "dinput" "dinput8.dll" stdcall }
{ "gdi32" "gdi32.dll" stdcall }
{ "user32" "user32.dll" stdcall }
{ "kernel32" "kernel32.dll" stdcall }
{ "winsock" "ws2_32.dll" stdcall }
{ "mswsock" "mswsock.dll" stdcall }
{ "shell32" "shell32.dll" stdcall }
{ "libc" "msvcrt.dll" cdecl }
{ "libm" "msvcrt.dll" cdecl }
{ "gl" "opengl32.dll" stdcall }
{ "glu" "glu32.dll" stdcall }
{ "ole32" "ole32.dll" stdcall }
{ "usp10" "usp10.dll" stdcall }
{ "psapi" "psapi.dll" stdcall }
{ "xinput" "xinput1_3.dll" stdcall }
{ "dxgi" "dxgi.dll" stdcall }
{ "d2d1" "d2d1.dll" stdcall }
{ "d3d9" "d3d9.dll" stdcall }
{ "d3d10" "d3d10.dll" stdcall }
{ "d3d10_1" "d3d10_1.dll" stdcall }
{ "d3d11" "d3d11.dll" stdcall }
{ "d3dcompiler" "d3dcompiler_42.dll" stdcall }
{ "d3dcsx" "d3dcsx_42.dll" stdcall }
{ "d3dx9" "d3dx9_42.dll" stdcall }
{ "d3dx10" "d3dx10_42.dll" stdcall }
{ "d3dx11" "d3dx11_42.dll" stdcall }
{ "dwrite" "dwrite.dll" stdcall }
{ "x3daudio" "x3daudio1_6.dll" stdcall }
{ "xactengine" "xactengine3_5.dll" stdcall }
{ "xapofx" "xapofx1_3.dll" stdcall }
{ "xaudio2" "xaudio2_5.dll" stdcall }
} [ first3 add-library ] each

1
unmaintained/ce/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

3
unmaintained/ce/backend/authors.txt
View File

@ -1,3 +0,0 @@
Doug Coleman
Slava Pestov
Mackenzie Straight

50
unmaintained/ce/backend/backend.factor
View File

@ -1,50 +0,0 @@
USING: io.ports io.windows threads.private kernel
io.backend windows.winsock windows.kernel32 windows
io.streams.duplex io namespaces alien.syntax system combinators
io.buffers io.encodings io.encodings.utf8 combinators.lib ;
IN: io.windows.ce.backend
: port-errored ( port -- )
win32-error-string swap set-port-error ;
M: wince io-multiplex ( ms -- )
60 60 * 1000 * or (sleep) ;
M: wince add-completion ( handle -- ) drop ;
GENERIC: wince-read ( port port-handle -- )
M: input-port (wait-to-read) ( port -- )
dup dup port-handle wince-read pending-error ;
GENERIC: wince-write ( port port-handle -- )
M: port port-flush
dup buffer-empty? over port-error or [
drop
] [
dup dup port-handle wince-write port-flush
] if ;
M: wince init-io ( -- )
init-winsock ;
LIBRARY: libc
FUNCTION: void* _getstdfilex int fd ;
FUNCTION: void* _fileno void* file ;
M: wince (init-stdio) ( -- )
#! We support Windows NT too, to make this I/O backend
#! easier to debug.
512 default-buffer-size [
os winnt? [
STD_INPUT_HANDLE GetStdHandle
STD_OUTPUT_HANDLE GetStdHandle
STD_ERROR_HANDLE GetStdHandle
] [
0 _getstdfilex _fileno
1 _getstdfilex _fileno
2 _getstdfilex _fileno
] if [ f <win32-file> ] 3apply
[ <input-port> ] [ <output-port> ] [ <output-port> ] tri*
] with-variable ;

11
unmaintained/ce/ce.factor
View File

@ -1,11 +0,0 @@
USE: io.backend
USE: io.windows
USE: io.windows.ce.backend
USE: io.windows.ce.files
USE: io.windows.ce.sockets
USE: io.windows.ce.launcher
USE: io.windows.mmap system
USE: io.windows.files
USE: system
wince set-io-backend

2
unmaintained/ce/files/authors.txt
View File

@ -1,2 +0,0 @@
Doug Coleman
Slava Pestov

32
unmaintained/ce/files/files.factor
View File

@ -1,32 +0,0 @@
USING: alien alien.c-types combinators io io.backend io.buffers
io.files io.ports io.windows kernel libc math namespaces
prettyprint sequences strings threads threads.private
windows windows.kernel32 io.windows.ce.backend system ;
IN: windows.ce.files
! M: wince normalize-path ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: wince CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ;
M: wince FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )
swap [ drop port-errored ] [ swap n>buffer ] if ;
M: win32-file wince-read
drop
dup make-FileArgs dup setup-read ReadFile zero?
swap FileArgs-lpNumberOfBytesRet *uint dup zero? [
2drop t swap set-port-eof?
] [
finish-read
] if ;
M: win32-file wince-write ( port port-handle -- )
drop dup make-FileArgs dup setup-write WriteFile zero? [
drop port-errored
] [
FileArgs-lpNumberOfBytesRet *uint
swap buffer-consume
] if ;

4
unmaintained/ce/privileges/privileges.factor
View File

@ -1,4 +0,0 @@
IN: io.windows.ce.privileges
USING: io.windows.privileges system ;
M: wince set-privilege 2drop ;

2
unmaintained/ce/sockets/authors.txt
View File

@ -1,2 +0,0 @@
Doug Coleman
Slava Pestov

113
unmaintained/ce/sockets/sockets.factor
View File

@ -1,113 +0,0 @@
USING: alien alien.c-types combinators io io.backend io.buffers
io.ports io.sockets io.windows kernel libc
math namespaces prettyprint qualified sequences strings threads
threads.private windows windows.kernel32 io.windows.ce.backend
byte-arrays system ;
QUALIFIED: windows.winsock
IN: io.windows.ce
M: wince WSASocket-flags ( -- DWORD ) 0 ;
M: win32-socket wince-read ( port port-handle -- )
win32-file-handle over buffer-end pick buffer-capacity 0
windows.winsock:recv
dup windows.winsock:SOCKET_ERROR = [
drop port-errored
] [
dup zero?
[ drop t swap set-port-eof? ] [ swap n>buffer ] if
] if ;
M: win32-socket wince-write ( port port-handle -- )
win32-file-handle over buffer@ pick buffer-length 0
windows.winsock:send
dup windows.winsock:SOCKET_ERROR =
[ drop port-errored ] [ swap buffer-consume ] if ;
: do-connect ( addrspec -- socket )
[ tcp-socket dup ] keep
make-sockaddr/size
f f f f
windows.winsock:WSAConnect
windows.winsock:winsock-error!=0/f ;
M: wince (client) ( addrspec -- reader writer )
do-connect <win32-socket> dup <ports> ;
M: wince (server) ( addrspec -- handle )
windows.winsock:SOCK_STREAM server-fd
dup listen-on-socket
<win32-socket> ;
M: wince (accept) ( server -- client )
[
[
dup port-handle win32-file-handle
swap server-port-addr sockaddr-type heap-size
dup <byte-array> [
swap <int> f 0
windows.winsock:WSAAccept
dup windows.winsock:INVALID_SOCKET =
[ windows.winsock:winsock-error ] when
] keep
] keep server-port-addr parse-sockaddr swap
<win32-socket> <ports>
] with-timeout ;
M: wince <datagram> ( addrspec -- datagram )
[
windows.winsock:SOCK_DGRAM server-fd <win32-socket>
] keep <datagram-port> ;
: packet-size 65536 ; inline
: receive-buffer ( -- buf )
\ receive-buffer get-global expired? [
packet-size malloc \ receive-buffer set-global
] when
\ receive-buffer get-global ;
: make-WSABUF ( len buf -- ptr )
"WSABUF" <c-object>
[ windows.winsock:set-WSABUF-buf ] keep
[ windows.winsock:set-WSABUF-len ] keep ;
: receive-WSABUF ( -- buf )
packet-size receive-buffer make-WSABUF ;
: packet-data ( len -- byte-array )
receive-buffer swap memory>byte-array ;
packet-size <byte-array> receive-buffer set-global
M: wince receive ( datagram -- packet addrspec )
dup check-datagram-port
[
port-handle win32-file-handle
receive-WSABUF
1
0 <uint> [
0 <uint>
64 "char" <c-array> [
64 <int>
f
f
windows.winsock:WSARecvFrom
windows.winsock:winsock-error!=0/f
] keep
] keep *uint packet-data swap
] keep datagram-port-addr parse-sockaddr ;
: send-WSABUF ( byte-array -- ptr )
dup length packet-size > [ "UDP packet too long" throw ] when
dup length receive-buffer rot pick memcpy
receive-buffer make-WSABUF ;
M: wince send ( packet addrspec datagram -- )
3dup check-datagram-send
port-handle win32-file-handle
rot send-WSABUF
rot make-sockaddr/size
>r >r 1 0 <uint> 0 r> r> f f
windows.winsock:WSASendTo
windows.winsock:winsock-error!=0/f ;

1
unmaintained/ce/summary.txt
View File

@ -1 +0,0 @@
Microsoft Windows CE native I/O implementation

19
vm/Config.windows
View File

@ -1,10 +1,17 @@
CFLAGS += -mno-cygwin
LIBS = -lm
PLAF_DLL_OBJS += vm/os-windows.o
CFLAGS += -mno-cygwin -mwindows
CFLAGS_CONSOLE += -mconsole
SHARED_FLAG = -shared
EXE_EXTENSION=.exe
CONSOLE_EXTENSION=.com
DLL_EXTENSION=.dll
SHARED_DLL_EXTENSION=.dll
LIBS = -lm
PLAF_EXE_OBJS += vm/resources.o vm/main-windows.o
EXE_SUFFIX=
EXE_EXTENSION=.exe
DLL_SUFFIX=
DLL_EXTENSION=.dll
CONSOLE_EXTENSION=.com
LINKER = $(CPP) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)

5
vm/Config.windows.ce
View File

@ -1,5 +0,0 @@
CFLAGS += -DWINCE
LIBS = -lm
PLAF_DLL_OBJS += vm/os-windows-ce.o
PLAF_EXE_OBJS += vm/main-windows-ce.o
include vm/Config.windows

4
vm/Config.windows.ce.arm
View File

@ -1,4 +0,0 @@
CC = arm-wince-mingw32ce-gcc
DLL_SUFFIX=-ce
EXE_SUFFIX=-ce
include vm/Config.windows.ce vm/Config.arm

10
vm/Config.windows.nt
View File

@ -1,10 +0,0 @@
LIBS = -lm
EXE_SUFFIX=
DLL_SUFFIX=
PLAF_DLL_OBJS += vm/os-windows-nt.o vm/mvm-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o
CFLAGS += -mwindows
CFLAGS_CONSOLE += -mconsole
CONSOLE_EXTENSION = .com
include vm/Config.windows

4
vm/Config.windows.nt.x86.32 → vm/Config.windows.x86.32
View File

@ -1,5 +1,5 @@
PLAF_DLL_OBJS += vm/os-windows-nt-x86.32.o
PLAF_DLL_OBJS += vm/os-windows-x86.32.o
DLL_PATH=http://factorcode.org/dlls
WINDRES=windres
include vm/Config.windows.nt
include vm/Config.windows
include vm/Config.x86.32

4
vm/Config.windows.nt.x86.64 → vm/Config.windows.x86.64
View File

@ -1,6 +1,6 @@
PLAF_DLL_OBJS += vm/os-windows-nt-x86.64.o
PLAF_DLL_OBJS += vm/os-windows-x86.64.o
DLL_PATH=http://factorcode.org/dlls/64
CC=$(WIN64_PATH)-gcc.exe
WINDRES=$(WIN64_PATH)-windres.exe
include vm/Config.windows.nt
include vm/Config.windows
include vm/Config.x86.64

2
vm/code_heap.cpp
View File

@ -13,7 +13,7 @@ code_heap::code_heap(cell size)
allocator = new free_list_allocator<code_block>(seg->end - start,start);
/* See os-windows-nt-x86.64.cpp for seh_area usage */
/* See os-windows-x86.64.cpp for seh_area usage */
seh_area = (char *)seg->start;
}

132
vm/main-windows-ce.cpp
View File

@ -1,132 +0,0 @@
#include "master.hpp"
/*
Windows argument parsing ported to work on
int main(int argc, wchar_t **argv).
Based on MinGW's public domain char** version.
*/
VM_C_API int parse_tokens(wchar_t *string, wchar_t ***tokens, int length)
{
/* Extract whitespace- and quotes- delimited tokens from the given string
and put them into the tokens array. Returns number of tokens
extracted. Length specifies the current size of tokens[].
THIS METHOD MODIFIES string. */
const wchar_t *whitespace = L" \t\r\n";
wchar_t *tokenEnd = 0;
const wchar_t *quoteCharacters = L"\"\'";
wchar_t *end = string + wcslen(string);
if (string == NULL)
return length;
while (1)
{
const wchar_t *q;
/* Skip over initial whitespace. */
string += wcsspn(string, whitespace);
if (*string == '\0')
break;
for (q = quoteCharacters; *q; ++q)
{
if (*string == *q)
break;
}
if (*q)
{
/* Token is quoted. */
wchar_t quote = *string++;
tokenEnd = wcschr(string, quote);
/* If there is no endquote, the token is the rest of the string. */
if (!tokenEnd)
tokenEnd = end;
}
else
{
tokenEnd = string + wcscspn(string, whitespace);
}
*tokenEnd = '\0';
{
wchar_t **new_tokens;
int newlen = length + 1;
new_tokens = (wchar_t **)realloc (*tokens, sizeof (wchar_t**) * newlen);
if (!new_tokens)
{
/* Out of memory. */
return -1;
}
*tokens = new_tokens;
(*tokens)[length] = string;
length = newlen;
}
if (tokenEnd == end)
break;
string = tokenEnd + 1;
}
return length;
}
VM_C_API void parse_args(int *argc, wchar_t ***argv, wchar_t *cmdlinePtrW)
{
int cmdlineLen = 0;
if (!cmdlinePtrW)
cmdlineLen = 0;
else
cmdlineLen = wcslen(cmdlinePtrW);
/* gets realloc()'d later */
*argc = 0;
*argv = (wchar_t **)malloc (sizeof (wchar_t**));
if (!*argv)
ExitProcess(1);
#ifdef WINCE
wchar_t cmdnameBufW[MAX_UNICODE_PATH];
/* argv[0] is the path of invoked program - get this from CE. */
cmdnameBufW[0] = 0;
GetModuleFileNameW(NULL, cmdnameBufW, sizeof (cmdnameBufW)/sizeof (cmdnameBufW[0]));
(*argv)[0] = wcsdup(cmdnameBufW);
if(!(*argv[0]))
ExitProcess(1);
/* Add one to account for argv[0] */
(*argc)++;
#endif
if (cmdlineLen > 0)
{
wchar_t *string = wcsdup(cmdlinePtrW);
if(!string)
ExitProcess(1);
*argc = parse_tokens(string, argv, *argc);
if (*argc < 0)
ExitProcess(1);
}
(*argv)[*argc] = 0;
return;
}
int WINAPI WinMain(
HINSTANCE hInstance,
HINSTANCE hPrevInstance,
LPWSTR lpCmdLine,
int nCmdShow)
{
int __argc;
wchar_t **__argv;
factor::parse_args(&__argc, &__argv, lpCmdLine);
factor::init_globals();
factor::start_standalone_factor(__argc,(LPWSTR*)__argv);
// memory leak from malloc, wcsdup
return 0;
}

0
vm/main-windows-nt.cpp → vm/main-windows.cpp Executable file → Normal file
View File

0
vm/mvm-windows-nt.cpp → vm/mvm-windows.cpp
View File

30
vm/os-windows-ce.cpp
View File

@ -1,30 +0,0 @@
#include "master.hpp"
namespace factor
{
char *strerror(int err)
{
/* strerror() is not defined on WinCE */
return "strerror() is not defined on WinCE. Use native I/O.";
}
void flush_icache(cell start, cell end)
{
FlushInstructionCache(GetCurrentProcess(), 0, 0);
}
char *getenv(char *name)
{
vm->not_implemented_error();
return 0; /* unreachable */
}
void c_to_factor_toplevel(cell quot)
{
c_to_factor(quot,vm);
}
void open_console() { }
}

27
vm/os-windows-ce.hpp
View File

@ -1,27 +0,0 @@
#ifndef UNICODE
#define UNICODE
#endif
#include <windows.h>
#include <ctype.h>
namespace factor
{
typedef wchar_t symbol_char;
#define FACTOR_OS_STRING "wince"
#define FACTOR_DLL L"factor-ce.dll"
int errno;
char *strerror(int err);
void flush_icache(cell start, cell end);
char *getenv(char *name);
#define snprintf _snprintf
#define snwprintf _snwprintf
void c_to_factor_toplevel(cell quot);
void open_console();
}

100
vm/os-windows-nt.cpp
View File

@ -1,100 +0,0 @@
#include "master.hpp"
namespace factor
{
THREADHANDLE start_thread(void *(*start_routine)(void *), void *args)
{
return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
u64 nano_count()
{
static double scale_factor;
static u32 hi = 0;
static u32 lo = 0;
LARGE_INTEGER count;
BOOL ret = QueryPerformanceCounter(&count);
if(ret == 0)
fatal_error("QueryPerformanceCounter", 0);
if(scale_factor == 0.0)
{
LARGE_INTEGER frequency;
BOOL ret = QueryPerformanceFrequency(&frequency);
if(ret == 0)
fatal_error("QueryPerformanceFrequency", 0);
scale_factor = (1000000000.0 / frequency.QuadPart);
}
#ifdef FACTOR_64
hi = count.HighPart;
#else
/* On VirtualBox, QueryPerformanceCounter does not increment
the high part every time the low part overflows. Workaround. */
if(lo > count.LowPart)
hi++;
#endif
lo = count.LowPart;
return (u64)((((u64)hi << 32) | (u64)lo) * scale_factor);
}
void sleep_nanos(u64 nsec)
{
Sleep((DWORD)(nsec/1000000));
}
LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
{
c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP);
ctx->callstack_top = (stack_frame *)c->ESP;
switch (e->ExceptionCode)
{
case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (cell)factor::memory_signal_handler_impl;
break;
case STATUS_FLOAT_DENORMAL_OPERAND:
case STATUS_FLOAT_DIVIDE_BY_ZERO:
case STATUS_FLOAT_INEXACT_RESULT:
case STATUS_FLOAT_INVALID_OPERATION:
case STATUS_FLOAT_OVERFLOW:
case STATUS_FLOAT_STACK_CHECK:
case STATUS_FLOAT_UNDERFLOW:
case STATUS_FLOAT_MULTIPLE_FAULTS:
case STATUS_FLOAT_MULTIPLE_TRAPS:
#ifdef FACTOR_64
signal_fpu_status = fpu_status(MXCSR(c));
#else
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
/* This seems to have no effect */
X87SW(c) = 0;
#endif
MXCSR(c) &= 0xffffffc0;
c->EIP = (cell)factor::fp_signal_handler_impl;
break;
default:
signal_number = e->ExceptionCode;
c->EIP = (cell)factor::misc_signal_handler_impl;
break;
}
return 0;
}
VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
{
return current_vm()->exception_handler(e,frame,c,dispatch);
}
void factor_vm::open_console()
{
}
}

42
vm/os-windows-nt.hpp
View File

@ -1,42 +0,0 @@
#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
#ifndef UNICODE
#define UNICODE
#endif
#include <windows.h>
#include <shellapi.h>
#ifdef _MSC_VER
#undef min
#undef max
#endif
namespace factor
{
typedef char symbol_char;
#define FACTOR_OS_STRING "winnt"
#define FACTOR_DLL NULL
VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
// SSE traps raise these exception codes, which are defined in internal NT headers
// but not winbase.h
#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
#endif
#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5
#endif
typedef HANDLE THREADHANDLE;
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
inline static THREADHANDLE thread_id() { return GetCurrentThread(); }
}

0
vm/os-windows-nt-x86.32.cpp → vm/os-windows-x86.32.cpp
View File

0
vm/os-windows-nt-x86.64.cpp → vm/os-windows-x86.64.cpp
View File

0
vm/os-windows-nt.32.hpp → vm/os-windows.32.hpp Executable file → Normal file
View File

0
vm/os-windows-nt.64.hpp → vm/os-windows.64.hpp Executable file → Normal file
View File

92
vm/os-windows.cpp
View File

@ -151,4 +151,96 @@ void factor_vm::move_file(const vm_char *path1, const vm_char *path2)
void factor_vm::init_signals() {}
THREADHANDLE start_thread(void *(*start_routine)(void *), void *args)
{
return (void *)CreateThread(NULL, 0, (LPTHREAD_START_ROUTINE)start_routine, args, 0, 0);
}
u64 nano_count()
{
static double scale_factor;
static u32 hi = 0;
static u32 lo = 0;
LARGE_INTEGER count;
BOOL ret = QueryPerformanceCounter(&count);
if(ret == 0)
fatal_error("QueryPerformanceCounter", 0);
if(scale_factor == 0.0)
{
LARGE_INTEGER frequency;
BOOL ret = QueryPerformanceFrequency(&frequency);
if(ret == 0)
fatal_error("QueryPerformanceFrequency", 0);
scale_factor = (1000000000.0 / frequency.QuadPart);
}
#ifdef FACTOR_64
hi = count.HighPart;
#else
/* On VirtualBox, QueryPerformanceCounter does not increment
the high part every time the low part overflows. Workaround. */
if(lo > count.LowPart)
hi++;
#endif
lo = count.LowPart;
return (u64)((((u64)hi << 32) | (u64)lo) * scale_factor);
}
void sleep_nanos(u64 nsec)
{
Sleep((DWORD)(nsec/1000000));
}
LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
{
c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP);
ctx->callstack_top = (stack_frame *)c->ESP;
switch (e->ExceptionCode)
{
case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (cell)factor::memory_signal_handler_impl;
break;
case STATUS_FLOAT_DENORMAL_OPERAND:
case STATUS_FLOAT_DIVIDE_BY_ZERO:
case STATUS_FLOAT_INEXACT_RESULT:
case STATUS_FLOAT_INVALID_OPERATION:
case STATUS_FLOAT_OVERFLOW:
case STATUS_FLOAT_STACK_CHECK:
case STATUS_FLOAT_UNDERFLOW:
case STATUS_FLOAT_MULTIPLE_FAULTS:
case STATUS_FLOAT_MULTIPLE_TRAPS:
#ifdef FACTOR_64
signal_fpu_status = fpu_status(MXCSR(c));
#else
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
/* This seems to have no effect */
X87SW(c) = 0;
#endif
MXCSR(c) &= 0xffffffc0;
c->EIP = (cell)factor::fp_signal_handler_impl;
break;
default:
signal_number = e->ExceptionCode;
c->EIP = (cell)factor::misc_signal_handler_impl;
break;
}
return 0;
}
VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
{
return current_vm()->exception_handler(e,frame,c,dispatch);
}
void factor_vm::open_console() {}
}

41
vm/os-windows.hpp
View File

@ -5,10 +5,30 @@
#include <wchar.h>
#endif
#undef _WIN32_WINNT
#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
#ifndef UNICODE
#define UNICODE
#endif
#include <windows.h>
#include <shellapi.h>
#ifdef _MSC_VER
#undef min
#undef max
#endif
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
namespace factor
{
typedef wchar_t vm_char;
typedef char symbol_char;
typedef HANDLE THREADHANDLE;
#define STRING_LITERAL(string) L##string
@ -29,17 +49,30 @@ typedef wchar_t vm_char;
#define SNPRINTF snprintf
#endif
#define FACTOR_OS_STRING "winnt"
#define FACTOR_DLL NULL
// SSE traps raise these exception codes, which are defined in internal NT headers
// but not winbase.h
#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
#endif
#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5
#endif
#define OPEN_READ(path) _wfopen((path),L"rb")
#define OPEN_WRITE(path) _wfopen((path),L"wb")
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
inline static void early_init() {}
u64 nano_count();
void sleep_nanos(u64 nsec);
long getpagesize();
void move_file(const vm_char *path1, const vm_char *path2);
VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
inline static THREADHANDLE thread_id() { return GetCurrentThread(); }
}

10
vm/platform.hpp
View File

@ -1,15 +1,11 @@
#if defined(WINDOWS)
#if defined(WINCE)
#include "os-windows-ce.hpp"
#if defined(WINNT)
#include "os-windows.hpp"
#elif defined(WINNT)
#include "os-windows.hpp"
#include "os-windows-nt.hpp"
#if defined(FACTOR_AMD64)
#include "os-windows-nt.64.hpp"
#include "os-windows.64.hpp"
#elif defined(FACTOR_X86)
#include "os-windows-nt.32.hpp"
#include "os-windows.32.hpp"
#else
#error "Unsupported Windows flavor"
#endif