@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
- @echo "wince-arm"
@echo "winnt-x86-32"
@echo "winnt-x86-64"
@echo ""
$(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
!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 \
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 \
vm\to_tenured_collector.obj \
vm\tuples.obj \
vm\utilities.obj \
- vm\vm.obj \
+ vm\vm.obj \
vm\words.obj
.cpp.obj:
"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
(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
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: accessors alien alien.c-types alien.data alien.syntax
-arrays assocs classes.struct combinators
-combinators.short-circuit destructors io io.backend
-io.backend.windows io.buffers io.files.windows io.ports
-io.streams.c io.streams.null io.timeouts kernel libc locals
-math namespaces sequences system threads vocabs.loader
-windows.errors windows.handles windows.kernel32 ;
-IN: io.backend.windows.nt
-
-! Global variable with assoc mapping overlapped to threads
-SYMBOL: pending-overlapped
-
-TUPLE: io-callback port thread ;
-
-C: <io-callback> io-callback
-
-: (make-overlapped) ( -- overlapped-ext )
- OVERLAPPED malloc-struct &free ;
-
-: make-overlapped ( port -- overlapped-ext )
- [ (make-overlapped) ] dip
- handle>> ptr>> [ >>offset ] when* ;
-
-M: winnt FileArgs-overlapped ( port -- overlapped )
- make-overlapped ;
-
-: <completion-port> ( handle existing -- handle )
- f 1 CreateIoCompletionPort dup win32-error=0/f ;
-
-SYMBOL: master-completion-port
-
-: <master-completion-port> ( -- handle )
- INVALID_HANDLE_VALUE f <completion-port> ;
-
-M: winnt add-completion ( win32-handle -- win32-handle )
- dup handle>> master-completion-port get-global <completion-port> drop ;
-
-: eof? ( error -- ? )
- { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
-
-: twiddle-thumbs ( overlapped port -- bytes-transferred )
- [
- drop
- [ self ] dip >c-ptr pending-overlapped get-global set-at
- "I/O" suspend {
- { [ dup integer? ] [ ] }
- { [ dup array? ] [
- first dup eof?
- [ drop 0 ] [ n>win32-error-string throw ] if
- ] }
- } cond
- ] with-timeout ;
-
-:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
- nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
- master-completion-port get-global
- { int void* pointer: OVERLAPPED }
- [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
- :> ( error? bytes key overlapped )
- bytes overlapped error? ;
-
-: resume-callback ( result overlapped -- )
- >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
-
-: handle-overlapped ( nanos -- ? )
- wait-for-overlapped [
- [
- [ drop GetLastError 1array ] dip resume-callback t
- ] [ drop f ] if*
- ] [ resume-callback t ] if ;
-
-M: win32-handle cancel-operation
- [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
-
-M: winnt io-multiplex ( nanos -- )
- handle-overlapped [ 0 io-multiplex ] when ;
-
-M: winnt init-io ( -- )
- <master-completion-port> master-completion-port set-global
- H{ } clone pending-overlapped set-global ;
-
-ERROR: invalid-file-size n ;
-
-: handle>file-size ( handle -- n )
- 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
-
-ERROR: seek-before-start n ;
-
-: set-seek-ptr ( n handle -- )
- [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
-
-M: winnt tell-handle ( handle -- n ) ptr>> ;
-
-M: winnt seek-handle ( n seek-type handle -- )
- swap {
- { seek-absolute [ set-seek-ptr ] }
- { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
- { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
- [ bad-seek-type ]
- } case ;
-
-: file-error? ( n -- eof? )
- zero? [
- GetLastError {
- { [ dup expected-io-error? ] [ drop f ] }
- { [ dup eof? ] [ drop t ] }
- [ n>win32-error-string throw ]
- } cond
- ] [ f ] if ;
-
-: wait-for-file ( FileArgs n port -- n )
- swap file-error?
- [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
-
-: update-file-ptr ( n port -- )
- handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
-
-: finish-write ( n port -- )
- [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
-
-M: winnt (wait-to-write)
- [
- [ make-FileArgs dup setup-write WriteFile ]
- [ wait-for-file ]
- [ finish-write ]
- tri
- ] with-destructors ;
-
-: finish-read ( n port -- )
- [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
-
-M: winnt (wait-to-read) ( port -- )
- [
- [ make-FileArgs dup setup-read ReadFile ]
- [ wait-for-file ]
- [ finish-read ]
- tri
- ] with-destructors ;
-
-: console-app? ( -- ? ) GetConsoleWindow >boolean ;
-
-M: winnt init-stdio
- console-app?
- [ init-c-stdio ]
- [ null-reader null-writer null-writer set-stdio ] if ;
-
-"io.files.windows.nt" require
-winnt set-io-backend
+++ /dev/null
-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 <struct>
- [ LookupPrivilegeValue win32-error=0/f ] keep ;
-
-:: make-token-privileges ( name enabled? -- obj )
- TOKEN_PRIVILEGES <struct>
- 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 ;
+++ /dev/null
-USING: io.backend.windows.privileges tools.test ;\r
-IN: io.backend.windows.privileges.tests\r
-\r
-[ [ ] with-privileges ] must-infer\r
+++ /dev/null
-USING: io.backend kernel continuations sequences\r
-system vocabs.loader combinators fry ;\r
-IN: io.backend.windows.privileges\r
-\r
-HOOK: set-privilege io-backend ( name ? -- )\r
-\r
-: with-privileges ( seq quot -- )\r
- [ '[ _ [ t set-privilege ] each @ ] ]\r
- [ drop '[ _ [ f set-privilege ] each ] ]\r
- 2bi [ ] cleanup ; inline\r
-\r
-{\r
- { [ os winnt? ] [ "io.backend.windows.nt.privileges" require ] }\r
- { [ os wince? ] [ "io.backend.windows.ce.privileges" require ] }\r
-} cond\r
! Copyright (C) 2004, 2010 Mackenzie Straight, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types classes.struct destructors
-io.backend io.timeouts kernel literals windows.errors
-windows.handles windows.kernel32 vocabs.loader ;
+USING: io.backend namespaces system vocabs.loader ;
IN: io.backend.windows
-HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
-HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
-HOOK: add-completion io-backend ( port -- port )
+"io.files.windows" require
-TUPLE: win32-file < win32-handle ptr ;
-
-: <win32-file> ( handle -- win32-file )
- win32-file new-win32-handle ;
-
-M: win32-file dispose
- [ cancel-operation ] [ call-next-method ] bi ;
-
-: opened-file ( handle -- win32-file )
- check-invalid-handle <win32-file> |dispose add-completion ;
-
-CONSTANT: share-mode
- flags{
- FILE_SHARE_READ
- FILE_SHARE_WRITE
- FILE_SHARE_DELETE
- }
-
-: default-security-attributes ( -- obj )
- SECURITY_ATTRIBUTES <struct>
- SECURITY_ATTRIBUTES heap-size >>nLength ;
-
-"io.files.windows" require
\ No newline at end of file
+winnt set-io-backend
! 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
-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 -- )
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-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
+++ /dev/null
-USING: accessors alien.c-types alien.strings classes.struct
-combinators combinators.short-circuit continuations environment
-io.backend io.backend.windows io.encodings.utf16n
-io.files.private io.files.windows io.pathnames kernel math
-sequences specialized-arrays system tr
-windows windows.errors windows.kernel32 windows.shell32
-windows.time ;
-SPECIALIZED-ARRAY: ushort
-IN: io.files.windows.nt
-
-M: winnt cwd
- MAX_UNICODE_PATH dup <ushort-array>
- [ GetCurrentDirectory win32-error=0/f ] keep
- utf16n alien>string ;
-
-M: winnt cd
- SetCurrentDirectory win32-error=0/f ;
-
-CONSTANT: unicode-prefix "\\\\?\\"
-
-M: winnt root-directory? ( path -- ? )
- {
- { [ dup empty? ] [ drop f ] }
- { [ dup [ path-separator? ] all? ] [ drop t ] }
- { [ dup trim-tail-separators { [ length 2 = ]
- [ second CHAR: : = ] } 1&& ] [ drop t ] }
- { [ dup unicode-prefix head? ]
- [ trim-tail-separators length unicode-prefix length 2 + = ] }
- [ drop f ]
- } cond ;
-
-: prepend-prefix ( string -- string' )
- dup unicode-prefix head? [
- unicode-prefix prepend
- ] unless ;
-
-TR: normalize-separators "/" "\\" ;
-
-M: winnt normalize-path ( string -- string' )
- absolute-path
- normalize-separators
- prepend-prefix ;
-
-M: winnt CreateFile-flags ( DWORD -- DWORD )
- FILE_FLAG_OVERLAPPED bitor ;
-
-<PRIVATE
-
-: windows-file-size ( path -- size )
- normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
- [ GetFileAttributesEx win32-error=0/f ] keep
- [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
-
-PRIVATE>
-
-M: winnt open-append
- [ dup windows-file-size ] [ drop 0 ] recover
- [ (open-append) ] dip >>ptr ;
-
-M: winnt home
- {
- [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
- [ "USERPROFILE" os-env ]
- [ my-documents ]
- } 0|| ;
--- /dev/null
+! 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
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types alien.data combinators
-destructors io.backend.windows io.binary io.buffers io.files
-io.files.types io.ports kernel literals make
-math.bitwise system windows.errors windows.handles
-windows.kernel32 windows.time windows.types vocabs.loader ;
+USING: accessors alien alien.c-types alien.data alien.strings
+alien.syntax arrays assocs classes.struct combinators
+combinators.short-circuit continuations destructors environment
+io io.backend io.binary io.buffers
+io.encodings.utf16n io.files io.files.private io.files.types
+io.pathnames io.ports io.streams.c io.streams.null io.timeouts
+kernel libc literals locals make math math.bitwise namespaces
+sequences specialized-arrays system
+threads tr windows windows.errors windows.handles
+windows.kernel32 windows.shell32 windows.time windows.types ;
+SPECIALIZED-ARRAY: ushort
IN: io.files.windows
+HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
+HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
+HOOK: add-completion io-backend ( port -- port )
+HOOK: open-append os ( path -- win32-file )
+
+TUPLE: win32-file < win32-handle ptr ;
+
+: <win32-file> ( handle -- win32-file )
+ win32-file new-win32-handle ;
+
+M: win32-file dispose
+ [ cancel-operation ] [ call-next-method ] bi ;
+
+: opened-file ( handle -- win32-file )
+ check-invalid-handle <win32-file> |dispose add-completion ;
+
+CONSTANT: share-mode
+ flags{
+ FILE_SHARE_READ
+ FILE_SHARE_WRITE
+ FILE_SHARE_DELETE
+ }
+
+: default-security-attributes ( -- obj )
+ SECURITY_ATTRIBUTES <struct>
+ SECURITY_ATTRIBUTES heap-size >>nLength ;
+
+TUPLE: FileArgs
+ hFile lpBuffer nNumberOfBytesToRead
+ lpNumberOfBytesRet lpOverlapped ;
+
+C: <FileArgs> FileArgs
+
+: make-FileArgs ( port -- <FileArgs> )
+ {
+ [ handle>> check-disposed ]
+ [ handle>> handle>> ]
+ [ buffer>> ]
+ [ buffer>> buffer-length ]
+ [ drop DWORD <c-object> ]
+ [ FileArgs-overlapped ]
+ } cleave <FileArgs> ;
+
+! Global variable with assoc mapping overlapped to threads
+SYMBOL: pending-overlapped
+
+TUPLE: io-callback port thread ;
+
+C: <io-callback> io-callback
+
+: (make-overlapped) ( -- overlapped-ext )
+ OVERLAPPED malloc-struct &free ;
+
+: make-overlapped ( port -- overlapped-ext )
+ [ (make-overlapped) ] dip
+ handle>> ptr>> [ >>offset ] when* ;
+
+M: winnt FileArgs-overlapped ( port -- overlapped )
+ make-overlapped ;
+
+: <completion-port> ( handle existing -- handle )
+ f 1 CreateIoCompletionPort dup win32-error=0/f ;
+
+SYMBOL: master-completion-port
+
+: <master-completion-port> ( -- handle )
+ INVALID_HANDLE_VALUE f <completion-port> ;
+
+M: winnt add-completion ( win32-handle -- win32-handle )
+ dup handle>> master-completion-port get-global <completion-port> drop ;
+
+: eof? ( error -- ? )
+ { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
+
+: twiddle-thumbs ( overlapped port -- bytes-transferred )
+ [
+ drop
+ [ self ] dip >c-ptr pending-overlapped get-global set-at
+ "I/O" suspend {
+ { [ dup integer? ] [ ] }
+ { [ dup array? ] [
+ first dup eof?
+ [ drop 0 ] [ n>win32-error-string throw ] if
+ ] }
+ } cond
+ ] with-timeout ;
+
+:: wait-for-overlapped ( nanos -- bytes-transferred overlapped error? )
+ nanos [ 1,000,000 /i ] [ INFINITE ] if* :> timeout
+ master-completion-port get-global
+ { int void* pointer: OVERLAPPED }
+ [ timeout GetQueuedCompletionStatus zero? ] with-out-parameters
+ :> ( error? bytes key overlapped )
+ bytes overlapped error? ;
+
+: resume-callback ( result overlapped -- )
+ >c-ptr pending-overlapped get-global delete-at* drop resume-with ;
+
+: handle-overlapped ( nanos -- ? )
+ wait-for-overlapped [
+ [
+ [ drop GetLastError 1array ] dip resume-callback t
+ ] [ drop f ] if*
+ ] [ resume-callback t ] if ;
+
+M: win32-handle cancel-operation
+ [ handle>> CancelIo win32-error=0/f ] unless-disposed ;
+
+M: winnt io-multiplex ( nanos -- )
+ handle-overlapped [ 0 io-multiplex ] when ;
+
+M: winnt init-io ( -- )
+ <master-completion-port> master-completion-port set-global
+ H{ } clone pending-overlapped set-global ;
+
+ERROR: invalid-file-size n ;
+
+: handle>file-size ( handle -- n )
+ 0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
+
+ERROR: seek-before-start n ;
+
+: set-seek-ptr ( n handle -- )
+ [ dup 0 < [ seek-before-start ] when ] dip ptr<< ;
+
+M: winnt tell-handle ( handle -- n ) ptr>> ;
+
+M: winnt seek-handle ( n seek-type handle -- )
+ swap {
+ { seek-absolute [ set-seek-ptr ] }
+ { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
+ { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
+ [ bad-seek-type ]
+ } case ;
+
+: file-error? ( n -- eof? )
+ zero? [
+ GetLastError {
+ { [ dup expected-io-error? ] [ drop f ] }
+ { [ dup eof? ] [ drop t ] }
+ [ n>win32-error-string throw ]
+ } cond
+ ] [ f ] if ;
+
+: wait-for-file ( FileArgs n port -- n )
+ swap file-error?
+ [ 2drop 0 ] [ [ lpOverlapped>> ] dip twiddle-thumbs ] if ;
+
+: update-file-ptr ( n port -- )
+ handle>> dup ptr>> [ rot + >>ptr drop ] [ 2drop ] if* ;
+
+: finish-write ( n port -- )
+ [ update-file-ptr ] [ buffer>> buffer-consume ] 2bi ;
+
+: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer-end ]
+ [ lpBuffer>> buffer-capacity ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
+ {
+ [ hFile>> ]
+ [ lpBuffer>> buffer@ ]
+ [ lpBuffer>> buffer-length ]
+ [ lpNumberOfBytesRet>> ]
+ [ lpOverlapped>> ]
+ } cleave ;
+
+M: winnt (wait-to-write)
+ [
+ [ make-FileArgs dup setup-write WriteFile ]
+ [ wait-for-file ]
+ [ finish-write ]
+ tri
+ ] with-destructors ;
+
+: finish-read ( n port -- )
+ [ update-file-ptr ] [ buffer>> n>buffer ] 2bi ;
+
+M: winnt (wait-to-read) ( port -- )
+ [
+ [ make-FileArgs dup setup-read ReadFile ]
+ [ wait-for-file ]
+ [ finish-read ]
+ tri
+ ] with-destructors ;
+
+: console-app? ( -- ? ) GetConsoleWindow >boolean ;
+
+M: winnt init-stdio
+ console-app?
+ [ init-c-stdio ]
+ [ null-reader null-writer null-writer set-stdio ] if ;
+
: open-file ( path access-mode create-mode flags -- handle )
[
[ share-mode default-security-attributes ] 2dip
[ [ handle>> ] dip d>w/w <uint> ] dip SetFilePointer
INVALID_SET_FILE_POINTER = [ "SetFilePointer failed" throw ] when ;
-HOOK: open-append os ( path -- win32-file )
-
-TUPLE: FileArgs
- hFile lpBuffer nNumberOfBytesToRead
- lpNumberOfBytesRet lpOverlapped ;
-
-C: <FileArgs> FileArgs
-
-: make-FileArgs ( port -- <FileArgs> )
- {
- [ handle>> check-disposed ]
- [ handle>> handle>> ]
- [ buffer>> ]
- [ buffer>> buffer-length ]
- [ drop DWORD <c-object> ]
- [ FileArgs-overlapped ]
- } cleave <FileArgs> ;
-
-: setup-read ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRead lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer-end ]
- [ lpBuffer>> buffer-capacity ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
-: setup-write ( <FileArgs> -- hFile lpBuffer nNumberOfBytesToWrite lpNumberOfBytesWritten lpOverlapped )
- {
- [ hFile>> ]
- [ lpBuffer>> buffer@ ]
- [ lpBuffer>> buffer-length ]
- [ lpNumberOfBytesRet>> ]
- [ lpOverlapped>> ]
- } cleave ;
-
M: windows (file-reader) ( path -- stream )
open-read <input-port> ;
[ 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 <ushort-array>
+ [ GetCurrentDirectory win32-error=0/f ] keep
+ utf16n alien>string ;
+
+M: winnt cd
+ SetCurrentDirectory win32-error=0/f ;
+
+CONSTANT: unicode-prefix "\\\\?\\"
+
+M: winnt root-directory? ( path -- ? )
+ {
+ { [ dup empty? ] [ drop f ] }
+ { [ dup [ path-separator? ] all? ] [ drop t ] }
+ { [ dup trim-tail-separators { [ length 2 = ]
+ [ second CHAR: : = ] } 1&& ] [ drop t ] }
+ { [ dup unicode-prefix head? ]
+ [ trim-tail-separators length unicode-prefix length 2 + = ] }
+ [ drop f ]
+ } cond ;
+
+: prepend-prefix ( string -- string' )
+ dup unicode-prefix head? [
+ unicode-prefix prepend
+ ] unless ;
+
+TR: normalize-separators "/" "\\" ;
+
+M: winnt normalize-path ( string -- string' )
+ absolute-path
+ normalize-separators
+ prepend-prefix ;
+
+M: winnt CreateFile-flags ( DWORD -- DWORD )
+ FILE_FLAG_OVERLAPPED bitor ;
+
+<PRIVATE
+
+: windows-file-size ( path -- size )
+ normalize-path 0 WIN32_FILE_ATTRIBUTE_DATA <struct>
+ [ GetFileAttributesEx win32-error=0/f ] keep
+ [ nFileSizeLow>> ] [ nFileSizeHigh>> ] bi >64bit ;
+
+PRIVATE>
+
+M: winnt open-append
+ [ dup windows-file-size ] [ drop 0 ] recover
+ [ (open-append) ] dip >>ptr ;
+
+M: winnt home
+ {
+ [ "HOMEDRIVE" os-env "HOMEPATH" os-env append-path ]
+ [ "USERPROFILE" os-env ]
+ [ my-documents ]
+ } 0|| ;
\ No newline at end of file
{
{ [ os unix? ] [ "io.launcher.unix" require ] }
- { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
+ { [ os windows? ] [ "io.launcher.windows" require ] }
[ ]
} cond
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: io.launcher tools.test calendar accessors environment
-namespaces kernel system arrays io io.files io.encodings.ascii
-sequences parser assocs hashtables math continuations eval
-io.files.temp io.directories io.pathnames splitting ;
-IN: io.launcher.windows.nt.tests
-
-[ ] [
- <process>
- "notepad" >>command
- 1/2 seconds >>timeout
- "notepad" set
-] unit-test
-
-[ f ] [ "notepad" get process-running? ] unit-test
-
-[ f ] [ "notepad" get process-started? ] unit-test
-
-[ ] [ "notepad" [ run-detached ] change ] unit-test
-
-[ "notepad" get wait-for-process ] must-fail
-
-[ t ] [ "notepad" get killed>> ] unit-test
-
-[ f ] [ "notepad" get process-running? ] unit-test
-
-[
- <process>
- "notepad" >>command
- 1/2 seconds >>timeout
- try-process
-] must-fail
-
-[
- <process>
- "notepad" >>command
- 1/2 seconds >>timeout
- try-output-process
-] must-fail
-
-: console-vm ( -- path )
- vm ".exe" ?tail [ ".com" append ] when ;
-
-[ ] [
- <process>
- console-vm "-quiet" "-run=hello-world" 3array >>command
- "out.txt" temp-file >>stdout
- try-process
-] unit-test
-
-[ "Hello world" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ "( scratchpad ) " ] [
- <process>
- console-vm "-run=listener" 2array >>command
- +closed+ >>stdin
- +stdout+ >>stderr
- ascii [ lines last ] with-process-reader
-] unit-test
-
-: launcher-test-path ( -- str )
- "resource:basis/io/launcher/windows/nt/test" ;
-
-[ ] [
- launcher-test-path [
- <process>
- console-vm "-script" "stderr.factor" 3array >>command
- "out.txt" temp-file >>stdout
- "err.txt" temp-file >>stderr
- try-process
- ] with-directory
-] unit-test
-
-[ "output" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ "error" ] [
- "err.txt" temp-file ascii file-lines first
-] unit-test
-
-[ ] [
- launcher-test-path [
- <process>
- console-vm "-script" "stderr.factor" 3array >>command
- "out.txt" temp-file >>stdout
- +stdout+ >>stderr
- try-process
- ] with-directory
-] unit-test
-
-[ "outputerror" ] [
- "out.txt" temp-file ascii file-lines first
-] unit-test
-
-[ "output" ] [
- launcher-test-path [
- <process>
- console-vm "-script" "stderr.factor" 3array >>command
- "err2.txt" temp-file >>stderr
- ascii <process-reader> stream-lines first
- ] with-directory
-] unit-test
-
-[ "error" ] [
- "err2.txt" temp-file ascii file-lines first
-] unit-test
-
-[ t ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- os-envs =
-] unit-test
-
-[ t ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- +replace-environment+ >>environment-mode
- os-envs >>environment
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- os-envs =
-] unit-test
-
-[ "B" ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- { { "A" "B" } } >>environment
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- "A" swap at
-] unit-test
-
-[ f ] [
- launcher-test-path [
- <process>
- console-vm "-script" "env.factor" 3array >>command
- { { "USERPROFILE" "XXX" } } >>environment
- +prepend-environment+ >>environment-mode
- ascii <process-reader> stream-contents
- ] with-directory eval( -- alist )
-
- "USERPROFILE" swap at "XXX" =
-] unit-test
-
-2 [
- [ ] [
- <process>
- "cmd.exe /c dir" >>command
- "dir.txt" temp-file >>stdout
- try-process
- ] unit-test
-
- [ ] [ "dir.txt" temp-file delete-file ] unit-test
-] times
-
-[ "append-test" temp-file delete-file ] ignore-errors
-
-[ "Hello appender\r\nHello appender\r\n" ] [
- 2 [
- launcher-test-path [
- <process>
- console-vm "-script" "append.factor" 3array >>command
- "append-test" temp-file <appender> >>stdout
- try-process
- ] with-directory
- ] times
-
- "append-test" temp-file ascii file-contents
-] unit-test
-
-[ "( scratchpad ) " ] [
- console-vm "-run=listener" 2array
- ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream
-] unit-test
-
-[ ] [
- console-vm "-run=listener" 2array
- ascii [ "USE: system 0 exit" print ] with-process-writer
-] unit-test
-
-[ ] [
- <process>
- console-vm "-run=listener" 2array >>command
- "vocab:io/launcher/windows/nt/test/input.txt" >>stdin
- try-process
-] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types combinators destructors
-io.backend io.backend.windows io.files.windows io.launcher
-io.launcher.windows io.pipes io.ports kernel locals strings
-system windows.errors windows.handles windows.kernel32
-windows.types ;
-IN: io.launcher.windows.nt
-
-: duplicate-handle ( handle -- handle' )
- GetCurrentProcess ! source process
- swap handle>> ! handle
- GetCurrentProcess ! target process
- f <void*> [ ! target handle
- DUPLICATE_SAME_ACCESS ! desired access
- TRUE ! inherit handle
- 0 ! options
- DuplicateHandle win32-error=0/f
- ] keep *void* <win32-handle> &dispose ;
-
-! /dev/null simulation
-: null-input ( -- pipe )
- (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
-
-: null-output ( -- pipe )
- (pipe) [ out>> &dispose ] [ in>> dispose ] bi ;
-
-: null-pipe ( mode -- pipe )
- {
- { GENERIC_READ [ null-input ] }
- { GENERIC_WRITE [ null-output ] }
- } case ;
-
-! The below code is based on the example given in
-! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
-
-: redirect-default ( obj access-mode create-mode -- handle )
- 3drop f ;
-
-: redirect-closed ( obj access-mode create-mode -- handle )
- drop nip null-pipe ;
-
-:: redirect-file ( path access-mode create-mode -- handle )
- path normalize-path
- access-mode
- share-mode
- default-security-attributes
- create-mode
- FILE_ATTRIBUTE_NORMAL ! flags and attributes
- f ! template file
- CreateFile check-invalid-handle <win32-file> &dispose ;
-
-: redirect-append ( path access-mode create-mode -- handle )
- [ path>> ] 2dip
- drop OPEN_ALWAYS
- redirect-file
- dup 0 FILE_END set-file-pointer ;
-
-: redirect-handle ( handle access-mode create-mode -- handle )
- 2drop ;
-
-: redirect-stream ( stream access-mode create-mode -- handle )
- [ underlying-handle ] 2dip redirect-handle ;
-
-: redirect ( obj access-mode create-mode -- handle )
- {
- { [ pick not ] [ redirect-default ] }
- { [ pick +closed+ eq? ] [ redirect-closed ] }
- { [ pick string? ] [ redirect-file ] }
- { [ pick appender? ] [ redirect-append ] }
- { [ pick win32-file? ] [ redirect-handle ] }
- [ redirect-stream ]
- } cond
- dup [ dup t set-inherit handle>> ] when ;
-
-: redirect-stdout ( process args -- handle )
- drop
- stdout>>
- GENERIC_WRITE
- CREATE_ALWAYS
- redirect
- STD_OUTPUT_HANDLE GetStdHandle or ;
-
-: redirect-stderr ( process args -- handle )
- over stderr>> +stdout+ eq? [
- nip
- lpStartupInfo>> hStdOutput>>
- ] [
- drop
- stderr>>
- GENERIC_WRITE
- CREATE_ALWAYS
- redirect
- STD_ERROR_HANDLE GetStdHandle or
- ] if ;
-
-: redirect-stdin ( process args -- handle )
- drop
- stdin>>
- GENERIC_READ
- OPEN_EXISTING
- redirect
- STD_INPUT_HANDLE GetStdHandle or ;
-
-M: winnt fill-redirection ( process args -- )
- dup lpStartupInfo>>
- [ [ redirect-stdout ] dip hStdOutput<< ]
- [ [ redirect-stderr ] dip hStdError<< ]
- [ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
+++ /dev/null
-USE: io\r
-"Hello appender" print\r
+++ /dev/null
-USE: system
-USE: prettyprint
-USE: environment
-os-envs .
+++ /dev/null
-USE: system 0 exit\r
+++ /dev/null
-USE: io\r
-USE: namespaces\r
-\r
-"output" write flush\r
-"error" error-stream get stream-write error-stream get stream-flush\r
--- /dev/null
+USE: io
+"Hello appender" print
--- /dev/null
+USE: system
+USE: prettyprint
+USE: environment
+os-envs .
--- /dev/null
+USE: system 0 exit
--- /dev/null
+USE: io
+USE: namespaces
+
+"output" write flush
+"error" error-stream get stream-write error-stream get stream-flush
+USING: accessors arrays assocs calendar continuations\r
+environment eval hashtables io io.directories\r
+io.encodings.ascii io.files io.files.temp io.launcher\r
+io.launcher.windows io.pathnames kernel math namespaces parser\r
+sequences splitting system tools.test ;\r
IN: io.launcher.windows.tests\r
-USING: tools.test io.launcher.windows ;\r
\r
[ "hello world" ] [ { "hello" "world" } join-arguments ] unit-test\r
\r
[ "bob mac\\\\arthur" ] [ { "bob" "mac\\\\arthur" } join-arguments ] unit-test\r
\r
[ "bob \"mac arthur\\\\\"" ] [ { "bob" "mac arthur\\" } join-arguments ] unit-test\r
+\r
+[ ] [\r
+ <process>\r
+ "notepad" >>command\r
+ 1/2 seconds >>timeout\r
+ "notepad" set\r
+] unit-test\r
+\r
+[ f ] [ "notepad" get process-running? ] unit-test\r
+\r
+[ f ] [ "notepad" get process-started? ] unit-test\r
+\r
+[ ] [ "notepad" [ run-detached ] change ] unit-test\r
+\r
+[ "notepad" get wait-for-process ] must-fail\r
+\r
+[ t ] [ "notepad" get killed>> ] unit-test\r
+\r
+[ f ] [ "notepad" get process-running? ] unit-test\r
+\r
+[\r
+ <process>\r
+ "notepad" >>command\r
+ 1/2 seconds >>timeout\r
+ try-process\r
+] must-fail\r
+\r
+[\r
+ <process>\r
+ "notepad" >>command\r
+ 1/2 seconds >>timeout\r
+ try-output-process\r
+] must-fail\r
+\r
+: console-vm ( -- path )\r
+ vm ".exe" ?tail [ ".com" append ] when ;\r
+\r
+[ ] [\r
+ <process>\r
+ console-vm "-quiet" "-run=hello-world" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ try-process\r
+] unit-test\r
+\r
+[ "Hello world" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "( scratchpad ) " ] [\r
+ <process>\r
+ console-vm "-run=listener" 2array >>command\r
+ +closed+ >>stdin\r
+ +stdout+ >>stderr\r
+ ascii [ lines last ] with-process-reader\r
+] unit-test\r
+\r
+: launcher-test-path ( -- str )\r
+ "resource:basis/io/launcher/windows/test" ;\r
+\r
+[ ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "stderr.factor" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ "err.txt" temp-file >>stderr\r
+ try-process\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "output" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "error" ] [\r
+ "err.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "stderr.factor" 3array >>command\r
+ "out.txt" temp-file >>stdout\r
+ +stdout+ >>stderr\r
+ try-process\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "outputerror" ] [\r
+ "out.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ "output" ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "stderr.factor" 3array >>command\r
+ "err2.txt" temp-file >>stderr\r
+ ascii <process-reader> stream-lines first\r
+ ] with-directory\r
+] unit-test\r
+\r
+[ "error" ] [\r
+ "err2.txt" temp-file ascii file-lines first\r
+] unit-test\r
+\r
+[ t ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+\r
+ os-envs =\r
+] unit-test\r
+\r
+[ t ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ +replace-environment+ >>environment-mode\r
+ os-envs >>environment\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+ \r
+ os-envs =\r
+] unit-test\r
+\r
+[ "B" ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ { { "A" "B" } } >>environment\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+\r
+ "A" swap at\r
+] unit-test\r
+\r
+[ f ] [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "env.factor" 3array >>command\r
+ { { "USERPROFILE" "XXX" } } >>environment\r
+ +prepend-environment+ >>environment-mode\r
+ ascii <process-reader> stream-contents\r
+ ] with-directory eval( -- alist )\r
+\r
+ "USERPROFILE" swap at "XXX" =\r
+] unit-test\r
+\r
+2 [\r
+ [ ] [\r
+ <process>\r
+ "cmd.exe /c dir" >>command\r
+ "dir.txt" temp-file >>stdout\r
+ try-process\r
+ ] unit-test\r
+\r
+ [ ] [ "dir.txt" temp-file delete-file ] unit-test\r
+] times\r
+\r
+[ "append-test" temp-file delete-file ] ignore-errors\r
+\r
+[ "Hello appender\r\nHello appender\r\n" ] [\r
+ 2 [\r
+ launcher-test-path [\r
+ <process>\r
+ console-vm "-script" "append.factor" 3array >>command\r
+ "append-test" temp-file <appender> >>stdout\r
+ try-process\r
+ ] with-directory\r
+ ] times\r
+ \r
+ "append-test" temp-file ascii file-contents\r
+] unit-test\r
+\r
+[ "( scratchpad ) " ] [\r
+ console-vm "-run=listener" 2array\r
+ ascii [ "USE: system 0 exit" print flush lines last ] with-process-stream\r
+] unit-test\r
+\r
+[ ] [\r
+ console-vm "-run=listener" 2array\r
+ ascii [ "USE: system 0 exit" print ] with-process-writer\r
+] unit-test\r
+\r
+[ ] [\r
+ <process>\r
+ console-vm "-run=listener" 2array >>command\r
+ "vocab:io/launcher/windows/test/input.txt" >>stdin\r
+ try-process\r
+] unit-test\r
! 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
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when
dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;
+
+: duplicate-handle ( handle -- handle' )
+ GetCurrentProcess ! source process
+ swap handle>> ! handle
+ GetCurrentProcess ! target process
+ f <void*> [ ! target handle
+ DUPLICATE_SAME_ACCESS ! desired access
+ TRUE ! inherit handle
+ 0 ! options
+ DuplicateHandle win32-error=0/f
+ ] keep *void* <win32-handle> &dispose ;
+
+! /dev/null simulation
+: null-input ( -- pipe )
+ (pipe) [ in>> &dispose ] [ out>> dispose ] bi ;
+
+: null-output ( -- pipe )
+ (pipe) [ out>> &dispose ] [ in>> dispose ] bi ;
+
+: null-pipe ( mode -- pipe )
+ {
+ { GENERIC_READ [ null-input ] }
+ { GENERIC_WRITE [ null-output ] }
+ } case ;
+
+! The below code is based on the example given in
+! http://msdn2.microsoft.com/en-us/library/ms682499.aspx
+
+: redirect-default ( obj access-mode create-mode -- handle )
+ 3drop f ;
+
+: redirect-closed ( obj access-mode create-mode -- handle )
+ drop nip null-pipe ;
+
+:: redirect-file ( path access-mode create-mode -- handle )
+ path normalize-path
+ access-mode
+ share-mode
+ default-security-attributes
+ create-mode
+ FILE_ATTRIBUTE_NORMAL ! flags and attributes
+ f ! template file
+ CreateFile check-invalid-handle <win32-file> &dispose ;
+
+: redirect-append ( path access-mode create-mode -- handle )
+ [ path>> ] 2dip
+ drop OPEN_ALWAYS
+ redirect-file
+ dup 0 FILE_END set-file-pointer ;
+
+: redirect-handle ( handle access-mode create-mode -- handle )
+ 2drop ;
+
+: redirect-stream ( stream access-mode create-mode -- handle )
+ [ underlying-handle ] 2dip redirect-handle ;
+
+: redirect ( obj access-mode create-mode -- handle )
+ {
+ { [ pick not ] [ redirect-default ] }
+ { [ pick +closed+ eq? ] [ redirect-closed ] }
+ { [ pick string? ] [ redirect-file ] }
+ { [ pick appender? ] [ redirect-append ] }
+ { [ pick win32-file? ] [ redirect-handle ] }
+ [ redirect-stream ]
+ } cond
+ dup [ dup t set-inherit handle>> ] when ;
+
+: redirect-stdout ( process args -- handle )
+ drop
+ stdout>>
+ GENERIC_WRITE
+ CREATE_ALWAYS
+ redirect
+ STD_OUTPUT_HANDLE GetStdHandle or ;
+
+: redirect-stderr ( process args -- handle )
+ over stderr>> +stdout+ eq? [
+ nip
+ lpStartupInfo>> hStdOutput>>
+ ] [
+ drop
+ stderr>>
+ GENERIC_WRITE
+ CREATE_ALWAYS
+ redirect
+ STD_ERROR_HANDLE GetStdHandle or
+ ] if ;
+
+: redirect-stdin ( process args -- handle )
+ drop
+ stdin>>
+ GENERIC_READ
+ OPEN_EXISTING
+ redirect
+ STD_INPUT_HANDLE GetStdHandle or ;
+
+M: winnt fill-redirection ( process args -- )
+ dup lpStartupInfo>>
+ [ [ redirect-stdout ] dip hStdOutput<< ]
+ [ [ redirect-stderr ] dip hStdError<< ]
+ [ [ redirect-stdin ] dip hStdInput<< ] 3tri ;
-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 ;
-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? [
[
{
{ [ 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
--- /dev/null
+Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-IN: io.monitors.windows.nt.tests\r
-USING: io.monitors.windows.nt tools.test ;\r
-\r
-\r
+++ /dev/null
-! 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 <uint>
- (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 <displaced-alien> ] 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 <buffered-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 ;
--- /dev/null
+! 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 <uint>
+ (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 <displaced-alien> ] 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 <buffered-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 ;
{
{ [ os unix? ] [ "io.pipes.unix" require ] }
- { [ os winnt? ] [ "io.pipes.windows.nt" require ] }
+ { [ os windows? ] [ "io.pipes.windows" require ] }
[ ]
} cond
--- /dev/null
+Slava Pestov
+++ /dev/null
-Slava Pestov
+++ /dev/null
-! 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 ;
--- /dev/null
+! 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 ;
{
{ [ os unix? ] [ "io.sockets.unix" require ] }
- { [ os winnt? ] [ "io.sockets.windows.nt" require ] }
+ { [ os windows? ] [ "io.sockets.windows" require ] }
} cond
--- /dev/null
+Doug Coleman
+Slava Pestov
+Mackenzie Straight
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: alien alien.accessors alien.c-types alien.data byte-arrays
-continuations destructors io.ports io.timeouts io.sockets
-io.sockets.private io namespaces io.streams.duplex
-io.backend.windows io.sockets.windows io.backend.windows.nt
-windows.winsock kernel libc math sequences threads system
-combinators accessors classes.struct windows.kernel32
-windows.types ;
-IN: io.sockets.windows.nt
-
-: malloc-int ( n -- alien )
- <int> malloc-byte-array ; inline
-
-M: winnt WSASocket-flags ( -- DWORD )
- WSA_FLAG_OVERLAPPED ;
-
-: get-ConnectEx-ptr ( socket -- void* )
- SIO_GET_EXTENSION_FUNCTION_POINTER
- WSAID_CONNECTEX
- GUID heap-size
- { void* }
- [
- void* heap-size
- DWORD <c-object>
- f
- f
- WSAIoctl SOCKET_ERROR = [
- winsock-error-string throw
- ] when
- ] with-out-parameters ;
-
-TUPLE: ConnectEx-args port
- s name namelen lpSendBuffer dwSendDataLength
- lpdwBytesSent lpOverlapped ptr ;
-
-: wait-for-socket ( args -- n )
- [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline
-
-: <ConnectEx-args> ( sockaddr size -- ConnectEx )
- ConnectEx-args new
- swap >>namelen
- swap >>name
- f >>lpSendBuffer
- 0 >>dwSendDataLength
- f >>lpdwBytesSent
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-ConnectEx ( ConnectEx -- )
- {
- [ s>> ]
- [ name>> ]
- [ namelen>> ]
- [ lpSendBuffer>> ]
- [ dwSendDataLength>> ]
- [ lpdwBytesSent>> ]
- [ lpOverlapped>> ]
- [ ptr>> ]
- } cleave
- int
- { SOCKET void* int PVOID DWORD LPDWORD void* }
- stdcall alien-indirect drop
- winsock-error-string [ throw ] when* ; inline
-
-M: object establish-connection ( client-out remote -- )
- make-sockaddr/size <ConnectEx-args>
- swap >>port
- dup port>> handle>> handle>> >>s
- dup s>> get-ConnectEx-ptr >>ptr
- dup call-ConnectEx
- wait-for-socket drop ;
-
-TUPLE: AcceptEx-args port
- sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength
- dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;
-
-: init-accept-buffer ( addr AcceptEx -- )
- swap sockaddr-size 16 +
- [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi
- dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer
- drop ; inline
-
-: <AcceptEx-args> ( server addr -- AcceptEx )
- AcceptEx-args new
- 2dup init-accept-buffer
- swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket
- over handle>> handle>> >>sListenSocket
- swap >>port
- 0 >>dwReceiveDataLength
- f >>lpdwBytesReceived
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-AcceptEx ( AcceptEx -- )
- {
- [ sListenSocket>> ]
- [ sAcceptSocket>> ]
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- [ lpdwBytesReceived>> ]
- [ lpOverlapped>> ]
- } cleave AcceptEx drop
- winsock-error-string [ throw ] when* ; inline
-
-: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )
- f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;
-
-: extract-remote-address ( AcceptEx -- sockaddr )
- [
- {
- [ lpOutputBuffer>> ]
- [ dwReceiveDataLength>> ]
- [ dwLocalAddressLength>> ]
- [ dwRemoteAddressLength>> ]
- } cleave
- (extract-remote-address)
- ] [ port>> addr>> protocol-family ] bi
- sockaddr-of-family ; inline
-
-M: object (accept) ( server addr -- handle sockaddr )
- [
- <AcceptEx-args>
- {
- [ call-AcceptEx ]
- [ wait-for-socket drop ]
- [ sAcceptSocket>> <win32-socket> ]
- [ extract-remote-address ]
- } cleave
- ] with-destructors ;
-
-TUPLE: WSARecvFrom-args port
- s lpBuffers dwBufferCount lpNumberOfBytesRecvd
- lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;
-
-: make-receive-buffer ( -- WSABUF )
- WSABUF malloc-struct &free
- default-buffer-size get
- [ >>len ] [ malloc &free >>buf ] bi ; inline
-
-: <WSARecvFrom-args> ( datagram -- WSARecvFrom )
- WSARecvFrom-args new
- swap >>port
- dup port>> handle>> handle>> >>s
- dup port>> addr>> sockaddr-size
- [ malloc &free >>lpFrom ]
- [ malloc-int &free >>lpFromLen ] bi
- make-receive-buffer >>lpBuffers
- 1 >>dwBufferCount
- 0 malloc-int &free >>lpFlags
- 0 malloc-int &free >>lpNumberOfBytesRecvd
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-WSARecvFrom ( WSARecvFrom -- )
- {
- [ s>> ]
- [ lpBuffers>> ]
- [ dwBufferCount>> ]
- [ lpNumberOfBytesRecvd>> ]
- [ lpFlags>> ]
- [ lpFrom>> ]
- [ lpFromLen>> ]
- [ lpOverlapped>> ]
- [ lpCompletionRoutine>> ]
- } cleave WSARecvFrom socket-error* ; inline
-
-: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )
- [ lpBuffers>> buf>> swap memory>byte-array ]
- [
- [ port>> addr>> empty-sockaddr dup ]
- [ lpFrom>> ]
- [ lpFromLen>> *int ]
- tri memcpy
- ] bi ; inline
-
-M: winnt (receive) ( datagram -- packet addrspec )
- [
- <WSARecvFrom-args>
- [ call-WSARecvFrom ]
- [ wait-for-socket ]
- [ parse-WSARecvFrom ]
- tri
- ] with-destructors ;
-
-TUPLE: WSASendTo-args port
- s lpBuffers dwBufferCount lpNumberOfBytesSent
- dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;
-
-: make-send-buffer ( packet -- WSABUF )
- [ WSABUF malloc-struct &free ] dip
- [ malloc-byte-array &free >>buf ]
- [ length >>len ] bi ; inline
-
-: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )
- WSASendTo-args new
- swap >>port
- dup port>> handle>> handle>> >>s
- swap make-sockaddr/size
- [ malloc-byte-array &free ] dip
- [ >>lpTo ] [ >>iToLen ] bi*
- swap make-send-buffer >>lpBuffers
- 1 >>dwBufferCount
- 0 >>dwFlags
- 0 <uint> >>lpNumberOfBytesSent
- (make-overlapped) >>lpOverlapped ; inline
-
-: call-WSASendTo ( WSASendTo -- )
- {
- [ s>> ]
- [ lpBuffers>> ]
- [ dwBufferCount>> ]
- [ lpNumberOfBytesSent>> ]
- [ dwFlags>> ]
- [ lpTo>> ]
- [ iToLen>> ]
- [ lpOverlapped>> ]
- [ lpCompletionRoutine>> ]
- } cleave WSASendTo socket-error* ; inline
-
-M: winnt (send) ( packet addrspec datagram -- )
- [
- <WSASendTo-args>
- [ call-WSASendTo ]
- [ wait-for-socket drop ]
- bi
- ] with-destructors ;
! Copyright (C) 2007, 2009 Slava Pestov, Doug Coleman.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors alien.c-types classes.struct combinators\r
-destructors io.backend io.backend.windows io.sockets\r
-io.sockets.private kernel system windows.handles\r
-windows.winsock ;\r
+USING: accessors alien alien.c-types alien.data classes.struct\r
+combinators destructors io.backend io.ports\r
+io.sockets io.sockets.private kernel libc math sequences system\r
+windows.handles windows.kernel32 windows.types windows.winsock ;\r
FROM: namespaces => get ;\r
IN: io.sockets.windows\r
\r
\r
M: windows (datagram) ( addrspec -- handle )\r
[ SOCK_DGRAM server-socket ] with-destructors ;\r
+\r
+\r
+: malloc-int ( n -- alien )\r
+ <int> malloc-byte-array ; inline\r
+\r
+M: winnt WSASocket-flags ( -- DWORD )\r
+ WSA_FLAG_OVERLAPPED ;\r
+\r
+: get-ConnectEx-ptr ( socket -- void* )\r
+ SIO_GET_EXTENSION_FUNCTION_POINTER\r
+ WSAID_CONNECTEX\r
+ GUID heap-size\r
+ { void* }\r
+ [\r
+ void* heap-size\r
+ DWORD <c-object>\r
+ f\r
+ f\r
+ WSAIoctl SOCKET_ERROR = [\r
+ winsock-error-string throw\r
+ ] when\r
+ ] with-out-parameters ;\r
+\r
+TUPLE: ConnectEx-args port\r
+ s name namelen lpSendBuffer dwSendDataLength\r
+ lpdwBytesSent lpOverlapped ptr ;\r
+\r
+: wait-for-socket ( args -- n )\r
+ [ lpOverlapped>> ] [ port>> ] bi twiddle-thumbs ; inline\r
+\r
+: <ConnectEx-args> ( sockaddr size -- ConnectEx )\r
+ ConnectEx-args new\r
+ swap >>namelen\r
+ swap >>name\r
+ f >>lpSendBuffer\r
+ 0 >>dwSendDataLength\r
+ f >>lpdwBytesSent\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-ConnectEx ( ConnectEx -- )\r
+ {\r
+ [ s>> ]\r
+ [ name>> ]\r
+ [ namelen>> ]\r
+ [ lpSendBuffer>> ]\r
+ [ dwSendDataLength>> ]\r
+ [ lpdwBytesSent>> ]\r
+ [ lpOverlapped>> ]\r
+ [ ptr>> ]\r
+ } cleave\r
+ int\r
+ { SOCKET void* int PVOID DWORD LPDWORD void* }\r
+ stdcall alien-indirect drop\r
+ winsock-error-string [ throw ] when* ; inline\r
+\r
+M: object establish-connection ( client-out remote -- )\r
+ make-sockaddr/size <ConnectEx-args>\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ dup s>> get-ConnectEx-ptr >>ptr\r
+ dup call-ConnectEx\r
+ wait-for-socket drop ;\r
+\r
+TUPLE: AcceptEx-args port\r
+ sListenSocket sAcceptSocket lpOutputBuffer dwReceiveDataLength\r
+ dwLocalAddressLength dwRemoteAddressLength lpdwBytesReceived lpOverlapped ;\r
+\r
+: init-accept-buffer ( addr AcceptEx -- )\r
+ swap sockaddr-size 16 +\r
+ [ >>dwLocalAddressLength ] [ >>dwRemoteAddressLength ] bi\r
+ dup dwLocalAddressLength>> 2 * malloc &free >>lpOutputBuffer\r
+ drop ; inline\r
+\r
+: <AcceptEx-args> ( server addr -- AcceptEx )\r
+ AcceptEx-args new\r
+ 2dup init-accept-buffer\r
+ swap SOCK_STREAM open-socket |dispose handle>> >>sAcceptSocket\r
+ over handle>> handle>> >>sListenSocket\r
+ swap >>port\r
+ 0 >>dwReceiveDataLength\r
+ f >>lpdwBytesReceived\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-AcceptEx ( AcceptEx -- )\r
+ {\r
+ [ sListenSocket>> ]\r
+ [ sAcceptSocket>> ]\r
+ [ lpOutputBuffer>> ]\r
+ [ dwReceiveDataLength>> ]\r
+ [ dwLocalAddressLength>> ]\r
+ [ dwRemoteAddressLength>> ]\r
+ [ lpdwBytesReceived>> ]\r
+ [ lpOverlapped>> ]\r
+ } cleave AcceptEx drop\r
+ winsock-error-string [ throw ] when* ; inline\r
+\r
+: (extract-remote-address) ( lpOutputBuffer dwReceiveDataLength dwLocalAddressLength dwRemoteAddressLength -- sockaddr )\r
+ f <void*> 0 <int> f <void*> [ 0 <int> GetAcceptExSockaddrs ] keep *void* ;\r
+\r
+: extract-remote-address ( AcceptEx -- sockaddr )\r
+ [\r
+ {\r
+ [ lpOutputBuffer>> ]\r
+ [ dwReceiveDataLength>> ]\r
+ [ dwLocalAddressLength>> ]\r
+ [ dwRemoteAddressLength>> ]\r
+ } cleave\r
+ (extract-remote-address)\r
+ ] [ port>> addr>> protocol-family ] bi\r
+ sockaddr-of-family ; inline\r
+\r
+M: object (accept) ( server addr -- handle sockaddr )\r
+ [\r
+ <AcceptEx-args>\r
+ {\r
+ [ call-AcceptEx ]\r
+ [ wait-for-socket drop ]\r
+ [ sAcceptSocket>> <win32-socket> ]\r
+ [ extract-remote-address ]\r
+ } cleave\r
+ ] with-destructors ;\r
+\r
+TUPLE: WSARecvFrom-args port\r
+ s lpBuffers dwBufferCount lpNumberOfBytesRecvd\r
+ lpFlags lpFrom lpFromLen lpOverlapped lpCompletionRoutine ;\r
+\r
+: make-receive-buffer ( -- WSABUF )\r
+ WSABUF malloc-struct &free\r
+ default-buffer-size get\r
+ [ >>len ] [ malloc &free >>buf ] bi ; inline\r
+\r
+: <WSARecvFrom-args> ( datagram -- WSARecvFrom )\r
+ WSARecvFrom-args new\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ dup port>> addr>> sockaddr-size\r
+ [ malloc &free >>lpFrom ]\r
+ [ malloc-int &free >>lpFromLen ] bi\r
+ make-receive-buffer >>lpBuffers\r
+ 1 >>dwBufferCount\r
+ 0 malloc-int &free >>lpFlags\r
+ 0 malloc-int &free >>lpNumberOfBytesRecvd\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-WSARecvFrom ( WSARecvFrom -- )\r
+ {\r
+ [ s>> ]\r
+ [ lpBuffers>> ]\r
+ [ dwBufferCount>> ]\r
+ [ lpNumberOfBytesRecvd>> ]\r
+ [ lpFlags>> ]\r
+ [ lpFrom>> ]\r
+ [ lpFromLen>> ]\r
+ [ lpOverlapped>> ]\r
+ [ lpCompletionRoutine>> ]\r
+ } cleave WSARecvFrom socket-error* ; inline\r
+\r
+: parse-WSARecvFrom ( n WSARecvFrom -- packet sockaddr )\r
+ [ lpBuffers>> buf>> swap memory>byte-array ]\r
+ [\r
+ [ port>> addr>> empty-sockaddr dup ]\r
+ [ lpFrom>> ]\r
+ [ lpFromLen>> *int ]\r
+ tri memcpy\r
+ ] bi ; inline\r
+\r
+M: winnt (receive) ( datagram -- packet addrspec )\r
+ [\r
+ <WSARecvFrom-args>\r
+ [ call-WSARecvFrom ]\r
+ [ wait-for-socket ]\r
+ [ parse-WSARecvFrom ]\r
+ tri\r
+ ] with-destructors ;\r
+\r
+TUPLE: WSASendTo-args port\r
+ s lpBuffers dwBufferCount lpNumberOfBytesSent\r
+ dwFlags lpTo iToLen lpOverlapped lpCompletionRoutine ;\r
+\r
+: make-send-buffer ( packet -- WSABUF )\r
+ [ WSABUF malloc-struct &free ] dip\r
+ [ malloc-byte-array &free >>buf ]\r
+ [ length >>len ] bi ; inline\r
+\r
+: <WSASendTo-args> ( packet addrspec datagram -- WSASendTo )\r
+ WSASendTo-args new\r
+ swap >>port\r
+ dup port>> handle>> handle>> >>s\r
+ swap make-sockaddr/size\r
+ [ malloc-byte-array &free ] dip\r
+ [ >>lpTo ] [ >>iToLen ] bi*\r
+ swap make-send-buffer >>lpBuffers\r
+ 1 >>dwBufferCount\r
+ 0 >>dwFlags\r
+ 0 <uint> >>lpNumberOfBytesSent\r
+ (make-overlapped) >>lpOverlapped ; inline\r
+\r
+: call-WSASendTo ( WSASendTo -- )\r
+ {\r
+ [ s>> ]\r
+ [ lpBuffers>> ]\r
+ [ dwBufferCount>> ]\r
+ [ lpNumberOfBytesSent>> ]\r
+ [ dwFlags>> ]\r
+ [ lpTo>> ]\r
+ [ iToLen>> ]\r
+ [ lpOverlapped>> ]\r
+ [ lpCompletionRoutine>> ]\r
+ } cleave WSASendTo socket-error* ; inline\r
+\r
+M: winnt (send) ( packet addrspec datagram -- )\r
+ [\r
+ <WSASendTo-args>\r
+ [ call-WSASendTo ]\r
+ [ wait-for-socket drop ]\r
+ bi\r
+ ] with-destructors ;\r
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.data system-info kernel math namespaces
-windows windows.kernel32 system-info.backend system ;
-IN: system-info.windows.ce
-
-: memory-status ( -- MEMORYSTATUS )
- "MEMORYSTATUS" <c-object>
- "MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
- dup GlobalMemoryStatus ;
-
-M: wince cpus ( -- n ) 1 ;
-
-M: wince memory-load ( -- n )
- memory-status MEMORYSTATUS-dwMemoryLoad ;
-
-M: wince physical-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalPhys ;
-
-M: wince available-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailPhys ;
-
-M: wince total-page-file ( -- n )
- memory-status MEMORYSTATUS-dwTotalPageFile ;
-
-M: wince available-page-file ( -- n )
- memory-status MEMORYSTATUS-dwAvailPageFile ;
-
-M: wince total-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwTotalVirtual ;
-
-M: wince available-virtual-mem ( -- n )
- memory-status MEMORYSTATUS-dwAvailVirtual ;
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
+++ /dev/null
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings
-kernel libc math namespaces system-info.backend
-system-info.windows windows windows.advapi32
-windows.kernel32 system byte-arrays windows.errors
-classes classes.struct accessors ;
-IN: system-info.windows.nt
-
-M: winnt cpus ( -- n )
- system-info dwNumberOfProcessors>> ;
-
-: memory-status ( -- MEMORYSTATUSEX )
- MEMORYSTATUSEX <struct>
- MEMORYSTATUSEX heap-size >>dwLength
- dup GlobalMemoryStatusEx win32-error=0/f ;
-
-M: winnt memory-load ( -- n )
- memory-status dwMemoryLoad>> ;
-
-M: winnt physical-mem ( -- n )
- memory-status ullTotalPhys>> ;
-
-M: winnt available-mem ( -- n )
- memory-status ullAvailPhys>> ;
-
-M: winnt total-page-file ( -- n )
- memory-status ullTotalPageFile>> ;
-
-M: winnt available-page-file ( -- n )
- memory-status ullAvailPageFile>> ;
-
-M: winnt total-virtual-mem ( -- n )
- memory-status ullTotalVirtual>> ;
-
-M: winnt available-virtual-mem ( -- n )
- memory-status ullAvailVirtual>> ;
-
-: computer-name ( -- string )
- MAX_COMPUTERNAME_LENGTH 1 +
- [ <byte-array> dup ] keep <uint>
- GetComputerName win32-error=0/f alien>native-string ;
-
-: username ( -- string )
- UNLEN 1 +
- [ <byte-array> dup ] keep <uint>
- GetUserName win32-error=0/f alien>native-string ;
--- /dev/null
+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
! 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
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
-<<
-{
- { [ os wince? ] [ "system-info.windows.ce" ] }
- { [ os winnt? ] [ "system-info.windows.nt" ] }
-} cond require >>
+M: winnt cpus ( -- n )
+ system-info dwNumberOfProcessors>> ;
+
+: memory-status ( -- MEMORYSTATUSEX )
+ MEMORYSTATUSEX <struct>
+ MEMORYSTATUSEX heap-size >>dwLength
+ dup GlobalMemoryStatusEx win32-error=0/f ;
+
+M: winnt memory-load ( -- n )
+ memory-status dwMemoryLoad>> ;
+
+M: winnt physical-mem ( -- n )
+ memory-status ullTotalPhys>> ;
+
+M: winnt available-mem ( -- n )
+ memory-status ullAvailPhys>> ;
+
+M: winnt total-page-file ( -- n )
+ memory-status ullTotalPageFile>> ;
+
+M: winnt available-page-file ( -- n )
+ memory-status ullAvailPageFile>> ;
+
+M: winnt total-virtual-mem ( -- n )
+ memory-status ullTotalVirtual>> ;
+
+M: winnt available-virtual-mem ( -- n )
+ memory-status ullAvailVirtual>> ;
+
+: computer-name ( -- string )
+ MAX_COMPUTERNAME_LENGTH 1 +
+ [ <byte-array> dup ] keep <uint>
+ GetComputerName win32-error=0/f alien>native-string ;
+
+: username ( -- string )
+ UNLEN 1 +
+ [ <byte-array> dup ] keep <uint>
+ GetUserName win32-error=0/f alien>native-string ;
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"
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
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
+++ /dev/null
-Doug Coleman
+++ /dev/null
-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
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test windows.privileges ;
+IN: windows.privileges.tests
--- /dev/null
+! 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 <struct>
+ [ LookupPrivilegeValue win32-error=0/f ] keep ;
+
+:: make-token-privileges ( name enabled? -- obj )
+ TOKEN_PRIVILEGES <struct>
+ 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
! 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
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
-Slava Pestov
-Mackenzie Straight
+++ /dev/null
-USING: io.ports io.windows threads.private kernel
-io.backend windows.winsock windows.kernel32 windows
-io.streams.duplex io namespaces alien.syntax system combinators
-io.buffers io.encodings io.encodings.utf8 combinators.lib ;
-IN: io.windows.ce.backend
-
-: port-errored ( port -- )
- win32-error-string swap set-port-error ;
-
-M: wince io-multiplex ( ms -- )
- 60 60 * 1000 * or (sleep) ;
-
-M: wince add-completion ( handle -- ) drop ;
-
-GENERIC: wince-read ( port port-handle -- )
-
-M: input-port (wait-to-read) ( port -- )
- dup dup port-handle wince-read pending-error ;
-
-GENERIC: wince-write ( port port-handle -- )
-
-M: port port-flush
- dup buffer-empty? over port-error or [
- drop
- ] [
- dup dup port-handle wince-write port-flush
- ] if ;
-
-M: wince init-io ( -- )
- init-winsock ;
-
-LIBRARY: libc
-FUNCTION: void* _getstdfilex int fd ;
-FUNCTION: void* _fileno void* file ;
-
-M: wince (init-stdio) ( -- )
- #! We support Windows NT too, to make this I/O backend
- #! easier to debug.
- 512 default-buffer-size [
- os winnt? [
- STD_INPUT_HANDLE GetStdHandle
- STD_OUTPUT_HANDLE GetStdHandle
- STD_ERROR_HANDLE GetStdHandle
- ] [
- 0 _getstdfilex _fileno
- 1 _getstdfilex _fileno
- 2 _getstdfilex _fileno
- ] if [ f <win32-file> ] 3apply
- [ <input-port> ] [ <output-port> ] [ <output-port> ] tri*
- ] with-variable ;
+++ /dev/null
-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
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-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 ;
+++ /dev/null
-IN: io.windows.ce.privileges\r
-USING: io.windows.privileges system ;\r
-\r
-M: wince set-privilege 2drop ;\r
+++ /dev/null
-Doug Coleman
-Slava Pestov
+++ /dev/null
-USING: alien alien.c-types combinators io io.backend io.buffers
-io.ports io.sockets io.windows kernel libc
-math namespaces prettyprint qualified sequences strings threads
-threads.private windows windows.kernel32 io.windows.ce.backend
-byte-arrays system ;
-QUALIFIED: windows.winsock
-IN: io.windows.ce
-
-M: wince WSASocket-flags ( -- DWORD ) 0 ;
-
-M: win32-socket wince-read ( port port-handle -- )
- win32-file-handle over buffer-end pick buffer-capacity 0
- windows.winsock:recv
- dup windows.winsock:SOCKET_ERROR = [
- drop port-errored
- ] [
- dup zero?
- [ drop t swap set-port-eof? ] [ swap n>buffer ] if
- ] if ;
-
-M: win32-socket wince-write ( port port-handle -- )
- win32-file-handle over buffer@ pick buffer-length 0
- windows.winsock:send
- dup windows.winsock:SOCKET_ERROR =
- [ drop port-errored ] [ swap buffer-consume ] if ;
-
-: do-connect ( addrspec -- socket )
- [ tcp-socket dup ] keep
- make-sockaddr/size
- f f f f
- windows.winsock:WSAConnect
- windows.winsock:winsock-error!=0/f ;
-
-M: wince (client) ( addrspec -- reader writer )
- do-connect <win32-socket> dup <ports> ;
-
-M: wince (server) ( addrspec -- handle )
- windows.winsock:SOCK_STREAM server-fd
- dup listen-on-socket
- <win32-socket> ;
-
-M: wince (accept) ( server -- client )
- [
- [
- dup port-handle win32-file-handle
- swap server-port-addr sockaddr-type heap-size
- dup <byte-array> [
- swap <int> f 0
- windows.winsock:WSAAccept
- dup windows.winsock:INVALID_SOCKET =
- [ windows.winsock:winsock-error ] when
- ] keep
- ] keep server-port-addr parse-sockaddr swap
- <win32-socket> <ports>
- ] with-timeout ;
-
-M: wince <datagram> ( addrspec -- datagram )
- [
- windows.winsock:SOCK_DGRAM server-fd <win32-socket>
- ] keep <datagram-port> ;
-
-: packet-size 65536 ; inline
-
-: receive-buffer ( -- buf )
- \ receive-buffer get-global expired? [
- packet-size malloc \ receive-buffer set-global
- ] when
- \ receive-buffer get-global ;
-
-: make-WSABUF ( len buf -- ptr )
- "WSABUF" <c-object>
- [ windows.winsock:set-WSABUF-buf ] keep
- [ windows.winsock:set-WSABUF-len ] keep ;
-
-: receive-WSABUF ( -- buf )
- packet-size receive-buffer make-WSABUF ;
-
-: packet-data ( len -- byte-array )
- receive-buffer swap memory>byte-array ;
-
-packet-size <byte-array> receive-buffer set-global
-
-M: wince receive ( datagram -- packet addrspec )
- dup check-datagram-port
- [
- port-handle win32-file-handle
- receive-WSABUF
- 1
- 0 <uint> [
- 0 <uint>
- 64 "char" <c-array> [
- 64 <int>
- f
- f
- windows.winsock:WSARecvFrom
- windows.winsock:winsock-error!=0/f
- ] keep
- ] keep *uint packet-data swap
- ] keep datagram-port-addr parse-sockaddr ;
-
-: send-WSABUF ( byte-array -- ptr )
- dup length packet-size > [ "UDP packet too long" throw ] when
- dup length receive-buffer rot pick memcpy
- receive-buffer make-WSABUF ;
-
-M: wince send ( packet addrspec datagram -- )
- 3dup check-datagram-send
- port-handle win32-file-handle
- rot send-WSABUF
- rot make-sockaddr/size
- >r >r 1 0 <uint> 0 r> r> f f
- windows.winsock:WSASendTo
- windows.winsock:winsock-error!=0/f ;
+++ /dev/null
-Microsoft Windows CE native I/O implementation
-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)
+++ /dev/null
-CFLAGS += -DWINCE
-LIBS = -lm
-PLAF_DLL_OBJS += vm/os-windows-ce.o
-PLAF_EXE_OBJS += vm/main-windows-ce.o
-include vm/Config.windows
+++ /dev/null
-CC = arm-wince-mingw32ce-gcc
-DLL_SUFFIX=-ce
-EXE_SUFFIX=-ce
-include vm/Config.windows.ce vm/Config.arm
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-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
--- /dev/null
+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
--- /dev/null
+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
allocator = new free_list_allocator<code_block>(seg->end - start,start);
- /* See os-windows-nt-x86.64.cpp for seh_area usage */
+ /* See os-windows-x86.64.cpp for seh_area usage */
seh_area = (char *)seg->start;
}
+++ /dev/null
-#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;
-}
+++ /dev/null
-#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;
-}
--- /dev/null
+#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;
+}
+++ /dev/null
-#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;
-}
-
-}
--- /dev/null
+#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;
+}
+
+}
+++ /dev/null
-#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() { }
-
-}
+++ /dev/null
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-#include <ctype.h>
-
-namespace factor
-{
-
-typedef wchar_t symbol_char;
-
-#define FACTOR_OS_STRING "wince"
-#define FACTOR_DLL L"factor-ce.dll"
-
-int errno;
-char *strerror(int err);
-void flush_icache(cell start, cell end);
-char *getenv(char *name);
-
-#define snprintf _snprintf
-#define snwprintf _snwprintf
-
-void c_to_factor_toplevel(cell quot);
-void open_console();
-
-}
+++ /dev/null
-#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);
-}
-
-}
+++ /dev/null
-#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);
-}
-
-}
+++ /dev/null
-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
-
-}
+++ /dev/null
-namespace factor
-{
-
-#define ESP Rsp
-#define EIP Rip
-
-#define MXCSR(ctx) (ctx)->MxCsr
-
-}
+++ /dev/null
-#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()
-{
-}
-
-}
+++ /dev/null
-#undef _WIN32_WINNT
-#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
-
-#ifndef UNICODE
-#define UNICODE
-#endif
-
-#include <windows.h>
-#include <shellapi.h>
-
-#ifdef _MSC_VER
- #undef min
- #undef max
-#endif
-
-namespace factor
-{
-
-typedef char symbol_char;
-
-#define FACTOR_OS_STRING "winnt"
-
-#define FACTOR_DLL NULL
-
-VM_C_API LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
-
-// SSE traps raise these exception codes, which are defined in internal NT headers
-// but not winbase.h
-#ifndef STATUS_FLOAT_MULTIPLE_FAULTS
-#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
-#endif
-
-#ifndef STATUS_FLOAT_MULTIPLE_TRAPS
-#define STATUS_FLOAT_MULTIPLE_TRAPS 0xC00002B5
-#endif
-
-typedef HANDLE THREADHANDLE;
-
-THREADHANDLE start_thread(void *(*start_routine)(void *),void *args);
-inline static THREADHANDLE thread_id() { return GetCurrentThread(); }
-
-}
--- /dev/null
+#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);
+}
+
+}
--- /dev/null
+#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);
+}
+
+}
--- /dev/null
+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
+
+}
--- /dev/null
+namespace factor
+{
+
+#define ESP Rsp
+#define EIP Rip
+
+#define MXCSR(ctx) (ctx)->MxCsr
+
+}
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() {}
+
}
#include <wchar.h>
#endif
+#undef _WIN32_WINNT
+#define _WIN32_WINNT 0x0501 // For AddVectoredExceptionHandler
+
+#ifndef UNICODE
+#define UNICODE
+#endif
+
+#include <windows.h>
+#include <shellapi.h>
+
+#ifdef _MSC_VER
+ #undef min
+ #undef max
+#endif
+
+/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
+#define EPOCH_OFFSET 0x019db1ded53e8000LL
+
namespace factor
{
typedef wchar_t vm_char;
+typedef char symbol_char;
+typedef HANDLE THREADHANDLE;
#define STRING_LITERAL(string) L##string
#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(); }
}
#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
projects / factor.git / commitdiff