From: Doug Coleman Date: Sun, 19 Sep 2010 19:02:32 +0000 (-0500) Subject: Squashed commit of the following: X-Git-Tag: 0.97~4257^2~104 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=f791c8c5d251fd69ca44d05d857e9e34cf09b9b9 Squashed commit of the following: commit 197dbe9a6733775ac0ea19b3da4bd4dc3c85418c Author: Doug Coleman Date: Sat Sep 18 19:01:38 2010 -0500 Fix bootstrap, move privileges to windows.privileges commit 521c622f8afb15bf42d263c738cb990560dc29cb Author: Doug Coleman Date: Sat Sep 18 18:26:30 2010 -0500 Hopefully fix bootstrap commit eb3f22928b59758b9505430034044b5b94705da2 Author: Doug Coleman Date: Sat Sep 18 18:19:05 2010 -0500 Remove wince from factor codebase commit 619d6c99415f46208a7ede6a04b0ccda46b15360 Author: Doug Coleman Date: Sat Sep 18 16:07:46 2010 -0500 Remove Windows CE from vm/ --- diff --git a/GNUmakefile b/GNUmakefile index 09aa5ee6bf..38e3b0d736 100755 --- a/GNUmakefile +++ b/GNUmakefile @@ -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 diff --git a/Nmakefile b/Nmakefile index 5297e49171..c6f24da08a 100755 --- a/Nmakefile +++ b/Nmakefile @@ -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: diff --git a/basis/bootstrap/io/io.factor b/basis/bootstrap/io/io.factor index b9a49b48b8..5740d44431 100644 --- a/basis/bootstrap/io/io.factor +++ b/basis/bootstrap/io/io.factor @@ -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 diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index e3e8b5ddbc..c70cf00df3 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -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 diff --git a/basis/io/backend/windows/nt/authors.txt b/basis/io/backend/windows/nt/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/backend/windows/nt/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor deleted file mode 100755 index b34902f7f1..0000000000 --- a/basis/io/backend/windows/nt/nt.factor +++ /dev/null @@ -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 - -: (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 ; - -: ( handle existing -- handle ) - f 1 CreateIoCompletionPort dup win32-error=0/f ; - -SYMBOL: master-completion-port - -: ( -- handle ) - INVALID_HANDLE_VALUE f ; - -M: winnt add-completion ( win32-handle -- win32-handle ) - dup handle>> master-completion-port get-global 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 set-global - H{ } clone pending-overlapped set-global ; - -ERROR: invalid-file-size n ; - -: handle>file-size ( handle -- n ) - 0 [ 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 diff --git a/basis/io/backend/windows/nt/platforms.txt b/basis/io/backend/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/backend/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/backend/windows/nt/privileges/platforms.txt b/basis/io/backend/windows/nt/privileges/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/backend/windows/nt/privileges/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/backend/windows/nt/privileges/privileges.factor b/basis/io/backend/windows/nt/privileges/privileges.factor deleted file mode 100644 index 896785b048..0000000000 --- a/basis/io/backend/windows/nt/privileges/privileges.factor +++ /dev/null @@ -1,51 +0,0 @@ -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 - -TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES - -! Security tokens -! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ - -: (open-process-token) ( handle -- handle ) - flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } - { PHANDLE } - [ OpenProcessToken win32-error=0/f ] - with-out-parameters ; - -: open-process-token ( -- handle ) - #! remember to CloseHandle - GetCurrentProcess (open-process-token) ; - -: with-process-token ( quot -- ) - #! quot: ( token-handle -- token-handle ) - [ open-process-token ] dip - [ keep ] curry - [ CloseHandle drop ] [ ] cleanup ; inline - -: lookup-privilege ( string -- luid ) - [ f ] dip LUID - [ LookupPrivilegeValue win32-error=0/f ] keep ; - -:: make-token-privileges ( name enabled? -- obj ) - TOKEN_PRIVILEGES - 1 >>PrivilegeCount - LUID_AND_ATTRIBUTES malloc-struct &free - enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when - name lookup-privilege >>Luid - >>Privileges ; - -M: winnt set-privilege ( name ? -- ) - '[ - 0 - _ _ make-token-privileges - dup byte-length - f - f - AdjustTokenPrivileges win32-error=0/f - ] with-process-token ; diff --git a/basis/io/backend/windows/privileges/platforms.txt b/basis/io/backend/windows/privileges/platforms.txt deleted file mode 100644 index 8e1a55995e..0000000000 --- a/basis/io/backend/windows/privileges/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -windows diff --git a/basis/io/backend/windows/privileges/privileges-tests.factor b/basis/io/backend/windows/privileges/privileges-tests.factor deleted file mode 100644 index a66b2aad7a..0000000000 --- a/basis/io/backend/windows/privileges/privileges-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -USING: io.backend.windows.privileges tools.test ; -IN: io.backend.windows.privileges.tests - -[ [ ] with-privileges ] must-infer diff --git a/basis/io/backend/windows/privileges/privileges.factor b/basis/io/backend/windows/privileges/privileges.factor deleted file mode 100644 index 58806cc4df..0000000000 --- a/basis/io/backend/windows/privileges/privileges.factor +++ /dev/null @@ -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 diff --git a/basis/io/backend/windows/windows.factor b/basis/io/backend/windows/windows.factor index 7ecb5765a1..7f9c42d13b 100755 --- a/basis/io/backend/windows/windows.factor +++ b/basis/io/backend/windows/windows.factor @@ -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 ; - -: ( 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 |dispose add-completion ; - -CONSTANT: share-mode - flags{ - FILE_SHARE_READ - FILE_SHARE_WRITE - FILE_SHARE_DELETE - } - -: default-security-attributes ( -- obj ) - SECURITY_ATTRIBUTES - SECURITY_ATTRIBUTES heap-size >>nLength ; - -"io.files.windows" require \ No newline at end of file +winnt set-io-backend diff --git a/basis/io/files/info/windows/windows.factor b/basis/io/files/info/windows/windows.factor index 2971a15b4b..bf055f327b 100755 --- a/basis/io/files/info/windows/windows.factor +++ b/basis/io/files/info/windows/windows.factor @@ -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 diff --git a/basis/io/files/unique/windows/windows.factor b/basis/io/files/unique/windows/windows.factor index 2c722426dc..f4b88ff21e 100644 --- a/basis/io/files/unique/windows/windows.factor +++ b/basis/io/files/unique/windows/windows.factor @@ -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 -- ) diff --git a/basis/io/files/windows/nt/authors.txt b/basis/io/files/windows/nt/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/files/windows/nt/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/files/windows/nt/nt-tests.factor b/basis/io/files/windows/nt/nt-tests.factor deleted file mode 100644 index a142bb844e..0000000000 --- a/basis/io/files/windows/nt/nt-tests.factor +++ /dev/null @@ -1,55 +0,0 @@ -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 - -[ f ] [ "\\foo" absolute-path? ] unit-test -[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test -[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test -[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test -[ t ] [ "c:\\foo" absolute-path? ] unit-test -[ t ] [ "c:" absolute-path? ] unit-test -[ t ] [ "c:\\" absolute-path? ] unit-test -[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test - -[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test -[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test -[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test -! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing -[ "c:\\" ] [ "c:\\" parent-directory ] unit-test -[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test -[ "c:" ] [ "c:" parent-directory ] unit-test -[ "Z:" ] [ "Z:" parent-directory ] unit-test - -[ f ] [ "" root-directory? ] unit-test -[ t ] [ "\\" root-directory? ] unit-test -[ t ] [ "\\\\" root-directory? ] unit-test -[ t ] [ "/" root-directory? ] unit-test -[ t ] [ "//" root-directory? ] unit-test -[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test -[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test -[ f ] [ "c:\\foo" root-directory? ] unit-test -[ f ] [ "." root-directory? ] unit-test -[ f ] [ ".." root-directory? ] unit-test -[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test -[ t ] [ "\\\\?\\c:" root-directory? ] unit-test -[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test - -[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test - -[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ - "C:\\builds\\factor\\12345\\" - "..\\log.txt" append-path normalize-path -] unit-test - -[ "\\\\?\\C:\\builds\\" ] [ - "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-path -] unit-test - -[ "\\\\?\\C:\\builds\\" ] [ - "C:\\builds\\factor\\12345\\" - "..\\.." append-path normalize-path -] unit-test - -[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test -[ t ] [ "" resource-path 2 tail exists? ] unit-test diff --git a/basis/io/files/windows/nt/nt.factor b/basis/io/files/windows/nt/nt.factor deleted file mode 100644 index 4046522a1b..0000000000 --- a/basis/io/files/windows/nt/nt.factor +++ /dev/null @@ -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 - [ 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 ; - - - [ 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|| ; diff --git a/basis/io/files/windows/nt/platforms.txt b/basis/io/files/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/files/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/files/windows/windows-tests.factor b/basis/io/files/windows/windows-tests.factor new file mode 100644 index 0000000000..d7d9080057 --- /dev/null +++ b/basis/io/files/windows/windows-tests.factor @@ -0,0 +1,57 @@ +! 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 splitting sequences io.pathnames.private ; +IN: io.files.windows.tests + +[ f ] [ "\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:\\" absolute-path? ] unit-test +[ t ] [ "\\\\?\\c:" absolute-path? ] unit-test +[ t ] [ "c:\\foo" absolute-path? ] unit-test +[ t ] [ "c:" absolute-path? ] unit-test +[ t ] [ "c:\\" absolute-path? ] unit-test +[ f ] [ "/cygdrive/c/builds" absolute-path? ] unit-test + +[ "c:\\foo\\" ] [ "c:\\foo\\bar" parent-directory ] unit-test +[ "c:\\" ] [ "c:\\foo\\" parent-directory ] unit-test +[ "c:\\" ] [ "c:\\foo" parent-directory ] unit-test +! { "c:" "c:\\" "c:/" } [ directory ] each -- all do the same thing +[ "c:\\" ] [ "c:\\" parent-directory ] unit-test +[ "Z:\\" ] [ "Z:\\" parent-directory ] unit-test +[ "c:" ] [ "c:" parent-directory ] unit-test +[ "Z:" ] [ "Z:" parent-directory ] unit-test + +[ f ] [ "" root-directory? ] unit-test +[ t ] [ "\\" root-directory? ] unit-test +[ t ] [ "\\\\" root-directory? ] unit-test +[ t ] [ "/" root-directory? ] unit-test +[ t ] [ "//" root-directory? ] unit-test +[ t ] [ "c:\\" trim-tail-separators root-directory? ] unit-test +[ t ] [ "Z:\\" trim-tail-separators root-directory? ] unit-test +[ f ] [ "c:\\foo" root-directory? ] unit-test +[ f ] [ "." root-directory? ] unit-test +[ f ] [ ".." root-directory? ] unit-test +[ t ] [ "\\\\?\\c:\\" root-directory? ] unit-test +[ t ] [ "\\\\?\\c:" root-directory? ] unit-test +[ f ] [ "\\\\?\\c:\\bar" root-directory? ] unit-test + +[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test + +[ "\\\\?\\C:\\builds\\factor\\log.txt" ] [ + "C:\\builds\\factor\\12345\\" + "..\\log.txt" append-path normalize-path +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." append-path normalize-path +] unit-test + +[ "\\\\?\\C:\\builds\\" ] [ + "C:\\builds\\factor\\12345\\" + "..\\.." append-path normalize-path +] unit-test + +[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test +[ t ] [ "" resource-path 2 tail exists? ] unit-test diff --git a/basis/io/files/windows/windows.factor b/basis/io/files/windows/windows.factor index 3b4df85371..024b278b4b 100644 --- a/basis/io/files/windows/windows.factor +++ b/basis/io/files/windows/windows.factor @@ -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 ; + +: ( 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 |dispose add-completion ; + +CONSTANT: share-mode + flags{ + FILE_SHARE_READ + FILE_SHARE_WRITE + FILE_SHARE_DELETE + } + +: default-security-attributes ( -- obj ) + SECURITY_ATTRIBUTES + SECURITY_ATTRIBUTES heap-size >>nLength ; + +TUPLE: FileArgs + hFile lpBuffer nNumberOfBytesToRead + lpNumberOfBytesRet lpOverlapped ; + +C: FileArgs + +: make-FileArgs ( port -- ) + { + [ handle>> check-disposed ] + [ handle>> handle>> ] + [ buffer>> ] + [ buffer>> buffer-length ] + [ drop DWORD ] + [ FileArgs-overlapped ] + } cleave ; + +! Global variable with assoc mapping overlapped to threads +SYMBOL: pending-overlapped + +TUPLE: io-callback port thread ; + +C: 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 ; + +: ( handle existing -- handle ) + f 1 CreateIoCompletionPort dup win32-error=0/f ; + +SYMBOL: master-completion-port + +: ( -- handle ) + INVALID_HANDLE_VALUE f ; + +M: winnt add-completion ( win32-handle -- win32-handle ) + dup handle>> master-completion-port get-global 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 set-global + H{ } clone pending-overlapped set-global ; + +ERROR: invalid-file-size n ; + +: handle>file-size ( handle -- n ) + 0 [ 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 ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) + { + [ hFile>> ] + [ lpBuffer>> buffer-end ] + [ lpBuffer>> buffer-capacity ] + [ lpNumberOfBytesRet>> ] + [ lpOverlapped>> ] + } cleave ; + +: setup-write ( -- 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 ] 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 - -: make-FileArgs ( port -- ) - { - [ handle>> check-disposed ] - [ handle>> handle>> ] - [ buffer>> ] - [ buffer>> buffer-length ] - [ drop DWORD ] - [ FileArgs-overlapped ] - } cleave ; - -: setup-read ( -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped ) - { - [ hFile>> ] - [ lpBuffer>> buffer-end ] - [ lpBuffer>> buffer-capacity ] - [ lpNumberOfBytesRet>> ] - [ lpOverlapped>> ] - } cleave ; - -: setup-write ( -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped ) - { - [ hFile>> ] - [ lpBuffer>> buffer@ ] - [ lpBuffer>> buffer-length ] - [ lpNumberOfBytesRet>> ] - [ lpOverlapped>> ] - } cleave ; - M: windows (file-reader) ( path -- stream ) open-read ; @@ -128,4 +296,58 @@ SYMBOLS: +read-only+ +hidden+ +system+ [ timestamp>FILETIME ] tri@ SetFileTime win32-error=0/f ; -"io.files.windows.nt" require \ No newline at end of file +M: winnt cwd + MAX_UNICODE_PATH dup + [ 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 ; + + + [ 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|| ; \ No newline at end of file diff --git a/basis/io/launcher/launcher.factor b/basis/io/launcher/launcher.factor index dfbbd33d2e..24d1d8e7b8 100755 --- a/basis/io/launcher/launcher.factor +++ b/basis/io/launcher/launcher.factor @@ -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 diff --git a/basis/io/launcher/windows/nt/authors.txt b/basis/io/launcher/windows/nt/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/launcher/windows/nt/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor deleted file mode 100755 index c97c411d2c..0000000000 --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ /dev/null @@ -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 - -[ ] [ - - "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 - -[ - - "notepad" >>command - 1/2 seconds >>timeout - try-process -] must-fail - -[ - - "notepad" >>command - 1/2 seconds >>timeout - try-output-process -] must-fail - -: console-vm ( -- path ) - vm ".exe" ?tail [ ".com" append ] when ; - -[ ] [ - - 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 ) " ] [ - - 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 [ - - 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 [ - - 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 [ - - console-vm "-script" "stderr.factor" 3array >>command - "err2.txt" temp-file >>stderr - ascii stream-lines first - ] with-directory -] unit-test - -[ "error" ] [ - "err2.txt" temp-file ascii file-lines first -] unit-test - -[ t ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - ascii stream-contents - ] with-directory eval( -- alist ) - - os-envs = -] unit-test - -[ t ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - +replace-environment+ >>environment-mode - os-envs >>environment - ascii stream-contents - ] with-directory eval( -- alist ) - - os-envs = -] unit-test - -[ "B" ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - { { "A" "B" } } >>environment - ascii stream-contents - ] with-directory eval( -- alist ) - - "A" swap at -] unit-test - -[ f ] [ - launcher-test-path [ - - console-vm "-script" "env.factor" 3array >>command - { { "USERPROFILE" "XXX" } } >>environment - +prepend-environment+ >>environment-mode - ascii stream-contents - ] with-directory eval( -- alist ) - - "USERPROFILE" swap at "XXX" = -] unit-test - -2 [ - [ ] [ - - "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 [ - - console-vm "-script" "append.factor" 3array >>command - "append-test" temp-file >>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 - -[ ] [ - - console-vm "-run=listener" 2array >>command - "vocab:io/launcher/windows/nt/test/input.txt" >>stdin - try-process -] unit-test diff --git a/basis/io/launcher/windows/nt/nt.factor b/basis/io/launcher/windows/nt/nt.factor deleted file mode 100644 index a9c66d202e..0000000000 --- a/basis/io/launcher/windows/nt/nt.factor +++ /dev/null @@ -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 [ ! target handle - DUPLICATE_SAME_ACCESS ! desired access - TRUE ! inherit handle - 0 ! options - DuplicateHandle win32-error=0/f - ] keep *void* &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 &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 ; diff --git a/basis/io/launcher/windows/nt/platforms.txt b/basis/io/launcher/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/launcher/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/launcher/windows/nt/test/append.factor b/basis/io/launcher/windows/nt/test/append.factor deleted file mode 100644 index 4c1de0c5f9..0000000000 --- a/basis/io/launcher/windows/nt/test/append.factor +++ /dev/null @@ -1,2 +0,0 @@ -USE: io -"Hello appender" print diff --git a/basis/io/launcher/windows/nt/test/env.factor b/basis/io/launcher/windows/nt/test/env.factor deleted file mode 100644 index 503ca7d018..0000000000 --- a/basis/io/launcher/windows/nt/test/env.factor +++ /dev/null @@ -1,4 +0,0 @@ -USE: system -USE: prettyprint -USE: environment -os-envs . diff --git a/basis/io/launcher/windows/nt/test/input.txt b/basis/io/launcher/windows/nt/test/input.txt deleted file mode 100755 index 99c3cc6fb1..0000000000 --- a/basis/io/launcher/windows/nt/test/input.txt +++ /dev/null @@ -1 +0,0 @@ -USE: system 0 exit diff --git a/basis/io/launcher/windows/nt/test/stderr.factor b/basis/io/launcher/windows/nt/test/stderr.factor deleted file mode 100644 index f22f50e406..0000000000 --- a/basis/io/launcher/windows/nt/test/stderr.factor +++ /dev/null @@ -1,5 +0,0 @@ -USE: io -USE: namespaces - -"output" write flush -"error" error-stream get stream-write error-stream get stream-flush diff --git a/basis/io/launcher/windows/test/append.factor b/basis/io/launcher/windows/test/append.factor new file mode 100644 index 0000000000..2943b53f70 --- /dev/null +++ b/basis/io/launcher/windows/test/append.factor @@ -0,0 +1,2 @@ +USE: io +"Hello appender" print diff --git a/basis/io/launcher/windows/test/env.factor b/basis/io/launcher/windows/test/env.factor new file mode 100644 index 0000000000..503ca7d018 --- /dev/null +++ b/basis/io/launcher/windows/test/env.factor @@ -0,0 +1,4 @@ +USE: system +USE: prettyprint +USE: environment +os-envs . diff --git a/basis/io/launcher/windows/test/input.txt b/basis/io/launcher/windows/test/input.txt new file mode 100644 index 0000000000..a225e1f1b9 --- /dev/null +++ b/basis/io/launcher/windows/test/input.txt @@ -0,0 +1 @@ +USE: system 0 exit diff --git a/basis/io/launcher/windows/test/stderr.factor b/basis/io/launcher/windows/test/stderr.factor new file mode 100644 index 0000000000..9b2df73860 --- /dev/null +++ b/basis/io/launcher/windows/test/stderr.factor @@ -0,0 +1,5 @@ +USE: io +USE: namespaces + +"output" write flush +"error" error-stream get stream-write error-stream get stream-flush diff --git a/basis/io/launcher/windows/windows-tests.factor b/basis/io/launcher/windows/windows-tests.factor index 1a3fe823a5..39b5e36cbb 100644 --- a/basis/io/launcher/windows/windows-tests.factor +++ b/basis/io/launcher/windows/windows-tests.factor @@ -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 + +[ ] [ + + "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 + +[ + + "notepad" >>command + 1/2 seconds >>timeout + try-process +] must-fail + +[ + + "notepad" >>command + 1/2 seconds >>timeout + try-output-process +] must-fail + +: console-vm ( -- path ) + vm ".exe" ?tail [ ".com" append ] when ; + +[ ] [ + + 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 ) " ] [ + + 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 [ + + 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 [ + + 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 [ + + console-vm "-script" "stderr.factor" 3array >>command + "err2.txt" temp-file >>stderr + ascii stream-lines first + ] with-directory +] unit-test + +[ "error" ] [ + "err2.txt" temp-file ascii file-lines first +] unit-test + +[ t ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + ascii stream-contents + ] with-directory eval( -- alist ) + + os-envs = +] unit-test + +[ t ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + +replace-environment+ >>environment-mode + os-envs >>environment + ascii stream-contents + ] with-directory eval( -- alist ) + + os-envs = +] unit-test + +[ "B" ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + { { "A" "B" } } >>environment + ascii stream-contents + ] with-directory eval( -- alist ) + + "A" swap at +] unit-test + +[ f ] [ + launcher-test-path [ + + console-vm "-script" "env.factor" 3array >>command + { { "USERPROFILE" "XXX" } } >>environment + +prepend-environment+ >>environment-mode + ascii stream-contents + ] with-directory eval( -- alist ) + + "USERPROFILE" swap at "XXX" = +] unit-test + +2 [ + [ ] [ + + "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 [ + + console-vm "-script" "append.factor" 3array >>command + "append-test" temp-file >>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 + +[ ] [ + + console-vm "-run=listener" 2array >>command + "vocab:io/launcher/windows/test/input.txt" >>stdin + try-process +] unit-test diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index ecf730716a..0b58df2e43 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -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 [ ! target handle + DUPLICATE_SAME_ACCESS ! desired access + TRUE ! inherit handle + 0 ! options + DuplicateHandle win32-error=0/f + ] keep *void* &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 &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 ; diff --git a/basis/io/mmap/windows/windows.factor b/basis/io/mmap/windows/windows.factor index 27382a5118..bd18c12eda 100644 --- a/basis/io/mmap/windows/windows.factor +++ b/basis/io/mmap/windows/windows.factor @@ -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 ; diff --git a/basis/io/monitors/monitors-tests.factor b/basis/io/monitors/monitors-tests.factor index ac17c4a39f..d084416030 100644 --- a/basis/io/monitors/monitors-tests.factor +++ b/basis/io/monitors/monitors-tests.factor @@ -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? [ [ diff --git a/basis/io/monitors/monitors.factor b/basis/io/monitors/monitors.factor index f3e744a59a..bc9638ce4d 100644 --- a/basis/io/monitors/monitors.factor +++ b/basis/io/monitors/monitors.factor @@ -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 diff --git a/basis/io/monitors/windows/authors.txt b/basis/io/monitors/windows/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/io/monitors/windows/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/io/monitors/windows/nt/authors.txt b/basis/io/monitors/windows/nt/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/io/monitors/windows/nt/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/io/monitors/windows/nt/nt-tests.factor b/basis/io/monitors/windows/nt/nt-tests.factor deleted file mode 100644 index a7ee649400..0000000000 --- a/basis/io/monitors/windows/nt/nt-tests.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: io.monitors.windows.nt.tests -USING: io.monitors.windows.nt tools.test ; - - diff --git a/basis/io/monitors/windows/nt/nt.factor b/basis/io/monitors/windows/nt/nt.factor deleted file mode 100644 index e6a055a9d6..0000000000 --- a/basis/io/monitors/windows/nt/nt.factor +++ /dev/null @@ -1,103 +0,0 @@ -! Copyright (C) 2008 Doug Coleman, Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -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 -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 - -: open-directory ( path -- handle ) - normalize-path - FILE_LIST_DIRECTORY - share-mode - f - OPEN_EXISTING - flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } - f - CreateFile opened-file ; - -TUPLE: win32-monitor-port < input-port recursive ; - -TUPLE: win32-monitor < monitor port ; - -: begin-reading-changes ( port -- overlapped ) - { - [ handle>> handle>> ] - [ buffer>> ptr>> ] - [ buffer>> size>> ] - [ recursive>> 1 0 ? ] - } cleave - FILE_NOTIFY_CHANGE_ALL - 0 - (make-overlapped) - [ f ReadDirectoryChangesW win32-error=0/f ] keep ; - -: read-changes ( port -- bytes-transferred ) - [ - [ begin-reading-changes ] [ twiddle-thumbs ] bi - ] with-destructors ; - -: parse-action ( action -- changed ) - { - { FILE_ACTION_ADDED [ +add-file+ ] } - { FILE_ACTION_REMOVED [ +remove-file+ ] } - { FILE_ACTION_MODIFIED [ +modify-file+ ] } - { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] } - { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] } - [ drop +modify-file+ ] - } case 1array ; - -: memory>u16-string ( alien len -- string ) - memory>byte-array utf16n decode ; - -: parse-notify-record ( buffer -- path changed ) - [ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ] - [ Action>> parse-action ] bi ; - -: (file-notify-records) ( buffer -- buffer ) - FILE_NOTIFY_INFORMATION memory>struct - dup , - dup NextEntryOffset>> zero? [ - [ NextEntryOffset>> ] [ >c-ptr ] bi - (file-notify-records) - ] unless ; - -: file-notify-records ( buffer -- seq ) - [ (file-notify-records) drop ] { } make ; - -:: parse-notify-records ( monitor buffer -- ) - buffer file-notify-records [ - parse-notify-record - [ monitor path>> prepend-path normalize-path ] dip - monitor queue-change - ] each ; - -: fill-queue ( monitor -- ) - dup port>> dup check-disposed - [ buffer>> ptr>> ] [ read-changes zero? ] bi - [ 2dup parse-notify-records ] unless - 2drop ; - -: (fill-queue-thread) ( monitor -- ) - dup fill-queue (fill-queue-thread) ; - -: fill-queue-thread ( monitor -- ) - [ dup fill-queue (fill-queue-thread) ] - [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ; - -M:: winnt (monitor) ( path recursive? mailbox -- monitor ) - [ - path normalize-path mailbox win32-monitor new-monitor - path open-directory \ win32-monitor-port - recursive? >>recursive - >>port - dup [ fill-queue-thread ] curry - "Windows monitor thread" spawn drop - ] with-destructors ; - -M: win32-monitor dispose - [ port>> dispose ] [ call-next-method ] bi ; diff --git a/basis/io/monitors/windows/nt/platforms.txt b/basis/io/monitors/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/monitors/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/monitors/windows/platforms.txt b/basis/io/monitors/windows/platforms.txt new file mode 100644 index 0000000000..205e64323d --- /dev/null +++ b/basis/io/monitors/windows/platforms.txt @@ -0,0 +1 @@ +winnt diff --git a/basis/io/monitors/windows/windows.factor b/basis/io/monitors/windows/windows.factor new file mode 100644 index 0000000000..8887d718d1 --- /dev/null +++ b/basis/io/monitors/windows/windows.factor @@ -0,0 +1,103 @@ +! Copyright (C) 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +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.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 + +: open-directory ( path -- handle ) + normalize-path + FILE_LIST_DIRECTORY + share-mode + f + OPEN_EXISTING + flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } + f + CreateFile opened-file ; + +TUPLE: win32-monitor-port < input-port recursive ; + +TUPLE: win32-monitor < monitor port ; + +: begin-reading-changes ( port -- overlapped ) + { + [ handle>> handle>> ] + [ buffer>> ptr>> ] + [ buffer>> size>> ] + [ recursive>> 1 0 ? ] + } cleave + FILE_NOTIFY_CHANGE_ALL + 0 + (make-overlapped) + [ f ReadDirectoryChangesW win32-error=0/f ] keep ; + +: read-changes ( port -- bytes-transferred ) + [ + [ begin-reading-changes ] [ twiddle-thumbs ] bi + ] with-destructors ; + +: parse-action ( action -- changed ) + { + { FILE_ACTION_ADDED [ +add-file+ ] } + { FILE_ACTION_REMOVED [ +remove-file+ ] } + { FILE_ACTION_MODIFIED [ +modify-file+ ] } + { FILE_ACTION_RENAMED_OLD_NAME [ +rename-file+ ] } + { FILE_ACTION_RENAMED_NEW_NAME [ +rename-file+ ] } + [ drop +modify-file+ ] + } case 1array ; + +: memory>u16-string ( alien len -- string ) + memory>byte-array utf16n decode ; + +: parse-notify-record ( buffer -- path changed ) + [ [ FileName>> ] [ FileNameLength>> ] bi memory>u16-string ] + [ Action>> parse-action ] bi ; + +: (file-notify-records) ( buffer -- buffer ) + FILE_NOTIFY_INFORMATION memory>struct + dup , + dup NextEntryOffset>> zero? [ + [ NextEntryOffset>> ] [ >c-ptr ] bi + (file-notify-records) + ] unless ; + +: file-notify-records ( buffer -- seq ) + [ (file-notify-records) drop ] { } make ; + +:: parse-notify-records ( monitor buffer -- ) + buffer file-notify-records [ + parse-notify-record + [ monitor path>> prepend-path normalize-path ] dip + monitor queue-change + ] each ; + +: fill-queue ( monitor -- ) + dup port>> dup check-disposed + [ buffer>> ptr>> ] [ read-changes zero? ] bi + [ 2dup parse-notify-records ] unless + 2drop ; + +: (fill-queue-thread) ( monitor -- ) + dup fill-queue (fill-queue-thread) ; + +: fill-queue-thread ( monitor -- ) + [ dup fill-queue (fill-queue-thread) ] + [ dup already-disposed? [ 2drop ] [ rethrow ] if ] recover ; + +M:: winnt (monitor) ( path recursive? mailbox -- monitor ) + [ + path normalize-path mailbox win32-monitor new-monitor + path open-directory \ win32-monitor-port + recursive? >>recursive + >>port + dup [ fill-queue-thread ] curry + "Windows monitor thread" spawn drop + ] with-destructors ; + +M: win32-monitor dispose + [ port>> dispose ] [ call-next-method ] bi ; diff --git a/basis/io/pipes/pipes.factor b/basis/io/pipes/pipes.factor index 73de6bf1a2..aee69f640e 100644 --- a/basis/io/pipes/pipes.factor +++ b/basis/io/pipes/pipes.factor @@ -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 diff --git a/basis/io/pipes/windows/authors.txt b/basis/io/pipes/windows/authors.txt new file mode 100644 index 0000000000..1901f27a24 --- /dev/null +++ b/basis/io/pipes/windows/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/basis/io/pipes/windows/nt/authors.txt b/basis/io/pipes/windows/nt/authors.txt deleted file mode 100755 index 1901f27a24..0000000000 --- a/basis/io/pipes/windows/nt/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov diff --git a/basis/io/pipes/windows/nt/nt.factor b/basis/io/pipes/windows/nt/nt.factor deleted file mode 100644 index d58e5e3d5f..0000000000 --- a/basis/io/pipes/windows/nt/nt.factor +++ /dev/null @@ -1,46 +0,0 @@ -! 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 - -! This code is based on -! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py - -: create-named-pipe ( name -- handle ) - flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } - PIPE_TYPE_BYTE - 1 - 4096 - 4096 - 0 - default-security-attributes - CreateNamedPipe opened-file ; - -: open-other-end ( name -- handle ) - GENERIC_WRITE - flags{ FILE_SHARE_READ FILE_SHARE_WRITE } - default-security-attributes - OPEN_EXISTING - FILE_FLAG_OVERLAPPED - f - CreateFile opened-file ; - -: unique-pipe-name ( -- string ) - [ - "\\\\.\\pipe\\factor-" % - pipe counter # - "-" % - 32 random-bits # - "-" % - nano-count # - ] "" make ; - -M: winnt (pipe) ( -- pipe ) - [ - unique-pipe-name - [ create-named-pipe ] [ open-other-end ] bi - pipe boa - ] with-destructors ; diff --git a/basis/io/pipes/windows/nt/platforms.txt b/basis/io/pipes/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/pipes/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/pipes/windows/platforms.txt b/basis/io/pipes/windows/platforms.txt new file mode 100644 index 0000000000..205e64323d --- /dev/null +++ b/basis/io/pipes/windows/platforms.txt @@ -0,0 +1 @@ +winnt diff --git a/basis/io/pipes/windows/windows.factor b/basis/io/pipes/windows/windows.factor new file mode 100644 index 0000000000..ea906de966 --- /dev/null +++ b/basis/io/pipes/windows/windows.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +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 + +: create-named-pipe ( name -- handle ) + flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } + PIPE_TYPE_BYTE + 1 + 4096 + 4096 + 0 + default-security-attributes + CreateNamedPipe opened-file ; + +: open-other-end ( name -- handle ) + GENERIC_WRITE + flags{ FILE_SHARE_READ FILE_SHARE_WRITE } + default-security-attributes + OPEN_EXISTING + FILE_FLAG_OVERLAPPED + f + CreateFile opened-file ; + +: unique-pipe-name ( -- string ) + [ + "\\\\.\\pipe\\factor-" % + pipe counter # + "-" % + 32 random-bits # + "-" % + nano-count # + ] "" make ; + +M: winnt (pipe) ( -- pipe ) + [ + unique-pipe-name + [ create-named-pipe ] [ open-other-end ] bi + pipe boa + ] with-destructors ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 30449f066f..b1175a9bb5 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -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 diff --git a/basis/io/sockets/windows/authors.txt b/basis/io/sockets/windows/authors.txt new file mode 100644 index 0000000000..026f4cd0de --- /dev/null +++ b/basis/io/sockets/windows/authors.txt @@ -0,0 +1,3 @@ +Doug Coleman +Slava Pestov +Mackenzie Straight diff --git a/basis/io/sockets/windows/nt/authors.txt b/basis/io/sockets/windows/nt/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/basis/io/sockets/windows/nt/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/basis/io/sockets/windows/nt/nt.factor b/basis/io/sockets/windows/nt/nt.factor deleted file mode 100644 index 13f399697e..0000000000 --- a/basis/io/sockets/windows/nt/nt.factor +++ /dev/null @@ -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 ) - 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 - 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 - -: ( 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 - 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 - -: ( 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 0 f [ 0 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 ) - [ - - { - [ call-AcceptEx ] - [ wait-for-socket drop ] - [ sAcceptSocket>> ] - [ 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 - -: ( 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 ) - [ - - [ 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 - -: ( 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 >>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 -- ) - [ - - [ call-WSASendTo ] - [ wait-for-socket drop ] - bi - ] with-destructors ; diff --git a/basis/io/sockets/windows/nt/platforms.txt b/basis/io/sockets/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/io/sockets/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/io/sockets/windows/windows.factor b/basis/io/sockets/windows/windows.factor index d41240d1b3..5dbe56f263 100755 --- a/basis/io/sockets/windows/windows.factor +++ b/basis/io/sockets/windows/windows.factor @@ -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 ) + 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 + 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 + +: ( 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 + 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 + +: ( 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 0 f [ 0 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 ) + [ + + { + [ call-AcceptEx ] + [ wait-for-socket drop ] + [ sAcceptSocket>> ] + [ 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 + +: ( 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 ) + [ + + [ 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 + +: ( 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 >>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 -- ) + [ + + [ call-WSASendTo ] + [ wait-for-socket drop ] + bi + ] with-destructors ; diff --git a/basis/system-info/windows/ce/authors.txt b/basis/system-info/windows/ce/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/system-info/windows/ce/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/system-info/windows/ce/ce.factor b/basis/system-info/windows/ce/ce.factor deleted file mode 100644 index 8c4f81a117..0000000000 --- a/basis/system-info/windows/ce/ce.factor +++ /dev/null @@ -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" - "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 ; diff --git a/basis/system-info/windows/ce/platforms.txt b/basis/system-info/windows/ce/platforms.txt deleted file mode 100644 index cd0d980f6f..0000000000 --- a/basis/system-info/windows/ce/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -wince diff --git a/basis/system-info/windows/nt/authors.txt b/basis/system-info/windows/nt/authors.txt deleted file mode 100755 index 7c1b2f2279..0000000000 --- a/basis/system-info/windows/nt/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/system-info/windows/nt/nt-tests.factor b/basis/system-info/windows/nt/nt-tests.factor deleted file mode 100755 index dfbd8b3283..0000000000 --- a/basis/system-info/windows/nt/nt-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -USING: math.order strings system-info.backend -system-info.windows system-info.windows.nt -tools.test ; -IN: system-info.windows.nt.tests - -[ t ] [ cpus 0 1024 between? ] unit-test -[ t ] [ username string? ] unit-test diff --git a/basis/system-info/windows/nt/nt.factor b/basis/system-info/windows/nt/nt.factor deleted file mode 100644 index 804eb25def..0000000000 --- a/basis/system-info/windows/nt/nt.factor +++ /dev/null @@ -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 - 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 + - [ dup ] keep - GetComputerName win32-error=0/f alien>native-string ; - -: username ( -- string ) - UNLEN 1 + - [ dup ] keep - GetUserName win32-error=0/f alien>native-string ; diff --git a/basis/system-info/windows/nt/platforms.txt b/basis/system-info/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/system-info/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/system-info/windows/windows-tests.factor b/basis/system-info/windows/windows-tests.factor new file mode 100644 index 0000000000..d26e86742c --- /dev/null +++ b/basis/system-info/windows/windows-tests.factor @@ -0,0 +1,6 @@ +USING: math.order strings system-info.backend +system-info.windows tools.test ; +IN: system-info.windows.tests + +[ t ] [ cpus 0 1024 between? ] unit-test +[ t ] [ username string? ] unit-test diff --git a/basis/system-info/windows/windows.factor b/basis/system-info/windows/windows.factor index 07cbcc41b3..0aba5eeff1 100644 --- a/basis/system-info/windows/windows.factor +++ b/basis/system-info/windows/windows.factor @@ -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 + 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 + + [ dup ] keep + GetComputerName win32-error=0/f alien>native-string ; + +: username ( -- string ) + UNLEN 1 + + [ dup ] keep + GetUserName win32-error=0/f alien>native-string ; diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 7981859573..7fad2414fc 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -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" diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index be184329a3..5178dbb499 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -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 diff --git a/basis/windows/ce/authors.txt b/basis/windows/ce/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/basis/windows/ce/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/windows/ce/ce.factor b/basis/windows/ce/ce.factor deleted file mode 100644 index 614a535ea0..0000000000 --- a/basis/windows/ce/ce.factor +++ /dev/null @@ -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 diff --git a/basis/windows/ce/platforms.txt b/basis/windows/ce/platforms.txt deleted file mode 100644 index cd0d980f6f..0000000000 --- a/basis/windows/ce/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -wince diff --git a/basis/windows/nt/authors.txt b/basis/windows/nt/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/basis/windows/nt/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/basis/windows/nt/nt.factor b/basis/windows/nt/nt.factor deleted file mode 100644 index 4b119ba5fa..0000000000 --- a/basis/windows/nt/nt.factor +++ /dev/null @@ -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 diff --git a/basis/windows/nt/platforms.txt b/basis/windows/nt/platforms.txt deleted file mode 100644 index 205e64323d..0000000000 --- a/basis/windows/nt/platforms.txt +++ /dev/null @@ -1 +0,0 @@ -winnt diff --git a/basis/windows/privileges/authors.txt b/basis/windows/privileges/authors.txt new file mode 100644 index 0000000000..7c1b2f2279 --- /dev/null +++ b/basis/windows/privileges/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/basis/windows/privileges/platforms.txt b/basis/windows/privileges/platforms.txt new file mode 100644 index 0000000000..8e1a55995e --- /dev/null +++ b/basis/windows/privileges/platforms.txt @@ -0,0 +1 @@ +windows diff --git a/basis/windows/privileges/privileges-tests.factor b/basis/windows/privileges/privileges-tests.factor new file mode 100644 index 0000000000..355ed71614 --- /dev/null +++ b/basis/windows/privileges/privileges-tests.factor @@ -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 diff --git a/basis/windows/privileges/privileges.factor b/basis/windows/privileges/privileges.factor new file mode 100644 index 0000000000..ed2827ed8a --- /dev/null +++ b/basis/windows/privileges/privileges.factor @@ -0,0 +1,54 @@ +! 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 + +! Security tokens +! http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/ + +: (open-process-token) ( handle -- handle ) + flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } + { PHANDLE } + [ OpenProcessToken win32-error=0/f ] + with-out-parameters ; + +: open-process-token ( -- handle ) + #! remember to CloseHandle + GetCurrentProcess (open-process-token) ; + +: with-process-token ( quot -- ) + #! quot: ( token-handle -- token-handle ) + [ open-process-token ] dip + [ keep ] curry + [ CloseHandle drop ] [ ] cleanup ; inline + +: lookup-privilege ( string -- luid ) + [ f ] dip LUID + [ LookupPrivilegeValue win32-error=0/f ] keep ; + +:: make-token-privileges ( name enabled? -- obj ) + TOKEN_PRIVILEGES + 1 >>PrivilegeCount + LUID_AND_ATTRIBUTES malloc-struct &free + enabled? [ SE_PRIVILEGE_ENABLED >>Attributes ] when + name lookup-privilege >>Luid + >>Privileges ; + +: set-privilege ( name ? -- ) + '[ + 0 + _ _ make-token-privileges + dup byte-length + f + 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 diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor index 92ba8b638a..dcdcb8b227 100644 --- a/basis/windows/windows.factor +++ b/basis/windows/windows.factor @@ -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 diff --git a/unmaintained/ce/authors.txt b/unmaintained/ce/authors.txt deleted file mode 100644 index 7c1b2f2279..0000000000 --- a/unmaintained/ce/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Doug Coleman diff --git a/unmaintained/ce/backend/authors.txt b/unmaintained/ce/backend/authors.txt deleted file mode 100755 index 026f4cd0de..0000000000 --- a/unmaintained/ce/backend/authors.txt +++ /dev/null @@ -1,3 +0,0 @@ -Doug Coleman -Slava Pestov -Mackenzie Straight diff --git a/unmaintained/ce/backend/backend.factor b/unmaintained/ce/backend/backend.factor deleted file mode 100644 index 7209a68ebf..0000000000 --- a/unmaintained/ce/backend/backend.factor +++ /dev/null @@ -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 ] 3apply - [ ] [ ] [ ] tri* - ] with-variable ; diff --git a/unmaintained/ce/ce.factor b/unmaintained/ce/ce.factor deleted file mode 100644 index a0a8de8513..0000000000 --- a/unmaintained/ce/ce.factor +++ /dev/null @@ -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 diff --git a/unmaintained/ce/files/authors.txt b/unmaintained/ce/files/authors.txt deleted file mode 100755 index 5674120196..0000000000 --- a/unmaintained/ce/files/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Slava Pestov diff --git a/unmaintained/ce/files/files.factor b/unmaintained/ce/files/files.factor deleted file mode 100644 index 83d456832b..0000000000 --- a/unmaintained/ce/files/files.factor +++ /dev/null @@ -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 ; diff --git a/unmaintained/ce/privileges/privileges.factor b/unmaintained/ce/privileges/privileges.factor deleted file mode 100644 index e0aa186b3d..0000000000 --- a/unmaintained/ce/privileges/privileges.factor +++ /dev/null @@ -1,4 +0,0 @@ -IN: io.windows.ce.privileges -USING: io.windows.privileges system ; - -M: wince set-privilege 2drop ; diff --git a/unmaintained/ce/sockets/authors.txt b/unmaintained/ce/sockets/authors.txt deleted file mode 100755 index 5674120196..0000000000 --- a/unmaintained/ce/sockets/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Doug Coleman -Slava Pestov diff --git a/unmaintained/ce/sockets/sockets.factor b/unmaintained/ce/sockets/sockets.factor deleted file mode 100644 index b3117dcde1..0000000000 --- a/unmaintained/ce/sockets/sockets.factor +++ /dev/null @@ -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 dup ; - -M: wince (server) ( addrspec -- handle ) - windows.winsock:SOCK_STREAM server-fd - dup listen-on-socket - ; - -M: wince (accept) ( server -- client ) - [ - [ - dup port-handle win32-file-handle - swap server-port-addr sockaddr-type heap-size - dup [ - swap f 0 - windows.winsock:WSAAccept - dup windows.winsock:INVALID_SOCKET = - [ windows.winsock:winsock-error ] when - ] keep - ] keep server-port-addr parse-sockaddr swap - - ] with-timeout ; - -M: wince ( addrspec -- datagram ) - [ - windows.winsock:SOCK_DGRAM server-fd - ] keep ; - -: 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" - [ 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 receive-buffer set-global - -M: wince receive ( datagram -- packet addrspec ) - dup check-datagram-port - [ - port-handle win32-file-handle - receive-WSABUF - 1 - 0 [ - 0 - 64 "char" [ - 64 - 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 0 r> r> f f - windows.winsock:WSASendTo - windows.winsock:winsock-error!=0/f ; diff --git a/unmaintained/ce/summary.txt b/unmaintained/ce/summary.txt deleted file mode 100644 index 0c660f75a5..0000000000 --- a/unmaintained/ce/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Microsoft Windows CE native I/O implementation diff --git a/vm/Config.windows b/vm/Config.windows index 11df403541..1886ee77d6 100644 --- a/vm/Config.windows +++ b/vm/Config.windows @@ -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 +SHARED_DLL_EXTENSION=.dll + +LIBS = -lm + +PLAF_EXE_OBJS += vm/resources.o vm/main-windows.o + +EXE_SUFFIX= EXE_EXTENSION=.exe -CONSOLE_EXTENSION=.com +DLL_SUFFIX= DLL_EXTENSION=.dll -SHARED_DLL_EXTENSION=.dll +CONSOLE_EXTENSION=.com + LINKER = $(CPP) -shared -mno-cygwin -o LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX) diff --git a/vm/Config.windows.ce b/vm/Config.windows.ce deleted file mode 100644 index 2e3204a589..0000000000 --- a/vm/Config.windows.ce +++ /dev/null @@ -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 diff --git a/vm/Config.windows.ce.arm b/vm/Config.windows.ce.arm deleted file mode 100644 index 98e08e8f61..0000000000 --- a/vm/Config.windows.ce.arm +++ /dev/null @@ -1,4 +0,0 @@ -CC = arm-wince-mingw32ce-gcc -DLL_SUFFIX=-ce -EXE_SUFFIX=-ce -include vm/Config.windows.ce vm/Config.arm diff --git a/vm/Config.windows.nt b/vm/Config.windows.nt deleted file mode 100644 index 322649dc06..0000000000 --- a/vm/Config.windows.nt +++ /dev/null @@ -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 diff --git a/vm/Config.windows.nt.x86.32 b/vm/Config.windows.nt.x86.32 deleted file mode 100644 index 73bf064ce5..0000000000 --- a/vm/Config.windows.nt.x86.32 +++ /dev/null @@ -1,5 +0,0 @@ -PLAF_DLL_OBJS += vm/os-windows-nt-x86.32.o -DLL_PATH=http://factorcode.org/dlls -WINDRES=windres -include vm/Config.windows.nt -include vm/Config.x86.32 diff --git a/vm/Config.windows.nt.x86.64 b/vm/Config.windows.nt.x86.64 deleted file mode 100644 index 495a3ccac9..0000000000 --- a/vm/Config.windows.nt.x86.64 +++ /dev/null @@ -1,6 +0,0 @@ -PLAF_DLL_OBJS += vm/os-windows-nt-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.x86.64 diff --git a/vm/Config.windows.x86.32 b/vm/Config.windows.x86.32 new file mode 100644 index 0000000000..6ba2955d79 --- /dev/null +++ b/vm/Config.windows.x86.32 @@ -0,0 +1,5 @@ +PLAF_DLL_OBJS += vm/os-windows-x86.32.o +DLL_PATH=http://factorcode.org/dlls +WINDRES=windres +include vm/Config.windows +include vm/Config.x86.32 diff --git a/vm/Config.windows.x86.64 b/vm/Config.windows.x86.64 new file mode 100644 index 0000000000..f3dc9b0b77 --- /dev/null +++ b/vm/Config.windows.x86.64 @@ -0,0 +1,6 @@ +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 +include vm/Config.x86.64 diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index b42261619b..b67da28922 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -13,7 +13,7 @@ code_heap::code_heap(cell size) allocator = new free_list_allocator(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; } diff --git a/vm/main-windows-ce.cpp b/vm/main-windows-ce.cpp deleted file mode 100755 index ed5844167a..0000000000 --- a/vm/main-windows-ce.cpp +++ /dev/null @@ -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; -} diff --git a/vm/main-windows-nt.cpp b/vm/main-windows-nt.cpp deleted file mode 100755 index 4de32f894a..0000000000 --- a/vm/main-windows-nt.cpp +++ /dev/null @@ -1,21 +0,0 @@ -#include "master.hpp" - -VM_C_API int wmain(int argc, wchar_t **argv) -{ - factor::init_globals(); - factor::start_standalone_factor(argc,argv); - return 0; -} - -int WINAPI WinMain( - HINSTANCE hInstance, - HINSTANCE hPrevInstance, - LPSTR lpCmdLine, - int nCmdShow) -{ - int argc; - wchar_t **argv = CommandLineToArgvW(GetCommandLine(),&argc); - wmain(argc,argv); - - return 0; -} diff --git a/vm/main-windows.cpp b/vm/main-windows.cpp new file mode 100644 index 0000000000..4de32f894a --- /dev/null +++ b/vm/main-windows.cpp @@ -0,0 +1,21 @@ +#include "master.hpp" + +VM_C_API int wmain(int argc, wchar_t **argv) +{ + factor::init_globals(); + factor::start_standalone_factor(argc,argv); + return 0; +} + +int WINAPI WinMain( + HINSTANCE hInstance, + HINSTANCE hPrevInstance, + LPSTR lpCmdLine, + int nCmdShow) +{ + int argc; + wchar_t **argv = CommandLineToArgvW(GetCommandLine(),&argc); + wmain(argc,argv); + + return 0; +} diff --git a/vm/mvm-windows-nt.cpp b/vm/mvm-windows-nt.cpp deleted file mode 100644 index 92c20672aa..0000000000 --- a/vm/mvm-windows-nt.cpp +++ /dev/null @@ -1,27 +0,0 @@ -#include "master.hpp" - -namespace factor -{ - -DWORD current_vm_tls_key; - -void init_mvm() -{ - if((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) - fatal_error("TlsAlloc() failed",0); -} - -void register_vm_with_thread(factor_vm *vm) -{ - if(!TlsSetValue(current_vm_tls_key, vm)) - fatal_error("TlsSetValue() failed",0); -} - -factor_vm *current_vm() -{ - factor_vm *vm = (factor_vm *)TlsGetValue(current_vm_tls_key); - assert(vm != NULL); - return vm; -} - -} diff --git a/vm/mvm-windows.cpp b/vm/mvm-windows.cpp new file mode 100644 index 0000000000..92c20672aa --- /dev/null +++ b/vm/mvm-windows.cpp @@ -0,0 +1,27 @@ +#include "master.hpp" + +namespace factor +{ + +DWORD current_vm_tls_key; + +void init_mvm() +{ + if((current_vm_tls_key = TlsAlloc()) == TLS_OUT_OF_INDEXES) + fatal_error("TlsAlloc() failed",0); +} + +void register_vm_with_thread(factor_vm *vm) +{ + if(!TlsSetValue(current_vm_tls_key, vm)) + fatal_error("TlsSetValue() failed",0); +} + +factor_vm *current_vm() +{ + factor_vm *vm = (factor_vm *)TlsGetValue(current_vm_tls_key); + assert(vm != NULL); + return vm; +} + +} diff --git a/vm/os-windows-ce.cpp b/vm/os-windows-ce.cpp deleted file mode 100644 index 65e8ef5b09..0000000000 --- a/vm/os-windows-ce.cpp +++ /dev/null @@ -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() { } - -} diff --git a/vm/os-windows-ce.hpp b/vm/os-windows-ce.hpp deleted file mode 100755 index 892fc88be9..0000000000 --- a/vm/os-windows-ce.hpp +++ /dev/null @@ -1,27 +0,0 @@ -#ifndef UNICODE -#define UNICODE -#endif - -#include -#include - -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(); - -} diff --git a/vm/os-windows-nt-x86.32.cpp b/vm/os-windows-nt-x86.32.cpp deleted file mode 100644 index 61cf9f6c4e..0000000000 --- a/vm/os-windows-nt-x86.32.cpp +++ /dev/null @@ -1,12 +0,0 @@ -#include "master.hpp" - -namespace factor -{ - -void factor_vm::c_to_factor_toplevel(cell quot) -{ - /* 32-bit Windows SEH is set up in basis/cpu/x86/32/winnt/bootstrap.factor */ - c_to_factor(quot); -} - -} diff --git a/vm/os-windows-nt-x86.64.cpp b/vm/os-windows-nt-x86.64.cpp deleted file mode 100644 index 876d0c5771..0000000000 --- a/vm/os-windows-nt-x86.64.cpp +++ /dev/null @@ -1,85 +0,0 @@ -#include "master.hpp" - -namespace factor { - -typedef unsigned char UBYTE; - -const UBYTE UNW_FLAG_EHANDLER = 0x1; - -struct UNWIND_INFO { - UBYTE Version:3; - UBYTE Flags:5; - UBYTE SizeOfProlog; - UBYTE CountOfCodes; - UBYTE FrameRegister:4; - UBYTE FrameOffset:4; - ULONG ExceptionHandler; - ULONG ExceptionData[1]; -}; - -struct seh_data { - UNWIND_INFO unwind_info; - RUNTIME_FUNCTION func; - UBYTE handler[32]; -}; - -void factor_vm::c_to_factor_toplevel(cell quot) -{ - /* The annoying thing about Win64 SEH is that the offsets in - * function tables are 32-bit integers, and the exception handler - * itself must reside between the start and end pointers, so - * we stick everything at the beginning of the code heap and - * generate a small trampoline that jumps to the real - * exception handler. */ - - seh_data *seh_area = (seh_data *)code->seh_area; - cell base = code->seg->start; - - /* Should look at generating this with the Factor assembler */ - - /* mov rax,0 */ - seh_area->handler[0] = 0x48; - seh_area->handler[1] = 0xb8; - seh_area->handler[2] = 0x0; - seh_area->handler[3] = 0x0; - seh_area->handler[4] = 0x0; - seh_area->handler[5] = 0x0; - seh_area->handler[6] = 0x0; - seh_area->handler[7] = 0x0; - seh_area->handler[8] = 0x0; - seh_area->handler[9] = 0x0; - - /* jmp rax */ - seh_area->handler[10] = 0x48; - seh_area->handler[11] = 0xff; - seh_area->handler[12] = 0xe0; - - /* Store address of exception handler in the operand of the 'mov' */ - cell handler = (cell)&factor::exception_handler; - memcpy(&seh_area->handler[2],&handler,sizeof(cell)); - - UNWIND_INFO *unwind_info = &seh_area->unwind_info; - unwind_info->Version = 1; - unwind_info->Flags = UNW_FLAG_EHANDLER; - unwind_info->SizeOfProlog = 0; - unwind_info->CountOfCodes = 0; - unwind_info->FrameRegister = 0; - unwind_info->FrameOffset = 0; - unwind_info->ExceptionHandler = (DWORD)((cell)&seh_area->handler[0] - base); - unwind_info->ExceptionData[0] = 0; - - RUNTIME_FUNCTION *func = &seh_area->func; - func->BeginAddress = 0; - func->EndAddress = (DWORD)(code->seg->end - base); - func->UnwindData = (DWORD)((cell)&seh_area->unwind_info - base); - - if(!RtlAddFunctionTable(func,1,base)) - fatal_error("RtlAddFunctionTable() failed",0); - - c_to_factor(quot); - - if(!RtlDeleteFunctionTable(func)) - fatal_error("RtlDeleteFunctionTable() failed",0); -} - -} diff --git a/vm/os-windows-nt.32.hpp b/vm/os-windows-nt.32.hpp deleted file mode 100755 index 748272ff38..0000000000 --- a/vm/os-windows-nt.32.hpp +++ /dev/null @@ -1,36 +0,0 @@ -namespace factor -{ - -#define ESP Esp -#define EIP Eip - -typedef struct DECLSPEC_ALIGN(16) _M128A { - ULONGLONG Low; - LONGLONG High; -} M128A, *PM128A; - -/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however, - * this structure is only made available from winnt.h on x86.64 */ -typedef struct _XMM_SAVE_AREA32 { - WORD ControlWord; /* 000 */ - WORD StatusWord; /* 002 */ - BYTE TagWord; /* 004 */ - BYTE Reserved1; /* 005 */ - WORD ErrorOpcode; /* 006 */ - DWORD ErrorOffset; /* 008 */ - WORD ErrorSelector; /* 00c */ - WORD Reserved2; /* 00e */ - DWORD DataOffset; /* 010 */ - WORD DataSelector; /* 014 */ - WORD Reserved3; /* 016 */ - DWORD MxCsr; /* 018 */ - DWORD MxCsr_Mask; /* 01c */ - M128A FloatRegisters[8]; /* 020 */ - M128A XmmRegisters[16]; /* 0a0 */ - BYTE Reserved4[96]; /* 1a0 */ -} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32; - -#define X87SW(ctx) (ctx)->FloatSave.StatusWord -#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr - -} diff --git a/vm/os-windows-nt.64.hpp b/vm/os-windows-nt.64.hpp deleted file mode 100755 index aff662a489..0000000000 --- a/vm/os-windows-nt.64.hpp +++ /dev/null @@ -1,9 +0,0 @@ -namespace factor -{ - -#define ESP Rsp -#define EIP Rip - -#define MXCSR(ctx) (ctx)->MxCsr - -} diff --git a/vm/os-windows-nt.cpp b/vm/os-windows-nt.cpp deleted file mode 100755 index 395ab10214..0000000000 --- a/vm/os-windows-nt.cpp +++ /dev/null @@ -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() -{ -} - -} diff --git a/vm/os-windows-nt.hpp b/vm/os-windows-nt.hpp deleted file mode 100755 index 60990c0986..0000000000 --- a/vm/os-windows-nt.hpp +++ /dev/null @@ -1,42 +0,0 @@ -#undef _WIN32_WINNT -#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler - -#ifndef UNICODE -#define UNICODE -#endif - -#include -#include - -#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(); } - -} diff --git a/vm/os-windows-x86.32.cpp b/vm/os-windows-x86.32.cpp new file mode 100644 index 0000000000..61cf9f6c4e --- /dev/null +++ b/vm/os-windows-x86.32.cpp @@ -0,0 +1,12 @@ +#include "master.hpp" + +namespace factor +{ + +void factor_vm::c_to_factor_toplevel(cell quot) +{ + /* 32-bit Windows SEH is set up in basis/cpu/x86/32/winnt/bootstrap.factor */ + c_to_factor(quot); +} + +} diff --git a/vm/os-windows-x86.64.cpp b/vm/os-windows-x86.64.cpp new file mode 100644 index 0000000000..876d0c5771 --- /dev/null +++ b/vm/os-windows-x86.64.cpp @@ -0,0 +1,85 @@ +#include "master.hpp" + +namespace factor { + +typedef unsigned char UBYTE; + +const UBYTE UNW_FLAG_EHANDLER = 0x1; + +struct UNWIND_INFO { + UBYTE Version:3; + UBYTE Flags:5; + UBYTE SizeOfProlog; + UBYTE CountOfCodes; + UBYTE FrameRegister:4; + UBYTE FrameOffset:4; + ULONG ExceptionHandler; + ULONG ExceptionData[1]; +}; + +struct seh_data { + UNWIND_INFO unwind_info; + RUNTIME_FUNCTION func; + UBYTE handler[32]; +}; + +void factor_vm::c_to_factor_toplevel(cell quot) +{ + /* The annoying thing about Win64 SEH is that the offsets in + * function tables are 32-bit integers, and the exception handler + * itself must reside between the start and end pointers, so + * we stick everything at the beginning of the code heap and + * generate a small trampoline that jumps to the real + * exception handler. */ + + seh_data *seh_area = (seh_data *)code->seh_area; + cell base = code->seg->start; + + /* Should look at generating this with the Factor assembler */ + + /* mov rax,0 */ + seh_area->handler[0] = 0x48; + seh_area->handler[1] = 0xb8; + seh_area->handler[2] = 0x0; + seh_area->handler[3] = 0x0; + seh_area->handler[4] = 0x0; + seh_area->handler[5] = 0x0; + seh_area->handler[6] = 0x0; + seh_area->handler[7] = 0x0; + seh_area->handler[8] = 0x0; + seh_area->handler[9] = 0x0; + + /* jmp rax */ + seh_area->handler[10] = 0x48; + seh_area->handler[11] = 0xff; + seh_area->handler[12] = 0xe0; + + /* Store address of exception handler in the operand of the 'mov' */ + cell handler = (cell)&factor::exception_handler; + memcpy(&seh_area->handler[2],&handler,sizeof(cell)); + + UNWIND_INFO *unwind_info = &seh_area->unwind_info; + unwind_info->Version = 1; + unwind_info->Flags = UNW_FLAG_EHANDLER; + unwind_info->SizeOfProlog = 0; + unwind_info->CountOfCodes = 0; + unwind_info->FrameRegister = 0; + unwind_info->FrameOffset = 0; + unwind_info->ExceptionHandler = (DWORD)((cell)&seh_area->handler[0] - base); + unwind_info->ExceptionData[0] = 0; + + RUNTIME_FUNCTION *func = &seh_area->func; + func->BeginAddress = 0; + func->EndAddress = (DWORD)(code->seg->end - base); + func->UnwindData = (DWORD)((cell)&seh_area->unwind_info - base); + + if(!RtlAddFunctionTable(func,1,base)) + fatal_error("RtlAddFunctionTable() failed",0); + + c_to_factor(quot); + + if(!RtlDeleteFunctionTable(func)) + fatal_error("RtlDeleteFunctionTable() failed",0); +} + +} diff --git a/vm/os-windows.32.hpp b/vm/os-windows.32.hpp new file mode 100644 index 0000000000..748272ff38 --- /dev/null +++ b/vm/os-windows.32.hpp @@ -0,0 +1,36 @@ +namespace factor +{ + +#define ESP Esp +#define EIP Eip + +typedef struct DECLSPEC_ALIGN(16) _M128A { + ULONGLONG Low; + LONGLONG High; +} M128A, *PM128A; + +/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however, + * this structure is only made available from winnt.h on x86.64 */ +typedef struct _XMM_SAVE_AREA32 { + WORD ControlWord; /* 000 */ + WORD StatusWord; /* 002 */ + BYTE TagWord; /* 004 */ + BYTE Reserved1; /* 005 */ + WORD ErrorOpcode; /* 006 */ + DWORD ErrorOffset; /* 008 */ + WORD ErrorSelector; /* 00c */ + WORD Reserved2; /* 00e */ + DWORD DataOffset; /* 010 */ + WORD DataSelector; /* 014 */ + WORD Reserved3; /* 016 */ + DWORD MxCsr; /* 018 */ + DWORD MxCsr_Mask; /* 01c */ + M128A FloatRegisters[8]; /* 020 */ + M128A XmmRegisters[16]; /* 0a0 */ + BYTE Reserved4[96]; /* 1a0 */ +} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32; + +#define X87SW(ctx) (ctx)->FloatSave.StatusWord +#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr + +} diff --git a/vm/os-windows.64.hpp b/vm/os-windows.64.hpp new file mode 100644 index 0000000000..aff662a489 --- /dev/null +++ b/vm/os-windows.64.hpp @@ -0,0 +1,9 @@ +namespace factor +{ + +#define ESP Rsp +#define EIP Rip + +#define MXCSR(ctx) (ctx)->MxCsr + +} diff --git a/vm/os-windows.cpp b/vm/os-windows.cpp index b9af2ec054..a54a5e15d7 100755 --- a/vm/os-windows.cpp +++ b/vm/os-windows.cpp @@ -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() {} + } diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 03dec4bb02..79f3e0d0aa 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -5,10 +5,30 @@ #include #endif +#undef _WIN32_WINNT +#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler + +#ifndef UNICODE +#define UNICODE +#endif + +#include +#include + +#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(); } } diff --git a/vm/platform.hpp b/vm/platform.hpp index e5a07a05d4..cdfe7fa45a 100755 --- a/vm/platform.hpp +++ b/vm/platform.hpp @@ -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