! 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 ;
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-boxer-quot
unclip
- [ product ]
+ [ array-length ]
[ [ require-c-type-arrays ] keep ] bi*
[ <c-type-direct-array> ] 2curry ;
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
[ 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 ;
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 ;
{ $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." ;
\ No newline at end of file
+"Arrays of C unions can be created with the " { $vocab-link "struct-arrays" } " vocabulary." ;
[ 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>>
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\"" }
{ $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." }
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
! (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
<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
] 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 ] [
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? )
[ 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
] ;
: 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
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
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 )
[
: 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
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 ;
} 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 ;
--- /dev/null
+! 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
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' )
: 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 ;
: 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 ;
: redirect-stderr ( process args -- handle )
over stderr>> +stdout+ eq? [
nip
- lpStartupInfo>> STARTUPINFO-hStdOutput
+ lpStartupInfo>> hStdOutput>>
] [
drop
stderr>>
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 ;
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
: 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 ;
] 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 -- )
] 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 ;
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
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 ;
: 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
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
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
! 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
"combination"
"compiled-generic-uses"
"compiled-uses"
+ "constant"
"constraints"
"custom-inlining"
"decision-tree"
"local-writer"
"local-writer?"
"local?"
+ "low-order"
"macro"
"members"
"memo-quot"
[ "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 ;
: calloc ( size count -- newalien ) (calloc) check-ptr ;
: free ( alien -- ) (free) ;
+
+FORGET: malloc-ptr
+
+FORGET: <malloc-ptr>
] 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?
}
{ "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" }
! Rendering
{ "drawRect:" "void" { "id" "SEL" "NSRect" }
- [ 2drop window relayout-1 ]
+ [ 2drop window relayout-1 yield ]
}
! Events
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
[ 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*
: 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 )
{
{ 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 ;
: 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
! 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
{ "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" }
{ "SYSTEMTIME" "DaylightDate" }
{ "LONG" "DaylightBias" } ;
-C-STRUCT: FILETIME
- { "DWORD" "dwLowDateTime" }
- { "DWORD" "dwHighDateTime" } ;
-
-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: FILETIME
+ { dwLowDateTime DWORD }
+ { dwHighDateTime DWORD } ;
+
+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" } ;
-
-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: PROCESS_INFORMATION
+ { hProcess HANDLE }
+ { hThread HANDLE }
+ { dwProcessId DWORD }
+ { dwThreadId DWORD } ;
+
+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
{ { "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
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
! 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 )
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 )
>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 ;
! 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
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" }
! 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
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?
[ 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
[ 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
! 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 ;
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
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 +
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>
projects / factor.git / commitdiff