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

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

db4
Sascha Matzke 2009-08-28 07:07:14 +02:00
parent 5665deaf8b b8978446d9
commit 8b410e373b
35 changed files with 311 additions and 285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/alien/arrays/arrays.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.accessors alien.structs
arrays words sequences math kernel namespaces fry libc cpu.architecture
io.encodings.utf8 ;
io.encodings.utf8 accessors ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -13,7 +13,10 @@ M: array c-type-class drop object ;
M: array c-type-boxed-class drop object ;
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
: array-length ( seq -- n )
[ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
M: array c-type-align first c-type-align ;
@ -31,7 +34,7 @@ M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot
unclip
[ product ]
[ array-length ]
[ [ require-c-type-arrays ] keep ] bi*
[ <c-type-direct-array> ] 2curry ;

2
basis/alien/c-types/c-types-tests.factor
View File

@ -4,7 +4,7 @@ IN: alien.c-types.tests
CONSTANT: xyz 123
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
[ 492 ] [ { "int" xyz } heap-size ] unit-test
[ -1 ] [ -1 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] unit-test

11
basis/alien/c-types/c-types.factor
View File

@ -326,17 +326,6 @@ M: long-long-type box-return ( type -- )
[ define-out ]
tri ;
: expand-constants ( c-type -- c-type' )
dup array? [
unclip [
[
dup word? [
def>> call( -- object )
] when
] map
] dip prefix
] when ;
: malloc-file-contents ( path -- alien len )
binary file-contents [ malloc-byte-array ] [ length ] bi ;

6
basis/alien/structs/fields/fields.factor
View File

@ -7,16 +7,16 @@ IN: alien.structs.fields
TUPLE: field-spec name offset type reader writer ;
: reader-word ( class name vocab -- word )
[ "-" glue ] dip create ;
[ "-" glue ] dip create dup make-deprecated ;
: writer-word ( class name vocab -- word )
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
[ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
: <field-spec> ( struct-name vocab type field-name -- spec )
field-spec new
0 >>offset
swap >>name
swap expand-constants >>type
swap >>type
3dup name>> swap reader-word >>reader
3dup name>> swap writer-word >>writer
2nip ;

2
basis/alien/structs/structs-docs.factor
View File

@ -30,4 +30,4 @@ ARTICLE: "c-unions" "C unions"
{ $subsection POSTPONE: C-UNION: }
"C union objects can be allocated by calling " { $link <c-object> } " or " { $link malloc-object } "."
$nl
"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;

5
basis/alien/structs/structs.factor
View File

@ -55,12 +55,11 @@ M: struct-type stack-size
[ struct-offsets ] keep
[ [ type>> ] map compute-struct-align ] keep
[ struct-type (define-struct) ] keep
[ define-field ] each ;
[ define-field ] each ; deprecated
: define-union ( name members -- )
[ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f struct-type (define-struct) ;
compute-struct-align f struct-type (define-struct) ; deprecated
: offset-of ( field struct -- offset )
c-types get at fields>>

4
basis/alien/syntax/syntax-docs.factor
View File

@ -1,6 +1,6 @@
IN: alien.syntax
USING: alien alien.c-types alien.parser alien.structs
help.markup help.syntax ;
classes.struct help.markup help.syntax ;
HELP: DLL"
{ $syntax "DLL\" path\"" }
@ -55,12 +55,14 @@ HELP: TYPEDEF:
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
HELP: C-STRUCT:
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
{ $syntax "C-STRUCT: name pairs... ;" }
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
{ $description "Defines a C struct layout and accessor words." }
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
HELP: C-UNION:
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
{ $syntax "C-UNION: name members... ;" }
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
{ $description "Defines a new C type sized to fit its largest member." }

4
basis/alien/syntax/syntax.factor
View File

@ -22,10 +22,10 @@ SYNTAX: TYPEDEF:
scan scan typedef ;
SYNTAX: C-STRUCT:
scan current-vocab parse-definition define-struct ;
scan current-vocab parse-definition define-struct ; deprecated
SYNTAX: C-UNION:
scan parse-definition define-union ;
scan parse-definition define-union ; deprecated
SYNTAX: C-ENUM:
";" parse-tokens

4
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -1,7 +1,7 @@
! (c)Joe Groff bsd license
USING: accessors assocs classes classes.struct combinators
kernel math prettyprint.backend prettyprint.custom
prettyprint.sections see.private sequences words ;
prettyprint.sections see.private sequences strings words ;
IN: classes.struct.prettyprint
<PRIVATE
@ -18,7 +18,7 @@ IN: classes.struct.prettyprint
<flow \ { pprint-word
{
[ name>> text ]
[ c-type>> text ]
[ c-type>> dup string? [ text ] [ pprint* ] if ]
[ read-only>> [ \ read-only pprint-word ] when ]
[ initial>> [ \ initial: pprint-word pprint* ] when* ]
} cleave

2
basis/classes/struct/struct-tests.factor
View File

@ -187,7 +187,7 @@ STRUCT: struct-test-array-slots
] unit-test
STRUCT: struct-test-optimization
{ x int[3] } { y int } ;
{ x { "int" 3 } } { y int } ;
[ t ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [

5
basis/classes/struct/struct.factor
View File

@ -232,10 +232,13 @@ ERROR: invalid-struct-slot token ;
c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
: scan-c-type ( -- c-type )
scan dup "{" = [ drop \ } parse-until >array ] when ;
: parse-struct-slot ( -- slot )
struct-slot-spec new
scan >>name
scan [ >>c-type ] [ struct-slot-class >>class ] bi
scan-c-type [ >>c-type ] [ struct-slot-class >>class ] bi
\ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
: parse-struct-slots ( slots -- slots' more? )

4
basis/compiler/tree/propagation/propagation-tests.factor
View File

@ -780,6 +780,10 @@ M: f whatever2 ; inline
[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test
SYMBOL: not-an-assoc
[ f ] [ [ not-an-assoc at ] { at* } inlined? ] unit-test
[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test

14
basis/compiler/tree/propagation/transforms/transforms.factor
View File

@ -207,12 +207,14 @@ CONSTANT: lookup-table-at-max 256
] ;
: at-quot ( assoc -- quot )
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
lookup-table-quot
] if
dup assoc? [
dup lookup-table-at? [
dup fast-lookup-table-at? [
fast-lookup-table-quot
] [
lookup-table-quot
] if
] [ drop f ] if
] [ drop f ] if ;
\ at* [ at-quot ] 1 define-partial-eval

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.streams.c io.streams.null libc kernel math namespaces sequences
threads windows windows.errors windows.kernel32 strings splitting
ascii system accessors locals ;
ascii system accessors locals classes.struct combinators.short-circuit ;
QUALIFIED: windows.winsock
IN: io.backend.windows.nt
@ -36,7 +36,7 @@ M: winnt add-completion ( win32-handle -- )
handle>> master-completion-port get-global <completion-port> drop ;
: eof? ( error -- ? )
[ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] bi or ;
{ [ ERROR_HANDLE_EOF = ] [ ERROR_BROKEN_PIPE = ] } 1|| ;
: twiddle-thumbs ( overlapped port -- bytes-transferred )
[
@ -66,9 +66,9 @@ M: winnt add-completion ( win32-handle -- )
: handle-overlapped ( us -- ? )
wait-for-overlapped [
dup [
[
[ drop GetLastError 1array ] dip resume-callback t
] [ 2drop f ] if
] [ drop f ] if*
] [ resume-callback t ] if ;
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
strings kernel math namespaces sequences windows.errors
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
TUPLE: win32-handle < disposable handle ;
@ -50,6 +51,5 @@ HOOK: add-completion io-backend ( port -- )
} flags ; foldable
: default-security-attributes ( -- obj )
"SECURITY_ATTRIBUTES" <c-object>
"SECURITY_ATTRIBUTES" heap-size
over set-SECURITY_ATTRIBUTES-nLength ;
SECURITY_ATTRIBUTES <struct>
dup class heap-size >>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
generalizations system alien.strings io.encodings.utf16n
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
:: 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 )
[ \ windows-file-info new ] dip
{
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-type >>type ]
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes win32-file-attributes >>attributes ]
[ dwFileAttributes>> win32-file-type >>type ]
[ dwFileAttributes>> win32-file-attributes >>attributes ]
[
[ BY_HANDLE_FILE_INFORMATION-nFileSizeLow ]
[ BY_HANDLE_FILE_INFORMATION-nFileSizeHigh ] bi >64bit >>size
[ nFileSizeLow>> ]
[ nFileSizeHigh>> ] bi >64bit >>size
]
[ BY_HANDLE_FILE_INFORMATION-dwFileAttributes >>permissions ]
[
BY_HANDLE_FILE_INFORMATION-ftCreationTime
FILETIME>timestamp >>created
]
[
BY_HANDLE_FILE_INFORMATION-ftLastWriteTime
FILETIME>timestamp >>modified
]
[
BY_HANDLE_FILE_INFORMATION-ftLastAccessTime
FILETIME>timestamp >>accessed
]
! [ BY_HANDLE_FILE_INFORMATION-nNumberOfLinks ]
[ dwFileAttributes>> >>permissions ]
[ ftCreationTime>> FILETIME>timestamp >>created ]
[ ftLastWriteTime>> FILETIME>timestamp >>modified ]
[ ftLastAccessTime>> FILETIME>timestamp >>accessed ]
! [ nNumberOfLinks>> ]
! [
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexLow ]
! [ BY_HANDLE_FILE_INFORMATION-nFileIndexHigh ] bi >64bit
! [ nFileIndexLow>> ]
! [ nFileIndexHigh>> ] bi >64bit
! ]
} cleave ;
: 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
] keep CloseHandle win32-error=0/f ;
@ -197,10 +188,10 @@ M: winnt file-systems ( -- array )
: file-times ( path -- timestamp timestamp timestamp )
[
normalize-path open-existing &dispose handle>>
"FILETIME" <c-object>
"FILETIME" <c-object>
"FILETIME" <c-object>
normalize-path open-read &dispose handle>>
FILETIME <struct>
FILETIME <struct>
FILETIME <struct>
[ GetFileTime win32-error=0/f ] 3keep
[ FILETIME>timestamp >local-time ] tri@
] 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 )
over stderr>> +stdout+ eq? [
nip
lpStartupInfo>> STARTUPINFO-hStdOutput
lpStartupInfo>> hStdOutput>>
] [
drop
stderr>>
@ -104,7 +104,7 @@ IN: io.launcher.windows.nt
STD_INPUT_HANDLE GetStdHandle or ;
M: winnt fill-redirection ( process args -- )
[ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
[ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
[ 2dup redirect-stdin ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
2drop ;
dup lpStartupInfo>>
[ [ redirect-stdout ] dip (>>hStdOutput) ]
[ [ redirect-stderr ] dip (>>hStdError) ]
[ [ 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
io.backend accessors concurrency.flags io.files assocs
io.files.private windows destructors specialized-arrays.ushort
specialized-arrays.alien ;
specialized-arrays.alien classes classes.struct ;
IN: io.launcher.windows
TUPLE: CreateProcess-args
@ -24,9 +24,10 @@ TUPLE: CreateProcess-args
: default-CreateProcess-args ( -- obj )
CreateProcess-args new
"STARTUPINFO" <c-object>
"STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
"PROCESS_INFORMATION" <c-object> >>lpProcessInformation
STARTUPINFO <struct>
dup class heap-size >>cb
>>lpStartupInfo
PROCESS_INFORMATION <struct> >>lpProcessInformation
TRUE >>bInheritHandles
0 >>dwCreateFlags ;
@ -108,7 +109,7 @@ TUPLE: CreateProcess-args
] when ;
: 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 -- )
@ -136,17 +137,16 @@ M: windows run-process* ( process -- handle )
] with-destructors ;
M: windows kill-process* ( handle -- )
PROCESS_INFORMATION-hProcess
255 TerminateProcess win32-error=0/f ;
hProcess>> 255 TerminateProcess win32-error=0/f ;
: dispose-process ( process-information -- )
#! From MSDN: "Handles in PROCESS_INFORMATION must be closed
#! with CloseHandle when they are no longer needed."
dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
[ hProcess>> [ CloseHandle drop ] when* ]
[ hThread>> [ CloseHandle drop ] when* ] bi ;
: exit-code ( process -- n )
PROCESS_INFORMATION-hProcess
hProcess>>
0 <ulong> [ GetExitCodeProcess ] keep *ulong
swap win32-error=0/f ;
@ -157,7 +157,7 @@ M: windows kill-process* ( handle -- )
M: windows wait-for-processes ( -- ? )
processes get keys dup
[ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as
[ handle>> hProcess>> ] void*-array{ } map-as
[ length ] keep 0 0
WaitForMultipleObjects
dup HEX: ffffffff = [ win32-error ] when

9
basis/stack-checker/alien/alien.factor
View File

@ -14,9 +14,6 @@ TUPLE: alien-indirect-params < alien-node-params ;
TUPLE: alien-callback-params < alien-node-params quot xt ;
: pop-parameters ( -- seq )
pop-literal nip [ expand-constants ] map ;
: param-prep-quot ( node -- quot )
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
@ -31,7 +28,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
: infer-alien-invoke ( -- )
alien-invoke-params new
! Compile-time parameters
pop-parameters >>parameters
pop-literal nip >>parameters
pop-literal nip >>function
pop-literal nip >>library
pop-literal nip >>return
@ -50,7 +47,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
alien-indirect-params new
! Compile-time parameters
pop-literal nip >>abi
pop-parameters >>parameters
pop-literal nip >>parameters
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup param-prep-quot [ dip ] curry infer-quot-here
@ -71,7 +68,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
alien-callback-params new
pop-literal nip >>quot
pop-literal nip >>abi
pop-parameters >>parameters
pop-literal nip >>parameters
pop-literal nip >>return
gensym >>xt
dup callback-bottom

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

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

2
basis/ui/backend/cocoa/tools/tools.factor
View File

@ -30,7 +30,7 @@ CLASS: {
}
{ "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" }
[ [ 3drop ] dip 0 = [ show-listener ] when 0 ]
[ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
}
{ "factorListener:" "id" { "id" "SEL" "id" }

2
basis/ui/backend/cocoa/views/views.factor
View File

@ -149,7 +149,7 @@ CLASS: {
! Rendering
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
[ 2drop window relayout-1 ]
[ 2drop window relayout-1 yield ]
}
! Events

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

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

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

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

@ -1,7 +1,8 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
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
: >64bit ( lo hi -- n )
@ -11,15 +12,13 @@ IN: windows.time
1601 1 1 0 0 0 instant <timestamp> ;
: FILETIME>windows-time ( FILETIME -- n )
[ FILETIME-dwLowDateTime ]
[ FILETIME-dwHighDateTime ]
bi >64bit ;
[ dwLowDateTime>> ] [ dwHighDateTime>> ] bi >64bit ;
: windows-time>timestamp ( n -- timestamp )
10000000 /i seconds windows-1601 swap time+ ;
: windows-time ( -- n )
"FILETIME" <c-object> [ GetSystemTimeAsFileTime ] keep
FILETIME <struct> [ GetSystemTimeAsFileTime ] keep
FILETIME>windows-time ;
: timestamp>windows-time ( timestamp -- n )
@ -27,11 +26,8 @@ IN: windows.time
>gmt windows-1601 (time-) 10000000 * >integer ;
: windows-time>FILETIME ( n -- FILETIME )
"FILETIME" <c-object>
[
[ [ 32 bits ] dip set-FILETIME-dwLowDateTime ]
[ [ -32 shift ] dip set-FILETIME-dwHighDateTime ] 2bi
] keep ;
[ FILETIME <struct> ] dip
[ 32 bits >>dwLowDateTime ] [ -32 shift >>dwHighDateTime ] bi ;
: timestamp>FILETIME ( timestamp -- FILETIME/f )
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.
USING: alien alien.c-types alien.syntax namespaces kernel words
sequences math math.bitwise math.vectors colors
io.encodings.utf16n ;
io.encodings.utf16n classes.struct ;
IN: windows.types
TYPEDEF: char CHAR
@ -301,33 +301,33 @@ C-STRUCT: MSG
TYPEDEF: MSG* LPMSG
C-STRUCT: PIXELFORMATDESCRIPTOR
{ "WORD" "nSize" }
{ "WORD" "nVersion" }
{ "DWORD" "dwFlags" }
{ "BYTE" "iPixelType" }
{ "BYTE" "cColorBits" }
{ "BYTE" "cRedBits" }
{ "BYTE" "cRedShift" }
{ "BYTE" "cGreenBits" }
{ "BYTE" "cGreenShift" }
{ "BYTE" "cBlueBits" }
{ "BYTE" "cBlueShift" }
{ "BYTE" "cAlphaBits" }
{ "BYTE" "cAlphaShift" }
{ "BYTE" "cAccumBits" }
{ "BYTE" "cAccumRedBits" }
{ "BYTE" "cAccumGreenBits" }
{ "BYTE" "cAccumBlueBits" }
{ "BYTE" "cAccumAlphaBits" }
{ "BYTE" "cDepthBits" }
{ "BYTE" "cStencilBits" }
{ "BYTE" "cAuxBuffers" }
{ "BYTE" "iLayerType" }
{ "BYTE" "bReserved" }
{ "DWORD" "dwLayerMask" }
{ "DWORD" "dwVisibleMask" }
{ "DWORD" "dwDamageMask" } ;
STRUCT: PIXELFORMATDESCRIPTOR
{ nSize WORD }
{ nVersion WORD }
{ dwFlags DWORD }
{ iPixelType BYTE }
{ cColorBits BYTE }
{ cRedBits BYTE }
{ cRedShift BYTE }
{ cGreenBits BYTE }
{ cGreenShift BYTE }
{ cBlueBits BYTE }
{ cBlueShift BYTE }
{ cAlphaBits BYTE }
{ cAlphaShift BYTE }
{ cAccumBits BYTE }
{ cAccumRedBits BYTE }
{ cAccumGreenBits BYTE }
{ cAccumBlueBits BYTE }
{ cAccumAlphaBits BYTE }
{ cDepthBits BYTE }
{ cStencilBits BYTE }
{ cAuxBuffers BYTE }
{ iLayerType BYTE }
{ bReserved BYTE }
{ dwLayerMask DWORD }
{ dwVisibleMask DWORD }
{ dwDamageMask DWORD } ;
C-STRUCT: RECT
{ "LONG" "left" }

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

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

6
core/words/words-docs.factor
View File

@ -219,7 +219,11 @@ HELP: <word> ( name vocab -- word )
HELP: gensym
{ $values { "word" word } }
{ $description "Creates an uninterned word that is not equal to any other word in the system." }
{ $examples { $unchecked-example "gensym ." "G:260561" } }
{ $examples { $example "USING: prettyprint words ;"
"gensym ."
"( gensym )"
}
}
{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
HELP: bootstrapping?

8
extra/bloom-filters/bloom-filters-tests.factor
View File

@ -66,7 +66,8 @@ IN: bloom-filters.tests
[ t ] [ 2000 iota
full-bloom-filter
[ bloom-filter-member? ] curry map
[ ] all? ] unit-test
[ ] all?
] unit-test
! We shouldn't have more than 0.01 false-positive rate.
[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
@ -74,5 +75,6 @@ IN: bloom-filters.tests
[ bloom-filter-member? ] curry map
[ ] filter
! TODO: This should be 10, but the false positive rate is currently very
! high. It shouldn't be much more than this.
length 150 <= ] unit-test
! high. 300 is large enough not to prevent builds from succeeding.
length 300 <=
] unit-test

22
extra/images/viewer/viewer.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ui.images ;
USING: accessors images images.loader io.pathnames kernel
models namespaces opengl opengl.gl opengl.textures sequences
strings ui ui.gadgets ui.gadgets.panes ui.images ui.render
constructors ;
IN: images.viewer
TUPLE: image-gadget < gadget image texture ;
@ -13,7 +14,20 @@ M: image-gadget pref-dim* image>> dim>> ;
dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- )
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture ;
dup image>> [
[ dim>> ] [ image-gadget-texture ] bi draw-scaled-texture
] [
drop
] if ;
TUPLE: image-control < image-gadget ;
CONSTRUCTOR: image-control ( model -- image-control ) ;
M: image-control pref-dim* image>> [ dim>> ] [ { 640 480 } ] if* ;
M: image-control model-changed
swap value>> >>image relayout ;
! Todo: delete texture on ungraft

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

@ -3,37 +3,38 @@
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 ;
windows.kernel32 system byte-arrays windows.errors
classes classes.struct ;
IN: system-info.windows.nt
M: winnt cpus ( -- n )
system-info SYSTEM_INFO-dwNumberOfProcessors ;
: memory-status ( -- MEMORYSTATUSEX )
"MEMORYSTATUSEX" <c-object>
"MEMORYSTATUSEX" heap-size over set-MEMORYSTATUSEX-dwLength
"MEMORYSTATUSEX" <struct>
dup class heap-size >>dwLength
dup GlobalMemoryStatusEx win32-error=0/f ;
M: winnt memory-load ( -- n )
memory-status MEMORYSTATUSEX-dwMemoryLoad ;
memory-status dwMemoryLoad>> ;
M: winnt physical-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPhys ;
memory-status ullTotalPhys>> ;
M: winnt available-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPhys ;
memory-status ullAvailPhys>> ;
M: winnt total-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullTotalPageFile ;
memory-status ullTotalPageFile>> ;
M: winnt available-page-file ( -- n )
memory-status MEMORYSTATUSEX-ullAvailPageFile ;
memory-status ullAvailPageFile>> ;
M: winnt total-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullTotalVirtual ;
memory-status ullTotalVirtual>> ;
M: winnt available-virtual-mem ( -- n )
memory-status MEMORYSTATUSEX-ullAvailVirtual ;
memory-status ullAvailVirtual>> ;
: computer-name ( -- string )
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
: system-info ( -- SYSTEM_INFO )
"SYSTEM_INFO" <c-object> [ GetSystemInfo ] keep ;
SYSTEM_INFO <struct> [ GetSystemInfo ] keep ;
: page-size ( -- n )
system-info SYSTEM_INFO-dwPageSize ;
system-info dwPageSize>> ;
! 386, 486, 586, 2200 (IA64), 8664 (AMD_X8664)
: 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
: processor-architecture ( -- n )
system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
system-info dwOemId>> HEX: ffff0000 bitand ;
: os-version ( -- os-version )
"OSVERSIONINFO" <c-object>