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

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-08-27 21:17:17 -05:00
parent eb4081c696 7e6f6e6a44
commit c3002ed0f0
16 changed files with 241 additions and 234 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -3,7 +3,7 @@ destructors io io.backend io.ports io.timeouts io.backend.windows
io.files.windows io.files.windows.nt io.files io.pathnames io.buffers io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
io.streams.c io.streams.null libc kernel math namespaces sequences io.streams.c io.streams.null libc kernel math namespaces sequences
threads windows windows.errors windows.kernel32 strings splitting threads windows windows.errors windows.kernel32 strings splitting
ascii system accessors locals ; ascii system accessors locals classes.struct combinators.short-circuit ;
QUALIFIED: windows.winsock QUALIFIED: windows.winsock
IN: io.backend.windows.nt IN: io.backend.windows.nt
@ -36,7 +36,7 @@ M: winnt add-completion ( win32-handle -- )
handle>> master-completion-port get-global <completion-port> drop ; handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? ) : eof? ( error -- ? )
[ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ; { [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
: twiddle-thumbs ( overlapped port -- bytes-transferred ) : twiddle-thumbs ( overlapped port -- bytes-transferred )
[ [
@ -66,9 +66,9 @@ M: winnt add-completion ( win32-handle -- )
: handle-overlapped ( us -- ? ) : handle-overlapped ( us -- ? )
wait-for-overlapped [ wait-for-overlapped [
dup [ [
[ drop GetLastError 1array ] dip resume-callback t [ drop GetLastError 1array ] dip resume-callback t
] [ 2drop f ] if ] [ drop f ] if*
] [ resume-callback t ] if ; ] [ resume-callback t ] if ;
M: win32-handle cancel-operation M: win32-handle cancel-operation

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

@ -4,7 +4,8 @@ USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.ports io.binary io.timeouts system io.buffers io.files io.ports io.binary io.timeouts system
strings kernel math namespaces sequences windows.errors strings kernel math namespaces sequences windows.errors
windows.kernel32 windows.shell32 windows.types windows.winsock windows.kernel32 windows.shell32 windows.types windows.winsock
splitting continuations math.bitwise accessors init sets assocs ; splitting continuations math.bitwise accessors init sets assocs
classes.struct classes ;
IN: io.backend.windows IN: io.backend.windows
TUPLE: win32-handle < disposable handle ; TUPLE: win32-handle < disposable handle ;
@ -50,6 +51,5 @@ HOOK: add-completion io-backend ( port -- )
} flags ; foldable } flags ; foldable
: default-security-attributes ( -- obj ) : default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object> SECURITY_ATTRIBUTES <struct>
"SECURITY_ATTRIBUTES" heap-size dup class heap-size >>nLength ;
over set-SECURITY_ATTRIBUTES-nLength ;

6
basis/io/files/info/windows/windows-tests.factor Executable file
View File

@ -0,0 +1,6 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test io.files.info.windows system kernel ;
IN: io.files.info.windows.tests
[ ] [ vm file-times 3drop ] unit-test

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

@ -5,7 +5,7 @@ io.files.windows io.files.windows.nt kernel windows.kernel32
windows.time windows accessors alien.c-types combinators windows.time windows accessors alien.c-types combinators
generalizations system alien.strings io.encodings.utf16n generalizations system alien.strings io.encodings.utf16n
sequences splitting windows.errors fry continuations destructors sequences splitting windows.errors fry continuations destructors
calendar ascii combinators.short-circuit locals ; calendar ascii combinators.short-circuit locals classes.struct ;
IN: io.files.info.windows IN: io.files.info.windows
:: round-up-to ( n multiple -- n' ) :: round-up-to ( n multiple -- n' )
@ -57,35 +57,26 @@ TUPLE: windows-file-info < file-info attributes ;
: BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info ) : BY_HANDLE_FILE_INFORMATION>file-info ( HANDLE_FILE_INFORMATION -- file-info )
[ \ windows-file-info new ] dip [ \ windows-file-info new ] dip
{ {
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ] [ dwFileAttributes>> win32-file-type >>type ]
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ] [ dwFileAttributes>> win32-file-attributes >>attributes ]
[ [
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ] [ nFileSizeLow>> ]
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size [ nFileSizeHigh>> ] bi >64bit >>size
] ]
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ] [ dwFileAttributes>> >>permissions ]
[ [ ftCreationTime>> FILETIME>timestamp >>created ]
BY_HANDLE_FILE_INFORMATION-ftCreationTime [ ftLastWriteTime>> FILETIME>timestamp >>modified ]
FILETIME>timestamp >>created [ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
] ! [ nNumberOfLinks>> ]
[
BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
FILETIME>timestamp >>modified
]
[
BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
FILETIME>timestamp >>accessed
]
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
! [ ! [
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ] ! [ nFileIndexLow>> ]
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit ! [ nFileIndexHigh>> ] bi >64bit
! ] ! ]
} cleave ; } cleave ;
: get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION ) : get-file-information ( handle -- BY_HANDLE_FILE_INFORMATION )
[ [
"BY_HANDLE_FILE_INFORMATION" <c-object> BY_HANDLE_FILE_INFORMATION <struct>
[ GetFileInformationByHandle win32-error=0/f ] keep [ GetFileInformationByHandle win32-error=0/f ] keep
] keep CloseHandle win32-error=0/f ; ] keep CloseHandle win32-error=0/f ;
@ -197,10 +188,10 @@ M: winnt file-systems ( -- array )
: file-times ( path -- timestamp timestamp timestamp ) : file-times ( path -- timestamp timestamp timestamp )
[ [
normalize-path open-existing &dispose handle>> normalize-path open-read &dispose handle>>
"FILETIME" <c-object> FILETIME <struct>
"FILETIME" <c-object> FILETIME <struct>
"FILETIME" <c-object> FILETIME <struct>
[ GetFileTime win32-error=0/f ] 3keep [ GetFileTime win32-error=0/f ] 3keep
[ FILETIME>timestamp >local-time ] tri@ [ FILETIME>timestamp >local-time ] tri@
] with-destructors ; ] with-destructors ;

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

@ -85,7 +85,7 @@ IN: io.launcher.windows.nt
: redirect-stderr ( process args -- handle ) : redirect-stderr ( process args -- handle )
over stderr>> +stdout+ eq? [ over stderr>> +stdout+ eq? [
nip nip
lpStartupInfo>> STARTUPINFO-hStdOutput lpStartupInfo>> hStdOutput>>
] [ ] [
drop drop
stderr>> stderr>>
@ -104,7 +104,7 @@ IN: io.launcher.windows.nt
STD_INPUT_HANDLE GetStdHandle or ; STD_INPUT_HANDLE GetStdHandle or ;
M: winnt fill-redirection ( process args -- ) M: winnt fill-redirection ( process args -- )
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput dup lpStartupInfo>>
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError [ [ redirect-stdout ] dip (>>hStdOutput) ]
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput [ [ redirect-stderr ] dip (>>hStdError) ]
2drop ; [ [ redirect-stdin ] dip (>>hStdInput) ] 3tri ;

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

@ -7,7 +7,7 @@ namespaces make io.launcher kernel sequences windows.errors
splitting system threads init strings combinators splitting system threads init strings combinators
io.backend accessors concurrency.flags io.files assocs io.backend accessors concurrency.flags io.files assocs
io.files.private windows destructors specialized-arrays.ushort io.files.private windows destructors specialized-arrays.ushort
specialized-arrays.alien ; specialized-arrays.alien classes classes.struct ;
IN: io.launcher.windows IN: io.launcher.windows
TUPLE: CreateProcess-args TUPLE: CreateProcess-args
@ -24,9 +24,10 @@ TUPLE: CreateProcess-args
: default-CreateProcess-args ( -- obj ) : default-CreateProcess-args ( -- obj )
CreateProcess-args new CreateProcess-args new
"STARTUPINFO" <c-object> STARTUPINFO <struct>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo dup class heap-size >>cb
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation >>lpStartupInfo
PROCESS_INFORMATION <struct> >>lpProcessInformation
TRUE >>bInheritHandles TRUE >>bInheritHandles
0 >>dwCreateFlags ; 0 >>dwCreateFlags ;
@ -108,7 +109,7 @@ TUPLE: CreateProcess-args
] when ; ] when ;
: fill-startup-info ( process args -- process args ) : fill-startup-info ( process args -- process args )
STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ; dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ;
HOOK: fill-redirection io-backend ( process args -- ) HOOK: fill-redirection io-backend ( process args -- )
@ -136,17 +137,16 @@ M: windows run-process* ( process -- handle )
] with-destructors ; ] with-destructors ;
M: windows kill-process* ( handle -- ) M: windows kill-process* ( handle -- )
PROCESS_INFORMATION-hProcess hProcess>> 255 TerminateProcess win32-error=0/f ;
255 TerminateProcess win32-error=0/f ;
: dispose-process ( process-information -- ) : dispose-process ( process-information -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed." #! with CloseHandle when they are no longer needed."
dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when* [ hProcess>> [ CloseHandle drop ] when* ]
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ; [ hThread>> [ CloseHandle drop ] when* ] bi ;
: exit-code ( process -- n ) : exit-code ( process -- n )
PROCESS_INFORMATION-hProcess hProcess>>
0 <ulong> [ GetExitCodeProcess ] keep *ulong 0 <ulong> [ GetExitCodeProcess ] keep *ulong
swap win32-error=0/f ; swap win32-error=0/f ;
@ -157,7 +157,7 @@ M: windows kill-process* ( handle -- )
M: windows wait-for-processes ( -- ? ) M: windows wait-for-processes ( -- ? )
processes get keys dup processes get keys dup
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as [ handle>> hProcess>> ] void*-array{ } map-as
[ length ] keep 0 0 [ length ] keep 0 0
WaitForMultipleObjects WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when dup HEX: ffffffff = [ win32-error ] when

25
basis/tools/deploy/shaker/shaker.factor
View File

@ -1,12 +1,13 @@
! Copyright (C) 2007, 2009 Slava Pestov. ! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io.backend io.streams.c init fry namespaces USING: arrays accessors io.backend io.streams.c init fry
math make assocs kernel parser parser.notes lexer strings.parser namespaces math make assocs kernel parser parser.notes lexer
vocabs sequences sequences.private words memory kernel.private strings.parser vocabs sequences sequences.deep sequences.private
continuations io vocabs.loader system strings sets vectors quotations words memory kernel.private continuations io vocabs.loader
byte-arrays sorting compiler.units definitions generic system strings sets vectors quotations byte-arrays sorting
generic.standard generic.single tools.deploy.config combinators compiler.units definitions generic generic.standard
classes classes.builtin slots.private grouping ; generic.single tools.deploy.config combinators classes
classes.builtin slots.private grouping ;
QUALIFIED: bootstrap.stage2 QUALIFIED: bootstrap.stage2
QUALIFIED: command-line QUALIFIED: command-line
QUALIFIED: compiler.errors QUALIFIED: compiler.errors
@ -120,6 +121,7 @@ IN: tools.deploy.shaker
"combination" "combination"
"compiled-generic-uses" "compiled-generic-uses"
"compiled-uses" "compiled-uses"
"constant"
"constraints" "constraints"
"custom-inlining" "custom-inlining"
"decision-tree" "decision-tree"
@ -145,6 +147,7 @@ IN: tools.deploy.shaker
"local-writer" "local-writer"
"local-writer?" "local-writer?"
"local?" "local?"
"low-order"
"macro" "macro"
"members" "members"
"memo-quot" "memo-quot"
@ -456,11 +459,13 @@ SYMBOL: deploy-vocab
[ "method-generic" word-prop ] bi [ "method-generic" word-prop ] bi
next-method ; next-method ;
: calls-next-method? ( method -- ? )
def>> flatten \ (call-next-method) swap memq? ;
: compute-next-methods ( -- ) : compute-next-methods ( -- )
[ standard-generic? ] instances [ [ standard-generic? ] instances [
"methods" word-prop [ "methods" word-prop values [ calls-next-method? ] filter
nip dup next-method* "next-method" set-word-prop [ dup next-method* "next-method" set-word-prop ] each
] assoc-each
] each ] each
"vocab:tools/deploy/shaker/next-methods.factor" run-file ; "vocab:tools/deploy/shaker/next-methods.factor" run-file ;

4
basis/tools/deploy/shaker/strip-libc.factor
View File

@ -8,3 +8,7 @@ IN: libc
: calloc ( size count -- newalien ) (calloc) check-ptr ; : calloc ( size count -- newalien ) (calloc) check-ptr ;
: free ( alien -- ) (free) ; : free ( alien -- ) (free) ;
FORGET: malloc-ptr
FORGET: <malloc-ptr>

4
basis/tools/deploy/test/test.factor
View File

@ -11,7 +11,9 @@ IN: tools.deploy.test
] with-directory ; ] with-directory ;
: small-enough? ( n -- ? ) : small-enough? ( n -- ? )
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ; [ "test.image" temp-file file-info size>> ]
[ cell 4 / * cpu ppc? [ 100000 + ] when ] bi*
<= ;
: run-temp-image ( -- ) : run-temp-image ( -- )
os macosx? os macosx?

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

@ -11,7 +11,7 @@ threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render math.bitwise locals command-line shuffle opengl ui.render math.bitwise locals
accessors math.rectangles math.order calendar ascii sets accessors math.rectangles math.order calendar ascii sets
io.encodings.utf16n windows.errors literals ui.pixel-formats io.encodings.utf16n windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes struct-arrays ; ui.pixel-formats.private memoize classes struct-arrays classes.struct ;
IN: ui.backend.windows IN: ui.backend.windows
SINGLETON: windows-ui-backend SINGLETON: windows-ui-backend
@ -89,26 +89,27 @@ CONSTANT: pfd-flag-map H{
[ value>> ] [ 0 ] if* ; [ value>> ] [ 0 ] if* ;
: >pfd ( attributes -- pfd ) : >pfd ( attributes -- pfd )
"PIXELFORMATDESCRIPTOR" <c-object> [ PIXELFORMATDESCRIPTOR <struct> ] dip
"PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize {
1 over set-PIXELFORMATDESCRIPTOR-nVersion [ drop PIXELFORMATDESCRIPTOR heap-size >>nSize ]
over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags [ drop 1 >>nVersion ]
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType [ >pfd-flags >>dwFlags ]
over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits [ drop PFD_TYPE_RGBA >>iPixelType ]
over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits [ color-bits attr-value >>cColorBits ]
over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits [ red-bits attr-value >>cRedBits ]
over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits [ green-bits attr-value >>cGreenBits ]
over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits [ blue-bits attr-value >>cBlueBits ]
over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits [ alpha-bits attr-value >>cAlphaBits ]
over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits [ accum-bits attr-value >>cAccumBits ]
over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits [ accum-red-bits attr-value >>cAccumRedBits ]
over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits [ accum-green-bits attr-value >>cAccumGreenBits ]
over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits [ accum-blue-bits attr-value >>cAccumBlueBits ]
over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits [ accum-alpha-bits attr-value >>cAccumAlphaBits ]
over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits [ depth-bits attr-value >>cDepthBits ]
over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers [ stencil-bits attr-value >>cStencilBits ]
PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask [ aux-buffers attr-value >>cAuxBuffers ]
nip ; [ drop PFD_MAIN_PLANE >>dwLayerMask ]
} cleave ;
: pfd-make-pixel-format ( world attributes -- pf ) : pfd-make-pixel-format ( world attributes -- pf )
[ handle>> hDC>> ] [ >pfd ] bi* [ handle>> hDC>> ] [ >pfd ] bi*
@ -116,12 +117,12 @@ CONSTANT: pfd-flag-map H{
: get-pfd ( pixel-format -- pfd ) : get-pfd ( pixel-format -- pfd )
[ world>> handle>> hDC>> ] [ handle>> ] bi [ world>> handle>> hDC>> ] [ handle>> ] bi
"PIXELFORMATDESCRIPTOR" heap-size PIXELFORMATDESCRIPTOR heap-size
"PIXELFORMATDESCRIPTOR" <c-object> PIXELFORMATDESCRIPTOR <struct>
[ DescribePixelFormat win32-error=0/f ] keep ; [ DescribePixelFormat win32-error=0/f ] keep ;
: pfd-flag? ( pfd flag -- ? ) : pfd-flag? ( pfd flag -- ? )
[ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ; [ dwFlags>> ] dip bitand c-bool> ;
: (pfd-pixel-format-attribute) ( pfd attribute -- value ) : (pfd-pixel-format-attribute) ( pfd attribute -- value )
{ {
@ -131,19 +132,19 @@ CONSTANT: pfd-flag-map H{
{ fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] } { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
{ windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] } { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
{ software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] } { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] }
{ color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] } { color-bits [ cColorBits>> ] }
{ red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] } { red-bits [ cRedBits>> ] }
{ green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] } { green-bits [ cGreenBits>> ] }
{ blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] } { blue-bits [ cBlueBits>> ] }
{ alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] } { alpha-bits [ cAlphaBits>> ] }
{ accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] } { accum-bits [ cAccumBits>> ] }
{ accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] } { accum-red-bits [ cAccumRedBits>> ] }
{ accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] } { accum-green-bits [ cAccumGreenBits>> ] }
{ accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] } { accum-blue-bits [ cAccumBlueBits>> ] }
{ accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] } { accum-alpha-bits [ cAccumAlphaBits>> ] }
{ depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] } { depth-bits [ cDepthBits>> ] }
{ stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] } { stencil-bits [ cStencilBits>> ] }
{ aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] } { aux-buffers [ cAuxBuffers>> ] }
[ 2drop f ] [ 2drop f ]
} case ; } case ;
@ -663,7 +664,7 @@ M: windows-ui-backend do-events
: set-pixel-format ( pixel-format hdc -- ) : set-pixel-format ( pixel-format hdc -- )
swap handle>> swap handle>>
"PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ; PIXELFORMATDESCRIPTOR <struct> SetPixelFormat win32-error=0/f ;
: setup-gl ( world -- ) : setup-gl ( world -- )
[ get-dc ] keep [ get-dc ] keep

165
basis/windows/kernel32/kernel32.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax kernel windows.types multiline ; USING: alien alien.syntax kernel windows.types multiline
classes.struct ;
IN: windows.kernel32 IN: windows.kernel32
CONSTANT: MAX_PATH 260 CONSTANT: MAX_PATH 260
@ -215,15 +216,15 @@ C-STRUCT: OVERLAPPED
{ "DWORD" "offset-high" } { "DWORD" "offset-high" }
{ "HANDLE" "event" } ; { "HANDLE" "event" } ;
C-STRUCT: SYSTEMTIME STRUCT: SYSTEMTIME
{ "WORD" "wYear" } { wYear WORD }
{ "WORD" "wMonth" } { wMonth WORD }
{ "WORD" "wDayOfWeek" } { wDayOfWeek WORD }
{ "WORD" "wDay" } { wDay WORD }
{ "WORD" "wHour" } { wHour WORD }
{ "WORD" "wMinute" } { wMinute WORD }
{ "WORD" "wSecond" } { wSecond WORD }
{ "WORD" "wMilliseconds" } ; { wMilliseconds WORD } ;
C-STRUCT: TIME_ZONE_INFORMATION C-STRUCT: TIME_ZONE_INFORMATION
{ "LONG" "Bias" } { "LONG" "Bias" }
@ -234,74 +235,74 @@ C-STRUCT: TIME_ZONE_INFORMATION
{ "SYSTEMTIME" "DaylightDate" } { "SYSTEMTIME" "DaylightDate" }
{ "LONG" "DaylightBias" } ; { "LONG" "DaylightBias" } ;
C-STRUCT: FILETIME STRUCT: FILETIME
{ "DWORD" "dwLowDateTime" } { dwLowDateTime DWORD }
{ "DWORD" "dwHighDateTime" } ; { dwHighDateTime DWORD } ;
C-STRUCT: STARTUPINFO STRUCT: STARTUPINFO
{ "DWORD" "cb" } { cb DWORD }
{ "LPTSTR" "lpReserved" } { lpReserved LPTSTR }
{ "LPTSTR" "lpDesktop" } { lpDesktop LPTSTR }
{ "LPTSTR" "lpTitle" } { lpTitle LPTSTR }
{ "DWORD" "dwX" } { dwX DWORD }
{ "DWORD" "dwY" } { dwY DWORD }
{ "DWORD" "dwXSize" } { dwXSize DWORD }
{ "DWORD" "dwYSize" } { dwYSize DWORD }
{ "DWORD" "dwXCountChars" } { dwXCountChars DWORD }
{ "DWORD" "dwYCountChars" } { dwYCountChars DWORD }
{ "DWORD" "dwFillAttribute" } { dwFillAttribute DWORD }
{ "DWORD" "dwFlags" } { dwFlags DWORD }
{ "WORD" "wShowWindow" } { wShowWindow WORD }
{ "WORD" "cbReserved2" } { cbReserved2 WORD }
{ "LPBYTE" "lpReserved2" } { lpReserved2 LPBYTE }
{ "HANDLE" "hStdInput" } { hStdInput HANDLE }
{ "HANDLE" "hStdOutput" } { hStdOutput HANDLE }
{ "HANDLE" "hStdError" } ; { hStdError HANDLE } ;
TYPEDEF: void* LPSTARTUPINFO TYPEDEF: void* LPSTARTUPINFO
C-STRUCT: PROCESS_INFORMATION STRUCT: PROCESS_INFORMATION
{ "HANDLE" "hProcess" } { hProcess HANDLE }
{ "HANDLE" "hThread" } { hThread HANDLE }
{ "DWORD" "dwProcessId" } { dwProcessId DWORD }
{ "DWORD" "dwThreadId" } ; { dwThreadId DWORD } ;
C-STRUCT: SYSTEM_INFO STRUCT: SYSTEM_INFO
{ "DWORD" "dwOemId" } { dwOemId DWORD }
{ "DWORD" "dwPageSize" } { dwPageSize DWORD }
{ "LPVOID" "lpMinimumApplicationAddress" } { lpMinimumApplicationAddress LPVOID }
{ "LPVOID" "lpMaximumApplicationAddress" } { lpMaximumApplicationAddress LPVOID }
{ "DWORD_PTR" "dwActiveProcessorMask" } { dwActiveProcessorMask DWORD_PTR }
{ "DWORD" "dwNumberOfProcessors" } { dwNumberOfProcessors DWORD }
{ "DWORD" "dwProcessorType" } { dwProcessorType DWORD }
{ "DWORD" "dwAllocationGranularity" } { dwAllocationGranularity DWORD }
{ "WORD" "wProcessorLevel" } { wProcessorLevel WORD }
{ "WORD" "wProcessorRevision" } ; { wProcessorRevision WORD } ;
TYPEDEF: void* LPSYSTEM_INFO TYPEDEF: void* LPSYSTEM_INFO
C-STRUCT: MEMORYSTATUS STRUCT: MEMORYSTATUS
{ "DWORD" "dwLength" } { dwLength DWORD }
{ "DWORD" "dwMemoryLoad" } { dwMemoryLoad DWORD }
{ "SIZE_T" "dwTotalPhys" } { dwTotalPhys SIZE_T }
{ "SIZE_T" "dwAvailPhys" } { dwAvailPhys SIZE_T }
{ "SIZE_T" "dwTotalPageFile" } { dwTotalPageFile SIZE_T }
{ "SIZE_T" "dwAvailPageFile" } { dwAvailPageFile SIZE_T }
{ "SIZE_T" "dwTotalVirtual" } { dwTotalVirtual SIZE_T }
{ "SIZE_T" "dwAvailVirtual" } ; { dwAvailVirtual SIZE_T } ;
TYPEDEF: void* LPMEMORYSTATUS TYPEDEF: void* LPMEMORYSTATUS
C-STRUCT: MEMORYSTATUSEX STRUCT: MEMORYSTATUSEX
{ "DWORD" "dwLength" } { dwLength DWORD }
{ "DWORD" "dwMemoryLoad" } { dwMemoryLoad DWORD }
{ "DWORDLONG" "ullTotalPhys" } { ullTotalPhys DWORDLONG }
{ "DWORDLONG" "ullAvailPhys" } { ullAvailPhys DWORDLONG }
{ "DWORDLONG" "ullTotalPageFile" } { ullTotalPageFile DWORDLONG }
{ "DWORDLONG" "ullAvailPageFile" } { ullAvailPageFile DWORDLONG }
{ "DWORDLONG" "ullTotalVirtual" } { ullTotalVirtual DWORDLONG }
{ "DWORDLONG" "ullAvailVirtual" } { ullAvailVirtual DWORDLONG }
{ "DWORDLONG" "ullAvailExtendedVirtual" } ; { ullAvailExtendedVirtual DWORDLONG } ;
TYPEDEF: void* LPMEMORYSTATUSEX TYPEDEF: void* LPMEMORYSTATUSEX
@ -707,17 +708,17 @@ C-STRUCT: WIN32_FIND_DATA
{ { "TCHAR" 260 } "cFileName" } { { "TCHAR" 260 } "cFileName" }
{ { "TCHAR" 14 } "cAlternateFileName" } ; { { "TCHAR" 14 } "cAlternateFileName" } ;
C-STRUCT: BY_HANDLE_FILE_INFORMATION STRUCT: BY_HANDLE_FILE_INFORMATION
{ "DWORD" "dwFileAttributes" } { dwFileAttributes DWORD }
{ "FILETIME" "ftCreationTime" } { ftCreationTime FILETIME }
{ "FILETIME" "ftLastAccessTime" } { ftLastAccessTime FILETIME }
{ "FILETIME" "ftLastWriteTime" } { ftLastWriteTime FILETIME }
{ "DWORD" "dwVolumeSerialNumber" } { dwVolumeSerialNumber DWORD }
{ "DWORD" "nFileSizeHigh" } { nFileSizeHigh DWORD }
{ "DWORD" "nFileSizeLow" } { nFileSizeLow DWORD }
{ "DWORD" "nNumberOfLinks" } { nNumberOfLinks DWORD }
{ "DWORD" "nFileIndexHigh" } { nFileIndexHigh DWORD }
{ "DWORD" "nFileIndexLow" } ; { nFileIndexLow DWORD } ;
TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA TYPEDEF: WIN32_FIND_DATA* PWIN32_FIND_DATA
TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA TYPEDEF: WIN32_FIND_DATA* LPWIN32_FIND_DATA
@ -737,10 +738,10 @@ TYPEDEF: PFILETIME LPFILETIME
TYPEDEF: int GET_FILEEX_INFO_LEVELS TYPEDEF: int GET_FILEEX_INFO_LEVELS
C-STRUCT: SECURITY_ATTRIBUTES STRUCT: SECURITY_ATTRIBUTES
{ "DWORD" "nLength" } { nLength DWORD }
{ "LPVOID" "lpSecurityDescriptor" } { lpSecurityDescriptor LPVOID }
{ "BOOL" "bInheritHandle" } ; { bInheritHandle BOOL } ;
CONSTANT: HANDLE_FLAG_INHERIT 1 CONSTANT: HANDLE_FLAG_INHERIT 1
CONSTANT: HANDLE_FLAG_PROTECT_FROM_CLOSE 2 CONSTANT: HANDLE_FLAG_PROTECT_FROM_CLOSE 2

16
basis/windows/time/time.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types kernel math windows.errors USING: alien alien.c-types kernel math windows.errors
windows.kernel32 namespaces calendar math.bitwise ; windows.kernel32 namespaces calendar math.bitwise accessors
classes.struct ;
IN: windows.time IN: windows.time
: >64bit ( lo hi -- n ) : >64bit ( lo hi -- n )
@ -11,15 +12,13 @@ IN: windows.time
1601 1 1 0 0 0 instant <timestamp> ; 1601 1 1 0 0 0 instant <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n ) : FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ] [ dwLowDateTime>> ] [ dwHighDateTime>> ] bi >64bit ;
[ FILETIME-dwHighDateTime ]
bi >64bit ;
: windows-time>timestamp ( n -- timestamp ) : windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap time+ ; 10000000 /i seconds windows-1601 swap time+ ;
: windows-time ( -- n ) : windows-time ( -- n )
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep FILETIME <struct> [ GetSystemTimeAsFileTime ] keep
FILETIME>windows-time ; FILETIME>windows-time ;
: timestamp>windows-time ( timestamp -- n ) : timestamp>windows-time ( timestamp -- n )
@ -27,11 +26,8 @@ IN: windows.time
>gmt windows-1601 (time-) 10000000 * >integer ; >gmt windows-1601 (time-) 10000000 * >integer ;
: windows-time>FILETIME ( n -- FILETIME ) : windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object> [ FILETIME <struct> ] dip
[ [ 32 bits >>dwLowDateTime ] [ -32 shift >>dwHighDateTime ] bi ;
[ [ 32 bits ] dip set-FILETIME-dwLowDateTime ]
[ [ -32 shift ] dip set-FILETIME-dwHighDateTime ] 2bi
] keep ;
: timestamp>FILETIME ( timestamp -- FILETIME/f ) : timestamp>FILETIME ( timestamp -- FILETIME/f )
dup [ >gmt timestamp>windows-time windows-time>FILETIME ] when ; dup [ >gmt timestamp>windows-time windows-time>FILETIME ] when ;

56
basis/windows/types/types.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax namespaces kernel words USING: alien alien.c-types alien.syntax namespaces kernel words
sequences math math.bitwise math.vectors colors sequences math math.bitwise math.vectors colors
io.encodings.utf16n ; io.encodings.utf16n classes.struct ;
IN: windows.types IN: windows.types
TYPEDEF: char CHAR TYPEDEF: char CHAR
@ -301,33 +301,33 @@ C-STRUCT: MSG
TYPEDEF: MSG* LPMSG TYPEDEF: MSG* LPMSG
C-STRUCT: PIXELFORMATDESCRIPTOR STRUCT: PIXELFORMATDESCRIPTOR
{ "WORD" "nSize" } { nSize WORD }
{ "WORD" "nVersion" } { nVersion WORD }
{ "DWORD" "dwFlags" } { dwFlags DWORD }
{ "BYTE" "iPixelType" } { iPixelType BYTE }
{ "BYTE" "cColorBits" } { cColorBits BYTE }
{ "BYTE" "cRedBits" } { cRedBits BYTE }
{ "BYTE" "cRedShift" } { cRedShift BYTE }
{ "BYTE" "cGreenBits" } { cGreenBits BYTE }
{ "BYTE" "cGreenShift" } { cGreenShift BYTE }
{ "BYTE" "cBlueBits" } { cBlueBits BYTE }
{ "BYTE" "cBlueShift" } { cBlueShift BYTE }
{ "BYTE" "cAlphaBits" } { cAlphaBits BYTE }
{ "BYTE" "cAlphaShift" } { cAlphaShift BYTE }
{ "BYTE" "cAccumBits" } { cAccumBits BYTE }
{ "BYTE" "cAccumRedBits" } { cAccumRedBits BYTE }
{ "BYTE" "cAccumGreenBits" } { cAccumGreenBits BYTE }
{ "BYTE" "cAccumBlueBits" } { cAccumBlueBits BYTE }
{ "BYTE" "cAccumAlphaBits" } { cAccumAlphaBits BYTE }
{ "BYTE" "cDepthBits" } { cDepthBits BYTE }
{ "BYTE" "cStencilBits" } { cStencilBits BYTE }
{ "BYTE" "cAuxBuffers" } { cAuxBuffers BYTE }
{ "BYTE" "iLayerType" } { iLayerType BYTE }
{ "BYTE" "bReserved" } { bReserved BYTE }
{ "DWORD" "dwLayerMask" } { dwLayerMask DWORD }
{ "DWORD" "dwVisibleMask" } { dwVisibleMask DWORD }
{ "DWORD" "dwDamageMask" } ; { dwDamageMask DWORD } ;
C-STRUCT: RECT C-STRUCT: RECT
{ "LONG" "left" } { "LONG" "left" }

2
basis/windows/user32/user32.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2006 Doug Coleman. ! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax parser namespaces kernel math USING: alien alien.syntax parser namespaces kernel math
windows.types generalizations math.bitwise ; windows.types generalizations math.bitwise classes.struct ;
IN: windows.user32 IN: windows.user32
! HKL for ActivateKeyboardLayout ! HKL for ActivateKeyboardLayout

21
extra/system-info/windows/nt/nt.factor
View File

@ -3,37 +3,38 @@
USING: alien alien.c-types alien.strings USING: alien alien.c-types alien.strings
kernel libc math namespaces system-info.backend kernel libc math namespaces system-info.backend
system-info.windows windows windows.advapi32 system-info.windows windows windows.advapi32
windows.kernel32 system byte-arrays windows.errors ; windows.kernel32 system byte-arrays windows.errors
classes classes.struct ;
IN: system-info.windows.nt IN: system-info.windows.nt
M: winnt cpus ( -- n ) M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ; system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX ) : memory-status ( -- MEMORYSTATUSEX )
"MEMORYSTATUSEX" <c-object> "MEMORYSTATUSEX" <struct>
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength dup class heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ; dup GlobalMemoryStatusEx win32-error=0/f ;
M: winnt memory-load ( -- n ) M: winnt memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ; memory-status dwMemoryLoad>> ;
M: winnt physical-mem ( -- n ) M: winnt physical-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPhys ; memory-status ullTotalPhys>> ;
M: winnt available-mem ( -- n ) M: winnt available-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPhys ; memory-status ullAvailPhys>> ;
M: winnt total-page-file ( -- n ) M: winnt total-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPageFile ; memory-status ullTotalPageFile>> ;
M: winnt available-page-file ( -- n ) M: winnt available-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPageFile ; memory-status ullAvailPageFile>> ;
M: winnt total-virtual-mem ( -- n ) M: winnt total-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalVirtual ; memory-status ullTotalVirtual>> ;
M: winnt available-virtual-mem ( -- n ) M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ; memory-status ullAvailVirtual>> ;
: computer-name ( -- string ) : computer-name ( -- string )
MAX_COMPUTERNAME_LENGTH 1 + MAX_COMPUTERNAME_LENGTH 1 +

8
extra/system-info/windows/windows.factor
View File

@ -7,18 +7,18 @@ system alien.strings windows.errors ;
IN: system-info.windows IN: system-info.windows
: system-info ( -- SYSTEM_INFO ) : system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ; SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
: page-size ( -- n ) : page-size ( -- n )
system-info SYSTEM_INFO-dwPageSize ; system-info dwPageSize>> ;
! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664) ! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
: processor-type ( -- n ) : processor-type ( -- n )
system-info SYSTEM_INFO-dwProcessorType ; system-info dwProcessorType>> ;
! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk ! 0 = x86, 6 = Intel Itanium, 9 = x64 (AMD or Intel), 10 = WOW64, 0xffff = Unk
: processor-architecture ( -- n ) : processor-architecture ( -- n )
system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ; system-info dwOemId>> HEX: ffff0000 bitand ;
: os-version ( -- os-version ) : os-version ( -- os-version )
"OSVERSIONINFO" <c-object> "OSVERSIONINFO" <c-object>