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. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.accessors alien.structs USING: alien alien.strings alien.c-types alien.accessors alien.structs
arrays words sequences math kernel namespaces fry libc cpu.architecture arrays words sequences math kernel namespaces fry libc cpu.architecture
io.encodings.utf8 ; io.encodings.utf8 accessors ;
IN: alien.arrays IN: alien.arrays
UNION: value-type array struct-type ; 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 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 ; 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 M: array c-type-boxer-quot
unclip unclip
[ product ] [ array-length ]
[ [ require-c-type-arrays ] keep ] bi* [ [ require-c-type-arrays ] keep ] bi*
[ <c-type-direct-array> ] 2curry ; [ <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 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 <char> *char ] unit-test
[ -1 ] [ -1 <short> *short ] 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 ] [ define-out ]
tri ; 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 ) : malloc-file-contents ( path -- alien len )
binary file-contents [ malloc-byte-array ] [ length ] bi ; 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 ; TUPLE: field-spec name offset type reader writer ;
: reader-word ( class name vocab -- word ) : reader-word ( class name vocab -- word )
[ "-" glue ] dip create ; [ "-" glue ] dip create dup make-deprecated ;
: writer-word ( class name vocab -- word ) : 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> ( struct-name vocab type field-name -- spec )
field-spec new field-spec new
0 >>offset 0 >>offset
swap >>name swap >>name
swap expand-constants >>type swap >>type
3dup name>> swap reader-word >>reader 3dup name>> swap reader-word >>reader
3dup name>> swap writer-word >>writer 3dup name>> swap writer-word >>writer
2nip ; 2nip ;

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

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

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

@ -1,6 +1,6 @@
IN: alien.syntax IN: alien.syntax
USING: alien alien.c-types alien.parser alien.structs USING: alien alien.c-types alien.parser alien.structs
help.markup help.syntax ; classes.struct help.markup help.syntax ;
HELP: DLL" HELP: DLL"
{ $syntax "DLL\" path\"" } { $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." } ; { $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: HELP: C-STRUCT:
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
{ $syntax "C-STRUCT: name pairs... ;" } { $syntax "C-STRUCT: name pairs... ;" }
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } } { $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
{ $description "Defines a C struct layout and accessor words." } { $description "Defines a C struct layout and accessor words." }
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ; { $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
HELP: C-UNION: HELP: C-UNION:
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
{ $syntax "C-UNION: name members... ;" } { $syntax "C-UNION: name members... ;" }
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } } { $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." } { $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 ; scan scan typedef ;
SYNTAX: C-STRUCT: SYNTAX: C-STRUCT:
scan current-vocab parse-definition define-struct ; scan current-vocab parse-definition define-struct ; deprecated
SYNTAX: C-UNION: SYNTAX: C-UNION:
scan parse-definition define-union ; scan parse-definition define-union ; deprecated
SYNTAX: C-ENUM: SYNTAX: C-ENUM:
";" parse-tokens ";" parse-tokens

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

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

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

@ -187,7 +187,7 @@ STRUCT: struct-test-array-slots
] unit-test ] unit-test
STRUCT: struct-test-optimization 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 ] [ [ struct-test-optimization memory>struct y>> ] { memory>struct y>> } inlined? ] unit-test
[ t ] [ [ t ] [

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

@ -232,10 +232,13 @@ ERROR: invalid-struct-slot token ;
c-type c-type-boxed-class c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ; dup \ byte-array = [ drop \ c-ptr ] when ;
: scan-c-type ( -- c-type )
scan dup "{" = [ drop \ } parse-until >array ] when ;
: parse-struct-slot ( -- slot ) : parse-struct-slot ( -- slot )
struct-slot-spec new struct-slot-spec new
scan >>name 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-until [ dup empty? ] [ peel-off-attributes ] until drop ;
: parse-struct-slots ( slots -- slots' more? ) : 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 [ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test
[ f ] [ [ 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 [ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test
[ f ] [ [ { 1 2 3 } swap 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 ) : at-quot ( assoc -- quot )
dup lookup-table-at? [ dup assoc? [
dup fast-lookup-table-at? [ dup lookup-table-at? [
fast-lookup-table-quot dup fast-lookup-table-at? [
] [ fast-lookup-table-quot
lookup-table-quot ] [
] if lookup-table-quot
] if
] [ drop f ] if
] [ drop f ] if ; ] [ drop f ] if ;
\ at* [ at-quot ] 1 define-partial-eval \ 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.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

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

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?

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

@ -30,7 +30,7 @@ CLASS: {
} }
{ "applicationShouldHandleReopen:hasVisibleWindows:" "int" { "id" "SEL" "id" "int" } { "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" } { "factorListener:" "id" { "id" "SEL" "id" }

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

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

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

@ -219,7 +219,11 @@ HELP: <word> ( name vocab -- word )
HELP: gensym HELP: gensym
{ $values { "word" word } } { $values { "word" word } }
{ $description "Creates an uninterned word that is not equal to any other word in the system." } { $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." } ; { $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? HELP: bootstrapping?

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

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

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

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2009 Doug Coleman. ! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io.pathnames kernel namespaces USING: accessors images images.loader io.pathnames kernel
opengl opengl.gl opengl.textures sequences strings ui ui.gadgets models namespaces opengl opengl.gl opengl.textures sequences
ui.gadgets.panes ui.render ui.images ; strings ui ui.gadgets ui.gadgets.panes ui.images ui.render
constructors ;
IN: images.viewer IN: images.viewer
TUPLE: image-gadget < gadget image texture ; 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 ; dup texture>> [ ] [ dup image>> { 0 0 } <texture> >>texture texture>> ] ?if ;
M: image-gadget draw-gadget* ( gadget -- ) 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 ! 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 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>