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

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

db4
Slava Pestov 2009-08-31 20:51:27 -05:00
parent 41e83d2246 4cbd4d4b5c
commit fdb3cd22cd
56 changed files with 855 additions and 658 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
basis/alien/arrays/arrays-docs.factor
View File

@ -7,6 +7,6 @@ $nl
"C type specifiers for array types are documented in " { $link "c-types-specs" } "."
$nl
"Specialized sequences are provided for accessing memory as an array of primitive type values. These sequences are implemented in the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets. They can also be loaded and constructed through their primitive C types:"
{ $subsection require-c-type-arrays }
{ $subsection <c-type-array> }
{ $subsection <c-type-direct-array> } ;
{ $subsection require-c-arrays }
{ $subsection <c-array> }
{ $subsection <c-direct-array> } ;

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

@ -35,8 +35,8 @@ M: array stack-size drop "void*" stack-size ;
M: array c-type-boxer-quot
unclip
[ array-length ]
[ [ require-c-type-arrays ] keep ] bi*
[ <c-type-direct-array> ] 2curry ;
[ [ require-c-arrays ] keep ] bi*
[ <c-direct-array> ] 2curry ;
M: array c-type-unboxer-quot drop [ >c-ptr ] ;

23
basis/alien/c-types/c-types-docs.factor
View File

@ -49,10 +49,10 @@ HELP: c-setter
{ $errors "Throws an error if the type does not exist." } ;
HELP: <c-array>
{ $deprecated "New code should use " { $link <c-type-array> } " or the " { $vocab-link "specialized-arrays" } " vocabularies." }
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
{ $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
{ $errors "Throws an error if the type does not exist or the requested size is negative." } ;
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." }
{ $errors "Throws an error if the type does not exist, the necessary specialized array vocabulary is not loaded, or the requested size is negative." } ;
HELP: <c-object>
{ $values { "type" "a C type" } { "array" byte-array } }
@ -72,8 +72,8 @@ HELP: byte-array>memory
HELP: malloc-array
{ $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-type-direct-array> } "." }
{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-direct-array> } "." }
{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
@ -89,7 +89,7 @@ HELP: malloc-byte-array
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if memory allocation fails." } ;
{ <c-type-array> <c-type-direct-array> malloc-array } related-words
{ <c-array> <c-direct-array> malloc-array } related-words
HELP: box-parameter
{ $values { "n" integer } { "ctype" string } }
@ -130,20 +130,15 @@ HELP: malloc-string
}
} ;
HELP: require-c-type-arrays
HELP: require-c-arrays
{ $values { "c-type" "a C type" } }
{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-type-array> } " or " { $link <c-type-direct-array> } " vocabularies." }
{ $description { $link require } "s any unloaded vocabularies needed to construct a specialized array or direct array of " { $snippet "c-type" } " using the " { $link <c-array> } " or " { $link <c-direct-array> } " vocabularies." }
{ $notes "This word must be called inside a compilation unit. See the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "specialized-arrays.direct" } " vocabulary sets for details on the underlying sequence types loaded." } ;
HELP: <c-type-array>
{ $values { "len" integer } { "c-type" "a C type" } { "array" "a specialized array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } "." }
{ $notes "The appropriate specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays" } " vocabulary set for details on the underlying sequence type constructed." } ;
HELP: <c-type-direct-array>
HELP: <c-direct-array>
{ $values { "alien" c-ptr } { "len" integer } { "c-type" "a C type" } { "array" "a specialized direct array" } }
{ $description "Constructs a new specialized array of length " { $snippet "len" } " and element type " { $snippet "c-type" } " over the range of memory referenced by " { $snippet "alien" } "." }
{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."

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

@ -24,6 +24,7 @@ size
align
array-class
array-constructor
(array)-constructor
direct-array-class
direct-array-constructor
sequence-mixin-class ;
@ -79,47 +80,74 @@ M: string c-type ( name -- type )
: ?require-word ( word/pair -- )
dup word? [ drop ] [ first require ] ?if ;
GENERIC: require-c-type-arrays ( c-type -- )
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: heap-size ( type -- size ) foldable
M: object require-c-type-arrays
M: string heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: require-c-arrays ( c-type -- )
M: object require-c-arrays
drop ;
M: c-type require-c-type-arrays
M: c-type require-c-arrays
[ array-class>> ?require-word ]
[ sequence-mixin-class>> ?require-word ]
[ direct-array-class>> ?require-word ] tri ;
M: string require-c-type-arrays
c-type require-c-type-arrays ;
M: string require-c-arrays
c-type require-c-arrays ;
M: array require-c-type-arrays
first c-type require-c-type-arrays ;
M: array require-c-arrays
first c-type require-c-arrays ;
ERROR: specialized-array-vocab-not-loaded vocab word ;
: c-type-array-constructor ( c-type -- word )
: c-array-constructor ( c-type -- word )
array-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
: c-type-direct-array-constructor ( c-type -- word )
: c-(array)-constructor ( c-type -- word )
(array)-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
: c-direct-array-constructor ( c-type -- word )
direct-array-constructor>> dup array?
[ first2 specialized-array-vocab-not-loaded ] when ; foldable
GENERIC: <c-type-array> ( len c-type -- array )
M: object <c-type-array>
c-type-array-constructor execute( len -- array ) ; inline
M: string <c-type-array>
c-type <c-type-array> ; inline
M: array <c-type-array>
first c-type <c-type-array> ; inline
GENERIC: <c-array> ( len c-type -- array )
M: object <c-array>
c-array-constructor execute( len -- array ) ; inline
M: string <c-array>
c-type <c-array> ; inline
M: array <c-array>
first c-type <c-array> ; inline
GENERIC: <c-type-direct-array> ( alien len c-type -- array )
M: object <c-type-direct-array>
c-type-direct-array-constructor execute( alien len -- array ) ; inline
M: string <c-type-direct-array>
c-type <c-type-direct-array> ; inline
M: array <c-type-direct-array>
first c-type <c-type-direct-array> ; inline
GENERIC: (c-array) ( len c-type -- array )
M: object (c-array)
c-(array)-constructor execute( len -- array ) ; inline
M: string (c-array)
c-type (c-array) ; inline
M: array (c-array)
first c-type (c-array) ; inline
GENERIC: <c-direct-array> ( alien len c-type -- array )
M: object <c-direct-array>
c-direct-array-constructor execute( alien len -- array ) ; inline
M: string <c-direct-array>
c-type <c-direct-array> ; inline
M: array <c-direct-array>
first c-type <c-direct-array> ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
[ heap-size * malloc ] [ <c-direct-array> ] 2bi ; inline
GENERIC: c-type-class ( name -- class )
@ -219,15 +247,6 @@ M: c-type unbox-return f swap c-type-unbox ;
M: string unbox-return c-type unbox-return ;
! These words being foldable means that words need to be
! recompiled if a C type is redefined. Even so, folding the
! size facilitates some optimizations.
GENERIC: heap-size ( type -- size ) foldable
M: string heap-size c-type heap-size ;
M: abstract-c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
@ -253,21 +272,12 @@ M: f byte-length drop 0 ; inline
[ "Cannot write struct fields with this type" throw ]
] unless* ;
: <c-array> ( n type -- array )
heap-size * <byte-array> ; inline deprecated
: <c-object> ( type -- array )
heap-size <byte-array> ; inline
: (c-object) ( type -- array )
heap-size (byte-array) ; inline
: malloc-array ( n type -- alien )
[ heap-size calloc ] [ <c-type-direct-array> ] 2bi ; inline
: (malloc-array) ( n type -- alien )
[ heap-size * malloc ] [ <c-type-direct-array> ] 2bi ; inline
: malloc-object ( type -- alien )
1 swap heap-size calloc ; inline
@ -354,6 +364,10 @@ M: long-long-type box-return ( type -- )
[ "specialized-arrays." prepend ]
[ "<" "-array>" surround ] bi* ?lookup >>array-constructor
]
[
[ "specialized-arrays." prepend ]
[ "(" "-array)" surround ] bi* ?lookup >>(array)-constructor
]
[
[ "specialized-arrays." prepend ]
[ "-sequence" append ] bi* ?lookup >>sequence-mixin-class

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

@ -1,7 +1,9 @@
! (c)Joe Groff bsd license
USING: accessors assocs classes classes.struct combinators
kernel math prettyprint.backend prettyprint.custom
prettyprint.sections see.private sequences strings words ;
USING: accessors alien alien.c-types arrays assocs classes
classes.struct combinators continuations fry kernel make math
math.parser mirrors prettyprint.backend prettyprint.custom
prettyprint.sections see.private sequences strings
summary words ;
IN: classes.struct.prettyprint
<PRIVATE
@ -12,7 +14,7 @@ IN: classes.struct.prettyprint
[ drop \ STRUCT: ] if ;
: struct>assoc ( struct -- assoc )
[ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
[ class struct-slots ] [ struct-slot-values ] bi zip ;
: pprint-struct-slot ( slot -- )
<flow \ { pprint-word
@ -24,6 +26,17 @@ IN: classes.struct.prettyprint
} cleave
\ } pprint-word block> ;
: pprint-struct ( struct -- )
[
[ \ S{ ] dip
[ class ]
[ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
\ } (pprint-tuple)
] ?pprint-tuple ;
: pprint-struct-pointer ( struct -- )
\ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
PRIVATE>
M: struct-class see-class*
@ -38,4 +51,23 @@ M: struct >pprint-sequence
[ class ] [ struct-slot-values ] bi class-slot-sequence ;
M: struct pprint*
[ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
[ pprint-struct ]
[ pprint-struct-pointer ] pprint-c-object ;
M: struct summary
[
dup class name>> %
" struct of " %
byte-length #
" bytes " %
] "" make ;
M: struct make-mirror
[
[ drop "underlying" ] [ (underlying)>> ] bi 2array 1array
] [
'[
_ struct>assoc
[ [ [ name>> ] [ c-type>> ] bi 2array ] dip ] assoc-map
] [ drop { } ] recover
] bi append ;

7
basis/classes/struct/struct-docs.factor
View File

@ -42,6 +42,13 @@ HELP: S{
{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
HELP: S@
{ $syntax "S@ class alien" }
{ $values { "class" "a " { $link struct } " class word" } { "alien" "a literal alien" } }
{ $description "Marks the beginning of a literal struct at a specific C address. The prettyprinter uses this syntax when the memory backing a struct object is invalid. This syntax should not generally be used in source code." } ;
{ POSTPONE: S{ POSTPONE: S@ } related-words
HELP: UNION-STRUCT:
{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }
{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }

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

@ -1,12 +1,12 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.libraries
alien.structs.fields alien.syntax ascii classes.struct combinators
destructors io.encodings.utf8 io.pathnames io.streams.string
alien.structs.fields alien.syntax ascii byte-arrays classes.struct
combinators destructors io.encodings.utf8 io.pathnames io.streams.string
kernel libc literals math multiline namespaces prettyprint
prettyprint.config see sequences specialized-arrays.ushort
system tools.test compiler.tree.debugger struct-arrays
classes.tuple.private specialized-arrays.direct.int
compiler.units byte-arrays specialized-arrays.char ;
compiler.units specialized-arrays.char ;
IN: classes.struct.tests
<<
@ -76,18 +76,38 @@ STRUCT: struct-test-string-ptr
] with-destructors
] unit-test
[ "S{ struct-test-foo { y 7654 } }" ]
[ "S{ struct-test-foo { x 0 } { y 7654 } { z f } }" ]
[
f boa-tuples?
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
with-variable
[
boa-tuples? off
c-object-pointers? off
struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S@ struct-test-foo B{ 0 0 0 0 0 0 0 0 0 0 0 0 }" ]
[
[
c-object-pointers? on
12 <byte-array> struct-test-foo memory>struct [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S{ struct-test-foo f 0 7654 f }" ]
[
t boa-tuples?
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
with-variable
[
boa-tuples? on
c-object-pointers? off
struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer
] with-scope
] unit-test
[ "S@ struct-test-foo f" ]
[
[
c-object-pointers? off
f struct-test-foo memory>struct [ pprint ] with-string-writer
] with-scope
] unit-test
[ <" USING: classes.struct ;
@ -164,6 +184,14 @@ STRUCT: struct-test-equality-2
] with-destructors
] unit-test
[ t ] [
[
struct-test-equality-1 <struct> 5 >>x
struct-test-equality-1 malloc-struct &free 5 >>x
[ hashcode ] bi@ =
] with-destructors
] unit-test
STRUCT: struct-test-ffi-foo
{ x int }
{ y int } ;

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

@ -6,7 +6,7 @@ combinators combinators.short-circuit combinators.smart
functors.backend fry generalizations generic.parser kernel
kernel.private lexer libc locals macros make math math.order parser
quotations sequences slots slots.private struct-arrays vectors
words compiler.tree.propagation.transforms ;
words compiler.tree.propagation.transforms specialized-arrays.direct.uchar ;
FROM: slots => reader-word writer-word ;
IN: classes.struct
@ -23,7 +23,7 @@ TUPLE: struct-slot-spec < slot-spec
PREDICATE: struct-class < tuple-class
{ [ \ struct subclass-of? ] [ all-slots length 1 = ] } 1&& ;
: struct-slots ( struct -- slots )
: struct-slots ( struct-class -- slots )
"struct-slots" word-prop ;
! struct allocation
@ -35,7 +35,10 @@ M: struct equal?
{
[ [ class ] bi@ = ]
[ [ >c-ptr ] [ [ >c-ptr ] [ byte-length ] bi ] bi* memory= ]
} 2&& ;
} 2&& ; inline
M: struct hashcode*
[ >c-ptr ] [ byte-length ] bi <direct-uchar-array> hashcode* ; inline
: struct-prototype ( class -- prototype ) "prototype" word-prop ; foldable
@ -254,19 +257,22 @@ PRIVATE>
ERROR: invalid-struct-slot token ;
<PRIVATE
: struct-slot-class ( c-type -- class' )
c-type c-type-boxed-class
dup \ byte-array = [ drop \ c-ptr ] when ;
: <struct-slot-spec> ( name c-type attributes -- slot-spec )
[ struct-slot-spec new ] 3dip
[ >>name ]
[ [ >>c-type ] [ struct-slot-class >>class ] bi ]
[ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
<PRIVATE
: 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 [ >>c-type ] [ struct-slot-class >>class ] bi
\ } parse-until [ dup empty? ] [ peel-off-attributes ] until drop ;
scan scan-c-type \ } parse-until <struct-slot-spec> ;
: parse-struct-slots ( slots -- slots' more? )
scan {
@ -287,23 +293,18 @@ SYNTAX: UNION-STRUCT:
SYNTAX: S{
scan-word dup struct-slots parse-tuple-literal-slots parsed ;
SYNTAX: S@
scan-word scan-object swap memory>struct parsed ;
! functor support
<PRIVATE
: scan-c-type` ( -- c-type/param )
scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
:: parse-struct-slot` ( accum -- accum )
scan-string-param :> name
scan-c-type` :> c-type
\ } parse-until :> attributes
accum {
\ struct-slot-spec new
name >>name
c-type [ >>c-type ] [ struct-slot-class >>class ] bi
attributes [ dup empty? ] [ peel-off-attributes ] until drop
over push
} over push-all ;
: parse-struct-slot` ( accum -- accum )
scan-string-param scan-c-type` \ } parse-until
[ <struct-slot-spec> over push ] 3curry over push-all ;
: parse-struct-slots` ( accum -- accum more? )
scan {

4
basis/cocoa/enumeration/enumeration.factor
View File

@ -4,7 +4,7 @@ USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
locals math sequences vectors fry libc destructors ;
IN: cocoa.enumeration
<< "id" require-c-type-arrays >>
<< "id" require-c-arrays >>
CONSTANT: NS-EACH-BUFFER-SIZE 16
@ -19,7 +19,7 @@ CONSTANT: NS-EACH-BUFFER-SIZE 16
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
items-count 0 = [
state itemsPtr>> [ items-count "id" <c-type-direct-array> ] [ stackbuf ] if* :> items
state itemsPtr>> [ items-count "id" <c-direct-array> ] [ stackbuf ] if* :> items
items-count iota [ items nth quot call ] each
object quot state stackbuf count (NSFastEnumeration-each)
] unless ; inline recursive

12
basis/cocoa/messages/messages.factor
View File

@ -155,12 +155,16 @@ objc>alien-types get [ swap ] assoc-map
} case
assoc-union alien>objc-types set-global
: internal-cocoa-type? ( c-type -- ? )
[ "?" = ] [ first CHAR: _ = ] bi or ;
: warn-c-type ( c-type -- )
dup internal-cocoa-type?
[ drop ] [ "Warning: no such C type: " write print ] if ;
: objc-struct-type ( i string -- ctype )
[ CHAR: = ] 2keep index-from swap subseq
dup c-types get key? [
"Warning: no such C type: " write dup print
drop "void*"
] unless ;
dup c-types get key? [ warn-c-type "void*" ] unless ;
ERROR: no-objc-type name ;

4
basis/environment/winnt/winnt.factor
View File

@ -6,10 +6,10 @@ alien.c-types sequences windows.errors io.streams.memory
io.encodings io ;
IN: environment.winnt
<< "TCHAR" require-c-type-arrays >>
<< "TCHAR" require-c-arrays >>
M: winnt os-env ( key -- value )
MAX_UNICODE_PATH "TCHAR" <c-type-array>
MAX_UNICODE_PATH "TCHAR" <c-array>
[ dup length GetEnvironmentVariable ] keep over 0 = [
2drop f
] [

93
basis/game-input/dinput/dinput.factor
View File

@ -39,12 +39,14 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
get IDirectInputDevice8W::SetDataFormat ole32-error ;
: <buffer-size-diprop> ( size -- DIPROPDWORD )
"DIPROPDWORD" <c-object>
"DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
"DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
0 over set-DIPROPHEADER-dwObj
DIPH_DEVICE over set-DIPROPHEADER-dwHow
swap over set-DIPROPDWORD-dwData ;
DIPROPDWORD <struct> [
diph>>
DIPROPDWORD heap-size >>dwSize
DIPROPHEADER heap-size >>dwHeaderSize
0 >>dwObj
DIPH_DEVICE >>dwHow
drop
] keep swap >>dwData ;
: set-buffer-size ( device size -- )
DIPROP_BUFFERSIZE swap <buffer-size-diprop>
@ -63,7 +65,7 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
GUID_SysKeyboard device-for-guid
[ configure-keyboard ]
[ +keyboard-device+ set-global ] bi
256 <byte-array> <keys-array> keyboard-state boa
256 <byte-array> 256 <keys-array> keyboard-state boa
+keyboard-state+ set-global ;
: find-mouse ( -- )
@ -72,23 +74,20 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
[ +mouse-device+ set-global ] bi
0 0 0 0 8 f <array> mouse-state boa
+mouse-state+ set-global
MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
MOUSE-BUFFER-SIZE DIDEVICEOBJECTDATA <struct-array>
+mouse-buffer+ set-global ;
: device-info ( device -- DIDEVICEIMAGEINFOW )
"DIDEVICEINSTANCEW" <c-object>
"DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
[ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
DIDEVICEINSTANCEW <struct>
DIDEVICEINSTANCEW heap-size >>dwSize
[ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ; inline
: device-caps ( device -- DIDEVCAPS )
"DIDEVCAPS" <c-object>
"DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
[ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
: <guid> ( memory -- byte-array )
"GUID" heap-size memory>byte-array ;
DIDEVCAPS <struct>
DIDEVCAPS heap-size >>dwSize
[ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ; inline
: device-guid ( device -- guid )
device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
device-info guidInstance>> ; inline
: device-attached? ( device -- ? )
+dinput+ get swap device-guid
@ -96,8 +95,9 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
: find-device-axes-callback ( -- alien )
[ ! ( lpddoi pvRef -- BOOL )
[ DIDEVICEOBJECTINSTANCEW memory>struct ] dip
+controller-devices+ get at
swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
swap guidType>> {
{ [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
{ [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
{ [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
@ -118,8 +118,8 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
: controller-state-template ( device -- controller-state )
controller-state new
over device-caps
[ DIDEVCAPS-dwButtons f <array> >>buttons ]
[ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
[ dwButtons>> f <array> >>buttons ]
[ dwPOVs>> zero? f pov-neutral ? >>pov ] bi
find-device-axes ;
: device-known? ( guid -- ? )
@ -129,12 +129,12 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
device-for-guid {
[ configure-controller ]
[ controller-state-template ]
[ dup device-guid +controller-guids+ get set-at ]
[ dup device-guid clone +controller-guids+ get set-at ]
[ +controller-devices+ get set-at ]
} cleave ;
: add-controller ( guid -- )
dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
dup device-known? [ drop ] [ (add-controller) ] if ;
: remove-controller ( device -- )
[ +controller-devices+ get delete-at ]
@ -143,9 +143,9 @@ SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
: find-controller-callback ( -- alien )
[ ! ( lpddi pvRef -- BOOL )
drop DIDEVICEINSTANCEW-guidInstance add-controller
drop DIDEVICEINSTANCEW memory>struct guidInstance>> add-controller
DIENUM_CONTINUE
] LPDIENUMDEVICESCALLBACKW ;
] LPDIENUMDEVICESCALLBACKW ; inline
: find-controllers ( -- )
+dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
@ -252,11 +252,11 @@ M: dinput-game-input-backend get-controllers
[ drop controller boa ] { } assoc>map ;
M: dinput-game-input-backend product-string
handle>> device-info DIDEVICEINSTANCEW-tszProductName
handle>> device-info tszProductName>>
utf16n alien>string ;
M: dinput-game-input-backend product-id
handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
handle>> device-info guidProduct>> ;
M: dinput-game-input-backend instance-id
handle>> device-guid ;
@ -273,38 +273,36 @@ CONSTANT: pov-values
}
: >axis ( long -- float )
32767 - 32767.0 /f ;
32767 - 32767.0 /f ; inline
: >slider ( long -- float )
65535.0 /f ;
65535.0 /f ; inline
: >pov ( long -- symbol )
dup HEX: FFFF bitand HEX: FFFF =
[ drop pov-neutral ]
[ 2750 + 4500 /i pov-values nth ] if ;
: >buttons ( alien length -- array )
memory>byte-array <keys-array> ;
[ 2750 + 4500 /i pov-values nth ] if ; inline
: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
[ drop ] compose [ 2drop ] if ; inline
: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
{
[ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
[ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
[ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
[ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
[ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
[ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
[ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
[ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
[ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
[ over x>> [ lX>> >axis >>x ] (fill-if) ]
[ over y>> [ lY>> >axis >>y ] (fill-if) ]
[ over z>> [ lZ>> >axis >>z ] (fill-if) ]
[ over rx>> [ lRx>> >axis >>rx ] (fill-if) ]
[ over ry>> [ lRy>> >axis >>ry ] (fill-if) ]
[ over rz>> [ lRz>> >axis >>rz ] (fill-if) ]
[ over slider>> [ rglSlider>> first >slider >>slider ] (fill-if) ]
[ over pov>> [ rgdwPOV>> first >pov >>pov ] (fill-if) ]
[ rgbButtons>> over buttons>> length <keys-array> >>buttons ]
} 2cleave ;
: read-device-buffer ( device buffer count -- buffer count' )
[ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
[ DIDEVICEOBJECTDATA heap-size ] 2dip <uint>
[ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
[ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
[ dwData>> 32 >signed ] [ dwOfs>> ] bi {
{ DIMOFS_X [ [ + ] curry change-dx ] }
{ DIMOFS_Y [ [ + ] curry change-dy ] }
{ DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
@ -312,16 +310,15 @@ CONSTANT: pov-values
} case ;
: fill-mouse-state ( buffer count -- state )
[ +mouse-state+ get ] 2dip swap
[ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
[ +mouse-state+ get ] 2dip swap [ nth (fill-mouse-state) ] curry each ;
: get-device-state ( device byte-array -- )
: get-device-state ( device DIJOYSTATE2 -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
[ length ] keep
[ byte-length ] keep
IDirectInputDevice8W::GetDeviceState ole32-error ;
: (read-controller) ( handle template -- state )
swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
swap [ DIJOYSTATE2 <struct> [ get-device-state ] keep ]
[ fill-controller-state ] [ drop f ] with-acquisition ;
M: dinput-game-input-backend read-controller

6
basis/game-input/dinput/keys-array/keys-array.factor
View File

@ -2,13 +2,15 @@ USING: sequences sequences.private math alien.c-types
accessors ;
IN: game-input.dinput.keys-array
TUPLE: keys-array underlying ;
TUPLE: keys-array
{ underlying sequence read-only }
{ length integer read-only } ;
C: <keys-array> keys-array
: >key ( byte -- ? )
HEX: 80 bitand c-bool> ;
M: keys-array length underlying>> length ;
M: keys-array length length>> ;
M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
INSTANCE: keys-array sequence

10
basis/io/files/info/unix/freebsd/freebsd.factor
View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.syntax combinators
io.backend io.files io.files.info io.files.unix kernel math system unix
unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd
sequences grouping alien.strings io.encodings.utf8 unix.types
arrays io.files.info.unix classes.struct ;
arrays io.files.info.unix classes.struct struct-arrays ;
IN: io.files.info.unix.freebsd
TUPLE: freebsd-file-system-info < unix-file-system-info
@ -40,7 +40,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf
} cleave ;
M: freebsd file-system-statvfs ( path -- byte-array )
\ statvfs <struct> [ \ statvfs io-error ] keep ;
\ statvfs <struct> [ statvfs io-error ] keep ;
M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-info )
{
@ -50,6 +50,6 @@ M: freebsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in
M: freebsd file-systems ( -- array )
f 0 0 getfsstat dup io-error
\ statfs <struct> dup dup length 0 getfsstat io-error
statfs heap-size group
[ f_mntonname>> alien>native-string file-system-info ] map ;
\ statfs <struct-array>
[ dup length 0 getfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ;

8
basis/io/files/info/unix/netbsd/netbsd.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix
combinators system io.backend accessors alien.c-types
io.encodings.utf8 alien.strings unix.types io.files.unix
io.files io.files.info unix.statvfs.netbsd unix.getfsstat.netbsd arrays
grouping sequences io.encodings.utf8 classes.struct
grouping sequences io.encodings.utf8 classes.struct struct-arrays
io.files.info.unix ;
IN: io.files.info.unix.netbsd
@ -47,6 +47,6 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf
M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error
\ statvfs <c-type-array> dup dup length 0 getvfsstat io-error
\ statvfs heap-size group
[ f_mntonname>> utf8 alien>string file-system-info ] map ;
\ statvfs <struct-array>
[ dup length 0 getvfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ;

15
basis/io/files/info/unix/openbsd/openbsd.factor Normal file → Executable file
View File

@ -4,7 +4,8 @@ USING: accessors alien.c-types alien.strings alien.syntax
combinators io.backend io.files io.files.info io.files.unix kernel math
sequences system unix unix.getfsstat.openbsd grouping
unix.statfs.openbsd unix.statvfs.openbsd unix.types
arrays io.files.info.unix classes.struct ;
arrays io.files.info.unix classes.struct struct-arrays
io.encodings.utf8 ;
IN: io.files.unix.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-info
@ -34,9 +35,9 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info
[ f_fsid>> >>id ]
[ f_namemax>> >>name-max ]
[ f_owner>> >>owner ]
[ f_fstypename>> alien>native-string >>type ]
[ f_mntonname>> alien>native-string >>mount-point ]
[ f_mntfromname>> alien>native-string >>device-name ]
[ f_fstypename>> utf8 alien>string >>type ]
[ f_mntonname>> utf8 alien>string >>mount-point ]
[ f_mntfromname>> utf8 alien>string >>device-name ]
} cleave ;
M: openbsd file-system-statvfs ( normalized-path -- statvfs )
@ -47,6 +48,6 @@ M: openbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-in
M: openbsd file-systems ( -- seq )
f 0 0 getfsstat dup io-error
\ statfs <c-type-array> dup dup length 0 getfsstat io-error
\ statfs heap-size group
[ f_mntonname>> alien>native-string file-system-info ] map ;
\ statfs <struct-array>
[ dup length 0 getfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ;

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

@ -98,11 +98,11 @@ M: windows link-info ( path -- info )
file-info ;
: volume-information ( normalized-path -- volume-name volume-serial max-component flags type )
MAX_PATH 1 + [ <byte-array> ] keep
MAX_PATH 1 + [ <ushort-array> ] keep
"DWORD" <c-object>
"DWORD" <c-object>
"DWORD" <c-object>
MAX_PATH 1 + [ <byte-array> ] keep
MAX_PATH 1 + [ <ushort-array> ] keep
[ GetVolumeInformation win32-error=0/f ] 7 nkeep
drop 5 nrot drop
[ utf16n alien>string ] 4 ndip
@ -154,13 +154,13 @@ M: winnt file-system-info ( path -- file-system-info )
] if ;
: find-first-volume ( -- string handle )
MAX_PATH 1 + [ <byte-array> ] keep
MAX_PATH 1 + [ <ushort-array> ] keep
dupd
FindFirstVolume dup win32-error=0/f
[ utf16n alien>string ] dip ;
: find-next-volume ( handle -- string/f )
MAX_PATH 1 + [ <byte-array> tuck ] keep
MAX_PATH 1 + [ <ushort-array> tuck ] keep
FindNextVolume 0 = [
GetLastError ERROR_NO_MORE_FILES =
[ drop f ] [ win32-error-string throw ] if

2
basis/math/blas/matrices/matrices.factor
View File

@ -132,7 +132,7 @@ M: blas-matrix-base clone
! XXX try rounding stride to next 128 bit bound for better vectorizin'
: <empty-matrix> ( rows cols exemplar -- matrix )
[ element-type [ * ] dip <c-array> ]
[ element-type heap-size * * <byte-array> ]
[ 2drop ]
[ f swap (blas-matrix-like) ] 3tri ;

4
basis/math/blas/vectors/vectors.factor
View File

@ -99,12 +99,12 @@ PRIVATE>
length v inc>> v (blas-vector-like) ;
: <zero-vector> ( exemplar -- zero )
[ element-type <c-object> ]
[ element-type heap-size <byte-array> ]
[ length>> 0 ]
[ (blas-vector-like) ] tri ;
: <empty-vector> ( length exemplar -- vector )
[ element-type <c-array> ]
[ element-type heap-size * <byte-array> ]
[ 1 swap ] 2bi
(blas-vector-like) ;

6
basis/pango/layouts/layouts.factor
View File

@ -5,7 +5,7 @@ USING: arrays sequences alien alien.c-types alien.destructors
alien.syntax math math.functions math.vectors destructors combinators
colors fonts accessors assocs namespaces kernel pango pango.fonts
pango.cairo cairo cairo.ffi glib unicode.data images cache init
math.rectangles fry memoize io.encodings.utf8 ;
math.rectangles fry memoize io.encodings.utf8 classes.struct ;
IN: pango.layouts
LIBRARY: pango
@ -84,8 +84,8 @@ SYMBOL: dpi
[ set-layout-text ] keep ;
: layout-extents ( layout -- ink-rect logical-rect )
"PangoRectangle" <c-object>
"PangoRectangle" <c-object>
PangoRectangle <struct>
PangoRectangle <struct>
[ pango_layout_get_extents ] 2keep
[ PangoRectangle>rect ] bi@ ;

17
basis/pango/pango.factor
View File

@ -2,7 +2,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license
USING: arrays system alien.destructors alien.c-types alien.syntax alien
combinators math.rectangles kernel math alien.libraries ;
combinators math.rectangles kernel math alien.libraries classes.struct
accessors ;
IN: pango
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -25,13 +26,13 @@ CONSTANT: PANGO_SCALE 1024
FUNCTION: PangoContext*
pango_context_new ( ) ;
C-STRUCT: PangoRectangle
{ "int" "x" }
{ "int" "y" }
{ "int" "width" }
{ "int" "height" } ;
STRUCT: PangoRectangle
{ x int }
{ y int }
{ width int }
{ height int } ;
: PangoRectangle>rect ( PangoRectangle -- rect )
[ [ PangoRectangle-x pango>float ] [ PangoRectangle-y pango>float ] bi 2array ]
[ [ PangoRectangle-width pango>float ] [ PangoRectangle-height pango>float ] bi 2array ] bi
[ [ x>> pango>float ] [ y>> pango>float ] bi 2array ]
[ [ width>> pango>float ] [ height>> pango>float ] bi 2array ] bi
<rect> ;

20
basis/prettyprint/backend/backend.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays byte-vectors generic hashtables
assocs kernel math namespaces make sequences strings sbufs vectors
words prettyprint.config prettyprint.custom prettyprint.sections
quotations io io.pathnames io.styles math.parser effects classes.tuple
math.order classes.tuple.private classes combinators colors ;
USING: accessors arrays byte-arrays byte-vectors continuations
generic hashtables assocs kernel math namespaces make sequences
strings sbufs vectors words prettyprint.config prettyprint.custom
prettyprint.sections quotations io io.pathnames io.styles math.parser
effects classes.tuple math.order classes.tuple.private classes
combinators colors ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
@ -153,6 +154,15 @@ M: pathname pprint*
M: tuple pprint*
pprint-tuple ;
: recover-pprint ( try recovery -- )
pprinter-stack get clone
[ pprinter-stack set ] curry prepose recover ; inline
: pprint-c-object ( object content-quot pointer-quot -- )
[ c-object-pointers? get ] 2dip
[ nip ]
[ [ drop ] prepose [ recover-pprint ] 2curry ] 2bi if ; inline
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]

5
basis/prettyprint/config/config-docs.factor
View File

@ -23,5 +23,8 @@ HELP: string-limit?
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
HELP: boa-tuples?
{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." }
{ $var-description "Toggles whether tuples and structs print in BOA-form or assoc-form." }
{ $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ;
HELP: c-object-pointers?
{ $var-description "Toggles whether C objects such as structs and direct arrays only print their underlying address. If this flag isn't set, C objects will attempt to print their contents. If a C object points to invalid memory, it will display only its address regardless." } ;

1
basis/prettyprint/config/config.factor
View File

@ -13,6 +13,7 @@ SYMBOL: length-limit
SYMBOL: line-limit
SYMBOL: string-limit?
SYMBOL: boa-tuples?
SYMBOL: c-object-pointers?
4 tab-size set-global
64 margin set-global

1
basis/prettyprint/prettyprint-docs.factor
View File

@ -30,6 +30,7 @@ ARTICLE: "prettyprint-variables" "Prettyprint control variables"
{ $subsection line-limit }
{ $subsection string-limit? }
{ $subsection boa-tuples? }
{ $subsection c-object-pointers? }
"Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables."
{
$warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope."

19
basis/specialized-arrays/direct/functor/functor.factor
View File

@ -2,9 +2,17 @@
! See http://factorcode.org/license.txt for BSD license.
USING: functors sequences sequences.private kernel words classes
math alien alien.c-types byte-arrays accessors
specialized-arrays prettyprint.custom ;
specialized-arrays parser
prettyprint.backend prettyprint.custom prettyprint.sections ;
IN: specialized-arrays.direct.functor
<PRIVATE
: pprint-direct-array ( direct-array tag -- )
[ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
PRIVATE>
FUNCTOR: define-direct-array ( T -- )
A' IS ${T}-array
@ -15,6 +23,7 @@ A'{ IS ${A'}{
A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${A}>
A'@ DEFINES ${A'}@
NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
@ -34,11 +43,17 @@ M: A new-sequence drop <A'> ; inline
M: A byte-length length>> T heap-size * ; inline
SYNTAX: A'@
scan-object scan-object <A> parsed ;
M: A pprint-delims drop \ A'{ \ } ;
M: A >pprint-sequence ;
M: A pprint* pprint-object ;
M: A pprint*
[ pprint-object ]
[ \ A'@ pprint-direct-array ]
pprint-c-object ;
INSTANCE: A sequence
INSTANCE: A S

9
basis/specialized-arrays/functor/functor.factor
View File

@ -10,10 +10,10 @@ ERROR: bad-byte-array-length byte-array type ;
M: bad-byte-array-length summary
drop "Byte array length doesn't divide type width" ;
: (c-array) ( n c-type -- array )
: (underlying) ( n c-type -- array )
heap-size * (byte-array) ; inline
: <c-array> ( n type -- array )
: <underlying> ( n type -- array )
heap-size * <byte-array> ; inline
FUNCTOR: define-array ( T -- )
@ -37,9 +37,9 @@ TUPLE: A
{ length array-capacity read-only }
{ underlying byte-array read-only } ;
: <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
: <A> ( n -- specialized-array ) dup T <underlying> A boa ; inline
: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
: (A) ( n -- specialized-array ) dup T (underlying) A boa ; inline
: byte-array>A ( byte-array -- specialized-array )
dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless
@ -86,6 +86,7 @@ A T c-type-boxed-class specialize-vector-words
T c-type
\ A >>array-class
\ <A> >>array-constructor
\ (A) >>(array)-constructor
\ S >>sequence-mixin-class
drop

11
basis/struct-arrays/prettyprint/prettyprint.factor
View File

@ -1,6 +1,6 @@
! (c)Joe Groff bsd license
USING: accessors arrays kernel prettyprint.backend
prettyprint.custom sequences struct-arrays ;
prettyprint.custom prettyprint.sections sequences struct-arrays ;
IN: struct-arrays.prettyprint
M: struct-array pprint-delims
@ -9,5 +9,12 @@ M: struct-array pprint-delims
M: struct-array >pprint-sequence
[ >array ] [ class>> ] bi prefix ;
M: struct-array pprint* pprint-object ;
: pprint-struct-array-pointer ( struct-array -- )
\ struct-array@
[ [ class>> pprint-word ] [ underlying>> pprint* ] [ length>> pprint* ] tri ]
pprint-prefix ;
M: struct-array pprint*
[ pprint-object ]
[ pprint-struct-array-pointer ] pprint-c-object ;

32
basis/struct-arrays/struct-arrays-docs.factor
View File

@ -1,5 +1,5 @@
IN: struct-arrays
USING: help.markup help.syntax alien strings math ;
USING: classes.struct help.markup help.syntax alien strings math multiline ;
HELP: struct-array
{ $class-description "The class of C struct and union arrays."
@ -14,10 +14,38 @@ HELP: <direct-struct-array>
{ $values { "alien" c-ptr } { "length" integer } { "c-type" string } { "struct-array" struct-array } }
{ $description "Creates a new array for holding values of the specified C type, backed by the memory at " { $snippet "alien" } "." } ;
HELP: struct-array-on
{ $value { "struct" struct } { "length" integer } }
{ $description "Create a new array for holding values of " { $snippet "struct" } "'s C type, backed by the memory starting at " { $snippet "struct" } "'s address." }
{ $examples
"This word is useful with the FFI. When a C function has a pointer to a struct as its return type (or a C callback has a struct pointer as an argument type), Factor automatically wraps the pointer in a " { $link struct } " object. If the pointer actually references an array of objects, this word will convert the struct object to a struct array object:"
{ $code <" USING: alien.syntax classes.struct struct-arrays ;
IN: scratchpad
STRUCT: zim { zang int } { zung int } ;
FUNCTION: zim* zingle ( ) ; ! Returns a pointer to 20 zims
zingle 20 struct-array-on "> }
} ;
HELP: struct-array{
{ $syntax "struct-array{ class value value value ... }" }
{ $description "Literal syntax for a " { $link struct-array } " containing structs of the given " { $link struct } " class." } ;
HELP: struct-array@
{ $syntax "struct-array@ class alien length" }
{ $description "Literal syntax for a " { $link struct-array } " at a particular memory address. The prettyprinter uses this syntax when the memory backing a struct array object is invalid. This syntax should not generally be used in source code." } ;
{ POSTPONE: struct-array{ POSTPONE: struct-array@ } related-words
ARTICLE: "struct-arrays" "C struct and union arrays"
"The " { $vocab-link "struct-arrays" } " vocabulary implements arrays specialized for holding C struct and union values."
{ $subsection struct-array }
{ $subsection <struct-array> }
{ $subsection <direct-struct-array> } ;
{ $subsection <direct-struct-array> }
{ $subsection struct-array-on }
"Struct arrays have literal syntax:"
{ $subsection POSTPONE: struct-array{ } ;
ABOUT: "struct-arrays"

59
basis/struct-arrays/struct-arrays.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.structs byte-arrays
classes.struct kernel libc math parser sequences sequences.private ;
classes classes.struct kernel libc math parser sequences
sequences.private words fry memoize compiler.units ;
IN: struct-arrays
: c-type-struct-class ( c-type -- class )
@ -11,7 +12,8 @@ TUPLE: struct-array
{ underlying c-ptr read-only }
{ length array-capacity read-only }
{ element-size array-capacity read-only }
{ class read-only } ;
{ class read-only }
{ ctor read-only } ;
M: struct-array length length>> ; inline
M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
@ -20,47 +22,65 @@ M: struct-array byte-length [ length>> ] [ element-size>> ] bi * ; inline
[ element-size>> * >fixnum ] [ underlying>> ] bi <displaced-alien> ; inline
M: struct-array nth-unsafe
[ (nth-ptr) ] [ class>> dup struct-class? ] bi [ memory>struct ] [ drop ] if ; inline
[ (nth-ptr) ] [ ctor>> ] bi execute( alien -- object ) ; inline
M: struct-array set-nth-unsafe
[ (nth-ptr) swap ] [ element-size>> ] bi memcpy ; inline
: (struct-element-constructor) ( c-type -- word )
[
"struct-array-ctor" f <word>
[
swap dup struct-class?
[ '[ _ memory>struct ] [ ] like ] [ drop [ ] ] if
(( alien -- object )) define-inline
] keep
] with-compilation-unit ;
! Foldable memo word. This is an optimization; by precompiling a
! constructor for array elements, we avoid memory>struct's slow path.
MEMO: struct-element-constructor ( c-type -- word )
(struct-element-constructor) ; foldable
: <direct-struct-array> ( alien length c-type -- struct-array )
[ heap-size ] [ c-type-struct-class ] [ struct-element-constructor ]
tri struct-array boa ; inline
M: struct-array new-sequence
[ element-size>> [ * (byte-array) ] 2keep ]
[ class>> ] bi struct-array boa ; inline
[ element-size>> * (byte-array) ] [ length>> ] [ class>> ] tri
<direct-struct-array> ; inline
M: struct-array resize ( n seq -- newseq )
[ [ element-size>> * ] [ underlying>> ] bi resize ]
[ [ element-size>> ] [ class>> ] bi ] 2bi
struct-array boa ;
[ [ element-size>> * ] [ underlying>> ] bi resize ] [ class>> ] 2bi
<direct-struct-array> ; inline
: <struct-array> ( length c-type -- struct-array )
[ heap-size [ * <byte-array> ] 2keep ]
[ c-type-struct-class ] bi struct-array boa ; inline
[ heap-size * <byte-array> ] 2keep <direct-struct-array> ; inline
ERROR: bad-byte-array-length byte-array ;
: byte-array>struct-array ( byte-array c-type -- struct-array )
[ heap-size [
[
heap-size
[ dup length ] dip /mod 0 =
[ drop bad-byte-array-length ] unless
] keep ] [ c-type-struct-class ] bi struct-array boa ; inline
] keep <direct-struct-array> ; inline
: <direct-struct-array> ( alien length c-type -- struct-array )
[ heap-size ] [ c-type-struct-class ] bi struct-array boa ; inline
: struct-array-on ( struct length -- struct-array )
[ [ >c-ptr ] [ class ] bi ] dip swap <direct-struct-array> ; inline
: malloc-struct-array ( length c-type -- struct-array )
[ heap-size calloc ] 2keep <direct-struct-array> ; inline
INSTANCE: struct-array sequence
M: struct-type <c-type-array> ( len c-type -- array )
dup c-type-array-constructor
M: struct-type <c-array> ( len c-type -- array )
dup c-array-constructor
[ execute( len -- array ) ]
[ <struct-array> ] ?if ; inline
M: struct-type <c-type-direct-array> ( alien len c-type -- array )
dup c-type-direct-array-constructor
M: struct-type <c-direct-array> ( alien len c-type -- array )
dup c-direct-array-constructor
[ execute( alien len -- array ) ]
[ <direct-struct-array> ] ?if ; inline
@ -71,6 +91,9 @@ M: struct-type <c-type-direct-array> ( alien len c-type -- array )
SYNTAX: struct-array{
\ } scan-word [ >struct-array ] curry parse-literal ;
SYNTAX: struct-array@
scan-word [ scan-object scan-object ] dip <direct-struct-array> parsed ;
USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "struct-arrays.prettyprint" require ] when

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

@ -68,9 +68,14 @@ IN: tools.deploy.shaker
] when ;
: strip-destructors ( -- )
"libc" vocab [
"Stripping destructor debug code" show
"vocab:tools/deploy/shaker/strip-destructors.factor"
run-file ;
: strip-struct-arrays ( -- )
"struct-arrays" vocab [
"Stripping dynamic struct array code" show
"vocab:tools/deploy/shaker/strip-struct-arrays.factor"
run-file
] when ;
@ -493,6 +498,7 @@ SYMBOL: deploy-vocab
: strip ( -- )
init-stripper
strip-libc
strip-struct-arrays
strip-destructors
strip-call
strip-cocoa

14
basis/tools/deploy/shaker/strip-call.factor
View File

@ -1,10 +1,14 @@
! Copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
IN: tools.deploy.shaker.call
USING: combinators.private kernel ;
IN: combinators
USE: combinators.private
: call-effect ( word effect -- ) call-effect-unsafe ; inline
: call-effect ( word effect -- ) call-effect-unsafe ;
: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
: execute-effect ( word effect -- ) execute-effect-unsafe ;
IN: compiler.tree.propagation.call-effect
: call-effect-unsafe? ( quot effect -- ? ) 2drop t ; inline
: execute-effect-unsafe? ( word effect -- ? ) 2drop t ; inline

13
basis/tools/deploy/shaker/strip-struct-arrays.factor Normal file
View File

@ -0,0 +1,13 @@
USING: kernel stack-checker.transforms ;
IN: struct-arrays
: struct-element-constructor ( c-type -- word )
"Struct array usages must be compiled" throw ;
<<
\ struct-element-constructor [
(struct-element-constructor) [ ] curry
] 1 define-transform
>>

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

@ -614,8 +614,8 @@ M: windows-ui-backend do-events
: default-position-RECT ( RECT -- RECT' )
dup get-RECT-width/height
[ CW_USEDEFAULT + >>bottom ] dip
CW_USEDEFAULT + >>right
[ CW_USEDEFAULT + >>right ] dip
CW_USEDEFAULT + >>bottom
CW_USEDEFAULT >>left
CW_USEDEFAULT >>top ;
@ -758,7 +758,7 @@ M: windows-ui-backend beep ( -- )
: client-area>RECT ( hwnd -- RECT )
RECT <struct>
[ GetClientRect win32-error=0/f ]
[ "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
[ >c-ptr "POINT" byte-array>struct-array [ ClientToScreen drop ] with each ]
[ nip ] 2tri ;
: hwnd>RECT ( hwnd -- RECT )

27
basis/unix/bsd/bsd.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2005, 2006 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax combinators system vocabs.loader ;
USING: alien.syntax classes.struct combinators system
vocabs.loader ;
IN: unix
CONSTANT: MAXPATHLEN 1024
@ -46,18 +47,18 @@ C-STRUCT: sockaddr-un
{ "uchar" "family" }
{ { "char" 104 } "path" } ;
C-STRUCT: passwd
{ "char*" "pw_name" }
{ "char*" "pw_passwd" }
{ "uid_t" "pw_uid" }
{ "gid_t" "pw_gid" }
{ "time_t" "pw_change" }
{ "char*" "pw_class" }
{ "char*" "pw_gecos" }
{ "char*" "pw_dir" }
{ "char*" "pw_shell" }
{ "time_t" "pw_expire" }
{ "int" "pw_fields" } ;
STRUCT: passwd
{ pw_name char* }
{ pw_passwd char* }
{ pw_uid uid_t }
{ pw_gid gid_t }
{ pw_change time_t }
{ pw_class char* }
{ pw_gecos char* }
{ pw_dir char* }
{ pw_shell char* }
{ pw_expire time_t }
{ pw_fields int } ;
CONSTANT: max-un-path 104

43
basis/unix/groups/groups.factor
View File

@ -1,12 +1,14 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings io.encodings.utf8
io.backend.unix kernel math sequences splitting unix strings
io.backend.unix kernel math sequences splitting strings
combinators.short-circuit byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
unix.users unix.utilities ;
unix.users unix.utilities classes.struct ;
IN: unix.groups
QUALIFIED: unix
QUALIFIED: grouping
TUPLE: group id name passwd members ;
@ -18,27 +20,27 @@ GENERIC: group-struct ( obj -- group/f )
<PRIVATE
: group-members ( group-struct -- seq )
group-gr_mem utf8 alien>strings ;
gr_mem>> utf8 alien>strings ;
: (group-struct) ( id -- group-struct id group-struct byte-array length void* )
"group" <c-object> tuck 4096
\ unix:group <struct> tuck 4096
[ <byte-array> ] keep f <void*> ;
: check-group-struct ( group-struct ptr -- group-struct/f )
*void* [ drop f ] unless ;
M: integer group-struct ( id -- group/f )
(group-struct) [ getgrgid_r io-error ] keep check-group-struct ;
(group-struct) [ unix:getgrgid_r unix:io-error ] keep check-group-struct ;
M: string group-struct ( string -- group/f )
(group-struct) [ getgrnam_r io-error ] keep check-group-struct ;
(group-struct) [ unix:getgrnam_r unix:io-error ] keep check-group-struct ;
: group-struct>group ( group-struct -- group )
[ \ group new ] dip
{
[ group-gr_name >>name ]
[ group-gr_passwd >>passwd ]
[ group-gr_gid >>id ]
[ gr_name>> >>name ]
[ gr_passwd>> >>passwd ]
[ gr_gid>> >>id ]
[ group-members >>members ]
} cleave ;
@ -48,12 +50,12 @@ PRIVATE>
dup group-cache get [
?at [ name>> ] [ number>string ] if
] [
group-struct [ group-gr_name ] [ f ] if*
group-struct [ gr_name>> ] [ f ] if*
] if*
[ nip ] [ number>string ] if* ;
: group-id ( string -- id/f )
group-struct [ group-gr_gid ] [ f ] if* ;
group-struct [ gr_gid>> ] [ f ] if* ;
<PRIVATE
@ -62,8 +64,8 @@ PRIVATE>
: (user-groups) ( string -- seq )
#! first group is -1337, legacy unix code
-1337 NGROUPS_MAX [ 4 * <byte-array> ] keep
<int> [ getgrouplist io-error ] 2keep
-1337 unix:NGROUPS_MAX [ 4 * <byte-array> ] keep
<int> [ unix:getgrouplist unix:io-error ] 2keep
[ 4 tail-slice ] [ *int 1 - ] bi* >groups ;
PRIVATE>
@ -77,7 +79,7 @@ M: integer user-groups ( id -- seq )
user-name (user-groups) ;
: all-groups ( -- seq )
[ getgrent dup ] [ group-struct>group ] produce nip ;
[ unix:getgrent dup ] [ \ unix:group memory>struct group-struct>group ] produce nip ;
: <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
@ -85,14 +87,11 @@ M: integer user-groups ( id -- seq )
: with-group-cache ( quot -- )
[ <group-cache> group-cache ] dip with-variable ; inline
: real-group-id ( -- id )
getgid ; inline
: real-group-id ( -- id ) unix:getgid ; inline
: real-group-name ( -- string )
real-group-id group-name ; inline
: real-group-name ( -- string ) real-group-id group-name ; inline
: effective-group-id ( -- string )
getegid ; inline
: effective-group-id ( -- string ) unix:getegid ; inline
: effective-group-name ( -- string )
effective-group-id group-name ; inline
@ -112,10 +111,10 @@ GENERIC: set-effective-group ( obj -- )
<PRIVATE
: (set-real-group) ( id -- )
setgid io-error ; inline
unix:setgid unix:io-error ; inline
: (set-effective-group) ( id -- )
setegid io-error ; inline
unix:setegid unix:io-error ; inline
PRIVATE>

16
basis/unix/linux/linux.factor
View File

@ -84,14 +84,14 @@ CONSTANT: SEEK_SET 0
CONSTANT: SEEK_CUR 1
CONSTANT: SEEK_END 2
C-STRUCT: passwd
{ "char*" "pw_name" }
{ "char*" "pw_passwd" }
{ "uid_t" "pw_uid" }
{ "gid_t" "pw_gid" }
{ "char*" "pw_gecos" }
{ "char*" "pw_dir" }
{ "char*" "pw_shell" } ;
STRUCT: passwd
{ pw_name char* }
{ pw_passwd char* }
{ pw_uid uid_t }
{ pw_gid gid_t }
{ pw_gecos char* }
{ pw_dir char* }
{ pw_shell char* } ;
! dirent64
STRUCT: dirent

26
basis/unix/unix.factor
View File

@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc
sequences continuations byte-arrays strings math namespaces
system combinators vocabs.loader accessors
stack-checker macros locals generalizations unix.types
io vocabs ;
io vocabs classes.struct ;
IN: unix
CONSTANT: PROT_NONE 0
@ -35,11 +35,11 @@ CONSTANT: DT_LNK 10
CONSTANT: DT_SOCK 12
CONSTANT: DT_WHT 14
C-STRUCT: group
{ "char*" "gr_name" }
{ "char*" "gr_passwd" }
{ "int" "gr_gid" }
{ "char**" "gr_mem" } ;
STRUCT: group
{ gr_name char* }
{ gr_passwd char* }
{ gr_gid int }
{ gr_mem char** } ;
LIBRARY: libc
@ -147,18 +147,18 @@ M: unix open-file [ open ] unix-system-call ;
FUNCTION: DIR* opendir ( char* path ) ;
C-STRUCT: utimbuf
{ "time_t" "actime" }
{ "time_t" "modtime" } ;
STRUCT: utimbuf
{ actime time_t }
{ modtime time_t } ;
FUNCTION: int utime ( char* path, utimebuf* buf ) ;
FUNCTION: int utime ( char* path, utimbuf* buf ) ;
: touch ( filename -- ) f [ utime ] unix-system-call drop ;
: change-file-times ( filename access modification -- )
"utimebuf" <c-object>
[ set-utimbuf-modtime ] keep
[ set-utimbuf-actime ] keep
utimbuf <struct>
swap >>modtime
swap >>actime
[ utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;

13
basis/unix/users/bsd/bsd.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators accessors kernel unix unix.users
USING: combinators accessors kernel unix.users
system ;
IN: unix.users.bsd
QUALIFIED: unix
TUPLE: bsd-passwd < passwd change class expire fields ;
@ -11,9 +12,9 @@ M: bsd new-passwd ( -- bsd-passwd ) bsd-passwd new ;
M: bsd passwd>new-passwd ( passwd -- bsd-passwd )
[ call-next-method ] keep
{
[ passwd-pw_change >>change ]
[ passwd-pw_class >>class ]
[ passwd-pw_shell >>shell ]
[ passwd-pw_expire >>expire ]
[ passwd-pw_fields >>fields ]
[ pw_change>> >>change ]
[ pw_class>> >>class ]
[ pw_shell>> >>shell ]
[ pw_expire>> >>expire ]
[ pw_fields>> >>fields ]
} cleave ;

35
basis/unix/users/users.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings io.encodings.utf8
io.backend.unix kernel math sequences splitting unix strings
io.backend.unix kernel math sequences splitting strings
combinators.short-circuit grouping byte-arrays combinators
accessors math.parser fry assocs namespaces continuations
vocabs.loader system ;
vocabs.loader system classes.struct ;
IN: unix.users
QUALIFIED: unix
TUPLE: passwd user-name password uid gid gecos dir shell ;
@ -20,23 +21,23 @@ M: unix new-passwd ( -- passwd )
M: unix passwd>new-passwd ( passwd -- seq )
[ new-passwd ] dip
{
[ passwd-pw_name >>user-name ]
[ passwd-pw_passwd >>password ]
[ passwd-pw_uid >>uid ]
[ passwd-pw_gid >>gid ]
[ passwd-pw_gecos >>gecos ]
[ passwd-pw_dir >>dir ]
[ passwd-pw_shell >>shell ]
[ pw_name>> >>user-name ]
[ pw_passwd>> >>password ]
[ pw_uid>> >>uid ]
[ pw_gid>> >>gid ]
[ pw_gecos>> >>gecos ]
[ pw_dir>> >>dir ]
[ pw_shell>> >>shell ]
} cleave ;
: with-pwent ( quot -- )
[ endpwent ] [ ] cleanup ; inline
[ unix:endpwent ] [ ] cleanup ; inline
PRIVATE>
: all-users ( -- seq )
[
[ getpwent dup ] [ passwd>new-passwd ] produce nip
[ unix:getpwent dup ] [ unix:passwd memory>struct passwd>new-passwd ] produce nip
] with-pwent ;
SYMBOL: user-cache
@ -51,10 +52,10 @@ GENERIC: user-passwd ( obj -- passwd/f )
M: integer user-passwd ( id -- passwd/f )
user-cache get
[ at ] [ getpwuid [ passwd>new-passwd ] [ f ] if* ] if* ;
[ at ] [ unix:getpwuid [ unix:passwd memory>struct passwd>new-passwd ] [ f ] if* ] if* ;
M: string user-passwd ( string -- passwd/f )
getpwnam dup [ passwd>new-passwd ] when ;
unix:getpwnam dup [ unix:passwd memory>struct passwd>new-passwd ] when ;
: user-name ( id -- string )
dup user-passwd
@ -64,13 +65,13 @@ M: string user-passwd ( string -- passwd/f )
user-passwd uid>> ;
: real-user-id ( -- id )
getuid ; inline
unix:getuid ; inline
: real-user-name ( -- string )
real-user-id user-name ; inline
: effective-user-id ( -- id )
geteuid ; inline
unix:geteuid ; inline
: effective-user-name ( -- string )
effective-user-id user-name ; inline
@ -92,10 +93,10 @@ GENERIC: set-effective-user ( string/id -- )
<PRIVATE
: (set-real-user) ( id -- )
setuid io-error ; inline
unix:setuid unix:io-error ; inline
: (set-effective-user) ( id -- )
seteuid io-error ; inline
unix:seteuid unix:io-error ; inline
PRIVATE>

3
basis/windows/com/wrapper/wrapper.factor
View File

@ -3,7 +3,8 @@ init windows.com.syntax.private windows.com continuations kernel
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations sets
specialized-arrays.alien specialized-arrays.direct.alien ;
specialized-arrays.alien specialized-arrays.direct.alien
windows.kernel32 ;
IN: windows.com.wrapper
TUPLE: com-wrapper < disposable callbacks vtbls ;

32
basis/windows/dinput/constants/constants.factor
View File

@ -2,7 +2,7 @@ USING: windows.dinput windows.kernel32 windows.ole32 windows.com
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
combinators sequences fry math accessors macros words quotations
libc continuations generalizations splitting locals assocs init
struct-arrays memoize ;
struct-arrays memoize classes.struct ;
IN: windows.dinput.constants
! Some global variables aren't provided by the DirectInput DLL (they're in the
@ -38,14 +38,6 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
: (flags) ( array -- n )
0 [ (flag) bitor ] reduce ;
: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien )
[ {
[ set-DIOBJECTDATAFORMAT-dwFlags ]
[ set-DIOBJECTDATAFORMAT-dwType ]
[ set-DIOBJECTDATAFORMAT-dwOfs ]
[ set-DIOBJECTDATAFORMAT-pguid ]
} cleave ] keep ;
: <DIOBJECTDATAFORMAT> ( struct {pguid-var,field,index,dwType-flags,dwFlags} -- alien )
{
[ first dup word? [ get ] when ]
@ -54,10 +46,10 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
[ fourth (flags) ]
[ 4 swap nth (flag) ]
} cleave
"DIOBJECTDATAFORMAT" <c-object> (DIOBJECTDATAFORMAT) ;
DIOBJECTDATAFORMAT <struct-boa> ;
:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
[let | alien [ array length "DIOBJECTDATAFORMAT" malloc-struct-array ] |
[let | alien [ array length DIOBJECTDATAFORMAT malloc-struct-array ] |
array [| args i |
struct args <DIOBJECTDATAFORMAT>
i alien set-nth
@ -65,22 +57,10 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
alien
] ;
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
[
{
[ set-DIDATAFORMAT-rgodf ]
[ set-DIDATAFORMAT-dwNumObjs ]
[ set-DIDATAFORMAT-dwDataSize ]
[ set-DIDATAFORMAT-dwFlags ]
[ set-DIDATAFORMAT-dwObjSize ]
[ set-DIDATAFORMAT-dwSize ]
} cleave
] keep ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip
[ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
[ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
"DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
DIDATAFORMAT <struct-boa> ;
: initialize ( symbol quot -- )
call swap set-global ; inline
@ -861,7 +841,7 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
{
c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
} [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
} [ [ rgodf>> free ] uninitialize ] each ;
PRIVATE>

463
basis/windows/dinput/dinput.factor
View File

@ -1,5 +1,6 @@
USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax
alien alien.c-types alien.syntax kernel system namespaces math ;
alien alien.c-types alien.syntax kernel system namespaces math
classes.struct ;
IN: windows.dinput
LIBRARY: dinput
@ -35,291 +36,293 @@ TYPEDEF: void* LPDIENUMDEVICEOBJECTSCALLBACKW
TYPEDEF: DWORD D3DCOLOR
C-STRUCT: DIDEVICEINSTANCEW
{ "DWORD" "dwSize" }
{ "GUID" "guidInstance" }
{ "GUID" "guidProduct" }
{ "DWORD" "dwDevType" }
{ "WCHAR[260]" "tszInstanceName" }
{ "WCHAR[260]" "tszProductName" }
{ "GUID" "guidFFDriver" }
{ "WORD" "wUsagePage" }
{ "WORD" "wUsage" } ;
STRUCT: DIDEVICEINSTANCEW
{ dwSize DWORD }
{ guidInstance GUID }
{ guidProduct GUID }
{ dwDevType DWORD }
{ tszInstanceName WCHAR[260] }
{ tszProductName WCHAR[260] }
{ guidFFDriver GUID }
{ wUsagePage WORD }
{ wUsage WORD } ;
TYPEDEF: DIDEVICEINSTANCEW* LPDIDEVICEINSTANCEW
TYPEDEF: DIDEVICEINSTANCEW* LPCDIDEVICEINSTANCEW
C-UNION: DIACTION-union "LPCWSTR" "UINT" ;
C-STRUCT: DIACTIONW
{ "UINT_PTR" "uAppData" }
{ "DWORD" "dwSemantic" }
{ "DWORD" "dwFlags" }
{ "DIACTION-union" "lptszActionName-or-uResIdString" }
{ "GUID" "guidInstance" }
{ "DWORD" "dwObjID" }
{ "DWORD" "dwHow" } ;
UNION-STRUCT: DIACTION-union
{ lptszActionName LPCWSTR }
{ uResIdString UINT } ;
STRUCT: DIACTIONW
{ uAppData UINT_PTR }
{ dwSemantic DWORD }
{ dwFlags DWORD }
{ union DIACTION-union }
{ guidInstance GUID }
{ dwObjID DWORD }
{ dwHow DWORD } ;
TYPEDEF: DIACTIONW* LPDIACTIONW
TYPEDEF: DIACTIONW* LPCDIACTIONW
C-STRUCT: DIACTIONFORMATW
{ "DWORD" "dwSize" }
{ "DWORD" "dwActionSize" }
{ "DWORD" "dwDataSize" }
{ "DWORD" "dwNumActions" }
{ "LPDIACTIONW" "rgoAction" }
{ "GUID" "guidActionMap" }
{ "DWORD" "dwGenre" }
{ "DWORD" "dwBufferSize" }
{ "LONG" "lAxisMin" }
{ "LONG" "lAxisMax" }
{ "HINSTANCE" "hInstString" }
{ "FILETIME" "ftTimeStamp" }
{ "DWORD" "dwCRC" }
{ "WCHAR[260]" "tszActionMap" } ;
STRUCT: DIACTIONFORMATW
{ dwSize DWORD }
{ dwActionSize DWORD }
{ dwDataSize DWORD }
{ dwNumActions DWORD }
{ rgoAction LPDIACTIONW }
{ guidActionMap GUID }
{ dwGenre DWORD }
{ dwBufferSize DWORD }
{ lAxisMin LONG }
{ lAxisMax LONG }
{ hInstString HINSTANCE }
{ ftTimeStamp FILETIME }
{ dwCRC DWORD }
{ tszActionMap WCHAR[260] } ;
TYPEDEF: DIACTIONFORMATW* LPDIACTIONFORMATW
TYPEDEF: DIACTIONFORMATW* LPCDIACTIONFORMATW
C-STRUCT: DICOLORSET
{ "DWORD" "dwSize" }
{ "D3DCOLOR" "cTextFore" }
{ "D3DCOLOR" "cTextHighlight" }
{ "D3DCOLOR" "cCalloutLine" }
{ "D3DCOLOR" "cCalloutHighlight" }
{ "D3DCOLOR" "cBorder" }
{ "D3DCOLOR" "cControlFill" }
{ "D3DCOLOR" "cHighlightFill" }
{ "D3DCOLOR" "cAreaFill" } ;
STRUCT: DICOLORSET
{ dwSize DWORD }
{ cTextFore D3DCOLOR }
{ cTextHighlight D3DCOLOR }
{ cCalloutLine D3DCOLOR }
{ cCalloutHighlight D3DCOLOR }
{ cBorder D3DCOLOR }
{ cControlFill D3DCOLOR }
{ cHighlightFill D3DCOLOR }
{ cAreaFill D3DCOLOR } ;
TYPEDEF: DICOLORSET* LPDICOLORSET
TYPEDEF: DICOLORSET* LPCDICOLORSET
C-STRUCT: DICONFIGUREDEVICESPARAMSW
{ "DWORD" "dwSize" }
{ "DWORD" "dwcUsers" }
{ "LPWSTR" "lptszUserNames" }
{ "DWORD" "dwcFormats" }
{ "LPDIACTIONFORMATW" "lprgFormats" }
{ "HWND" "hwnd" }
{ "DICOLORSET" "dics" }
{ "IUnknown*" "lpUnkDDSTarget" } ;
STRUCT: DICONFIGUREDEVICESPARAMSW
{ dwSize DWORD }
{ dwcUsers DWORD }
{ lptszUserNames LPWSTR }
{ dwcFormats DWORD }
{ lprgFormats LPDIACTIONFORMATW }
{ hwnd HWND }
{ dics DICOLORSET }
{ lpUnkDDSTarget IUnknown* } ;
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
C-STRUCT: DIDEVCAPS
{ "DWORD" "dwSize" }
{ "DWORD" "dwFlags" }
{ "DWORD" "dwDevType" }
{ "DWORD" "dwAxes" }
{ "DWORD" "dwButtons" }
{ "DWORD" "dwPOVs" }
{ "DWORD" "dwFFSamplePeriod" }
{ "DWORD" "dwFFMinTimeResolution" }
{ "DWORD" "dwFirmwareRevision" }
{ "DWORD" "dwHardwareRevision" }
{ "DWORD" "dwFFDriverVersion" } ;
STRUCT: DIDEVCAPS
{ dwSize DWORD }
{ dwFlags DWORD }
{ dwDevType DWORD }
{ dwAxes DWORD }
{ dwButtons DWORD }
{ dwPOVs DWORD }
{ dwFFSamplePeriod DWORD }
{ dwFFMinTimeResolution DWORD }
{ dwFirmwareRevision DWORD }
{ dwHardwareRevision DWORD }
{ dwFFDriverVersion DWORD } ;
TYPEDEF: DIDEVCAPS* LPDIDEVCAPS
TYPEDEF: DIDEVCAPS* LPCDIDEVCAPS
C-STRUCT: DIDEVICEOBJECTINSTANCEW
{ "DWORD" "dwSize" }
{ "GUID" "guidType" }
{ "DWORD" "dwOfs" }
{ "DWORD" "dwType" }
{ "DWORD" "dwFlags" }
{ "WCHAR[260]" "tszName" }
{ "DWORD" "dwFFMaxForce" }
{ "DWORD" "dwFFForceResolution" }
{ "WORD" "wCollectionNumber" }
{ "WORD" "wDesignatorIndex" }
{ "WORD" "wUsagePage" }
{ "WORD" "wUsage" }
{ "DWORD" "dwDimension" }
{ "WORD" "wExponent" }
{ "WORD" "wReportId" } ;
STRUCT: DIDEVICEOBJECTINSTANCEW
{ dwSize DWORD }
{ guidType GUID }
{ dwOfs DWORD }
{ dwType DWORD }
{ dwFlags DWORD }
{ tszName WCHAR[260] }
{ dwFFMaxForce DWORD }
{ dwFFForceResolution DWORD }
{ wCollectionNumber WORD }
{ wDesignatorIndex WORD }
{ wUsagePage WORD }
{ wUsage WORD }
{ dwDimension DWORD }
{ wExponent WORD }
{ wReportId WORD } ;
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPDIDEVICEOBJECTINSTANCEW
TYPEDEF: DIDEVICEOBJECTINSTANCEW* LPCDIDEVICEOBJECTINSTANCEW
C-STRUCT: DIDEVICEOBJECTDATA
{ "DWORD" "dwOfs" }
{ "DWORD" "dwData" }
{ "DWORD" "dwTimeStamp" }
{ "DWORD" "dwSequence" }
{ "UINT_PTR" "uAppData" } ;
STRUCT: DIDEVICEOBJECTDATA
{ dwOfs DWORD }
{ dwData DWORD }
{ dwTimeStamp DWORD }
{ dwSequence DWORD }
{ uAppData UINT_PTR } ;
TYPEDEF: DIDEVICEOBJECTDATA* LPDIDEVICEOBJECTDATA
TYPEDEF: DIDEVICEOBJECTDATA* LPCDIDEVICEOBJECTDATA
C-STRUCT: DIOBJECTDATAFORMAT
{ "GUID*" "pguid" }
{ "DWORD" "dwOfs" }
{ "DWORD" "dwType" }
{ "DWORD" "dwFlags" } ;
STRUCT: DIOBJECTDATAFORMAT
{ pguid GUID* }
{ dwOfs DWORD }
{ dwType DWORD }
{ dwFlags DWORD } ;
TYPEDEF: DIOBJECTDATAFORMAT* LPDIOBJECTDATAFORMAT
TYPEDEF: DIOBJECTDATAFORMAT* LPCDIOBJECTDATAFORMAT
C-STRUCT: DIDATAFORMAT
{ "DWORD" "dwSize" }
{ "DWORD" "dwObjSize" }
{ "DWORD" "dwFlags" }
{ "DWORD" "dwDataSize" }
{ "DWORD" "dwNumObjs" }
{ "LPDIOBJECTDATAFORMAT" "rgodf" } ;
STRUCT: DIDATAFORMAT
{ dwSize DWORD }
{ dwObjSize DWORD }
{ dwFlags DWORD }
{ dwDataSize DWORD }
{ dwNumObjs DWORD }
{ rgodf LPDIOBJECTDATAFORMAT } ;
TYPEDEF: DIDATAFORMAT* LPDIDATAFORMAT
TYPEDEF: DIDATAFORMAT* LPCDIDATAFORMAT
C-STRUCT: DIPROPHEADER
{ "DWORD" "dwSize" }
{ "DWORD" "dwHeaderSize" }
{ "DWORD" "dwObj" }
{ "DWORD" "dwHow" } ;
STRUCT: DIPROPHEADER
{ dwSize DWORD }
{ dwHeaderSize DWORD }
{ dwObj DWORD }
{ dwHow DWORD } ;
TYPEDEF: DIPROPHEADER* LPDIPROPHEADER
TYPEDEF: DIPROPHEADER* LPCDIPROPHEADER
C-STRUCT: DIPROPDWORD
{ "DIPROPHEADER" "diph" }
{ "DWORD" "dwData" } ;
STRUCT: DIPROPDWORD
{ diph DIPROPHEADER }
{ dwData DWORD } ;
TYPEDEF: DIPROPDWORD* LPDIPROPDWORD
TYPEDEF: DIPROPDWORD* LPCDIPROPDWORD
C-STRUCT: DIPROPPOINTER
{ "DIPROPHEADER" "diph" }
{ "UINT_PTR" "uData" } ;
STRUCT: DIPROPPOINTER
{ diph DIPROPHEADER }
{ uData UINT_PTR } ;
TYPEDEF: DIPROPPOINTER* LPDIPROPPOINTER
TYPEDEF: DIPROPPOINTER* LPCDIPROPPOINTER
C-STRUCT: DIPROPRANGE
{ "DIPROPHEADER" "diph" }
{ "LONG" "lMin" }
{ "LONG" "lMax" } ;
STRUCT: DIPROPRANGE
{ diph DIPROPHEADER }
{ lMin LONG }
{ lMax LONG } ;
TYPEDEF: DIPROPRANGE* LPDIPROPRANGE
TYPEDEF: DIPROPRANGE* LPCDIPROPRANGE
C-STRUCT: DIPROPCAL
{ "DIPROPHEADER" "diph" }
{ "LONG" "lMin" }
{ "LONG" "lCenter" }
{ "LONG" "lMax" } ;
STRUCT: DIPROPCAL
{ diph DIPROPHEADER }
{ lMin LONG }
{ lCenter LONG }
{ lMax LONG } ;
TYPEDEF: DIPROPCAL* LPDIPROPCAL
TYPEDEF: DIPROPCAL* LPCDIPROPCAL
C-STRUCT: DIPROPGUIDANDPATH
{ "DIPROPHEADER" "diph" }
{ "GUID" "guidClass" }
{ "WCHAR[260]" "wszPath" } ;
STRUCT: DIPROPGUIDANDPATH
{ diph DIPROPHEADER }
{ guidClass GUID }
{ wszPath WCHAR[260] } ;
TYPEDEF: DIPROPGUIDANDPATH* LPDIPROPGUIDANDPATH
TYPEDEF: DIPROPGUIDANDPATH* LPCDIPROPGUIDANDPATH
C-STRUCT: DIPROPSTRING
{ "DIPROPHEADER" "diph" }
{ "WCHAR[260]" "wsz" } ;
STRUCT: DIPROPSTRING
{ diph DIPROPHEADER }
{ wsz WCHAR[260] } ;
TYPEDEF: DIPROPSTRING* LPDIPROPSTRING
TYPEDEF: DIPROPSTRING* LPCDIPROPSTRING
C-STRUCT: CPOINT
{ "LONG" "lP" }
{ "DWORD" "dwLog" } ;
C-STRUCT: DIPROPCPOINTS
{ "DIPROPHEADER" "diph" }
{ "DWORD" "dwCPointsNum" }
{ "CPOINT[8]" "cp" } ;
STRUCT: CPOINT
{ lP LONG }
{ dwLog DWORD } ;
STRUCT: DIPROPCPOINTS
{ diph DIPROPHEADER }
{ dwCPointsNum DWORD }
{ cp CPOINT[8] } ;
TYPEDEF: DIPROPCPOINTS* LPDIPROPCPOINTS
TYPEDEF: DIPROPCPOINTS* LPCDIPROPCPOINTS
C-STRUCT: DIENVELOPE
{ "DWORD" "dwSize" }
{ "DWORD" "dwAttackLevel" }
{ "DWORD" "dwAttackTime" }
{ "DWORD" "dwFadeLevel" }
{ "DWORD" "dwFadeTime" } ;
STRUCT: DIENVELOPE
{ dwSize DWORD }
{ dwAttackLevel DWORD }
{ dwAttackTime DWORD }
{ dwFadeLevel DWORD }
{ dwFadeTime DWORD } ;
TYPEDEF: DIENVELOPE* LPDIENVELOPE
TYPEDEF: DIENVELOPE* LPCDIENVELOPE
C-STRUCT: DIEFFECT
{ "DWORD" "dwSize" }
{ "DWORD" "dwFlags" }
{ "DWORD" "dwDuration" }
{ "DWORD" "dwSamplePeriod" }
{ "DWORD" "dwGain" }
{ "DWORD" "dwTriggerButton" }
{ "DWORD" "dwTriggerRepeatInterval" }
{ "DWORD" "cAxes" }
{ "LPDWORD" "rgdwAxes" }
{ "LPLONG" "rglDirection" }
{ "LPDIENVELOPE" "lpEnvelope" }
{ "DWORD" "cbTypeSpecificParams" }
{ "LPVOID" "lpvTypeSpecificParams" }
{ "DWORD" "dwStartDelay" } ;
STRUCT: DIEFFECT
{ dwSize DWORD }
{ dwFlags DWORD }
{ dwDuration DWORD }
{ dwSamplePeriod DWORD }
{ dwGain DWORD }
{ dwTriggerButton DWORD }
{ dwTriggerRepeatInterval DWORD }
{ cAxes DWORD }
{ rgdwAxes LPDWORD }
{ rglDirection LPLONG }
{ lpEnvelope LPDIENVELOPE }
{ cbTypeSpecificParams DWORD }
{ lpvTypeSpecificParams LPVOID }
{ dwStartDelay DWORD } ;
TYPEDEF: DIEFFECT* LPDIEFFECT
TYPEDEF: DIEFFECT* LPCDIEFFECT
C-STRUCT: DIEFFECTINFOW
{ "DWORD" "dwSize" }
{ "GUID" "guid" }
{ "DWORD" "dwEffType" }
{ "DWORD" "dwStaticParams" }
{ "DWORD" "dwDynamicParams" }
{ "WCHAR[260]" "tszName" } ;
STRUCT: DIEFFECTINFOW
{ dwSize DWORD }
{ guid GUID }
{ dwEffType DWORD }
{ dwStaticParams DWORD }
{ dwDynamicParams DWORD }
{ tszName WCHAR[260] } ;
TYPEDEF: DIEFFECTINFOW* LPDIEFFECTINFOW
TYPEDEF: DIEFFECTINFOW* LPCDIEFFECTINFOW
C-STRUCT: DIEFFESCAPE
{ "DWORD" "dwSize" }
{ "DWORD" "dwCommand" }
{ "LPVOID" "lpvInBuffer" }
{ "DWORD" "cbInBuffer" }
{ "LPVOID" "lpvOutBuffer" }
{ "DWORD" "cbOutBuffer" } ;
STRUCT: DIEFFESCAPE
{ dwSize DWORD }
{ dwCommand DWORD }
{ lpvInBuffer LPVOID }
{ cbInBuffer DWORD }
{ lpvOutBuffer LPVOID }
{ cbOutBuffer DWORD } ;
TYPEDEF: DIEFFESCAPE* LPDIEFFESCAPE
TYPEDEF: DIEFFESCAPE* LPCDIEFFESCAPE
C-STRUCT: DIFILEEFFECT
{ "DWORD" "dwSize" }
{ "GUID" "GuidEffect" }
{ "LPCDIEFFECT" "lpDiEffect" }
{ "CHAR[260]" "szFriendlyName" } ;
STRUCT: DIFILEEFFECT
{ dwSize DWORD }
{ GuidEffect GUID }
{ lpDiEffect LPCDIEFFECT }
{ szFriendlyName CHAR[260] } ;
TYPEDEF: DIFILEEFFECT* LPDIFILEEFFECT
TYPEDEF: DIFILEEFFECT* LPCDIFILEEFFECT
C-STRUCT: DIDEVICEIMAGEINFOW
{ "WCHAR[260]" "tszImagePath" }
{ "DWORD" "dwFlags" }
{ "DWORD" "dwViewID" }
{ "RECT" "rcOverlay" }
{ "DWORD" "dwObjID" }
{ "DWORD" "dwcValidPts" }
{ "POINT[5]" "rgptCalloutLine" }
{ "RECT" "rcCalloutRect" }
{ "DWORD" "dwTextAlign" } ;
STRUCT: DIDEVICEIMAGEINFOW
{ tszImagePath WCHAR[260] }
{ dwFlags DWORD }
{ dwViewID DWORD }
{ rcOverlay RECT }
{ dwObjID DWORD }
{ dwcValidPts DWORD }
{ rgptCalloutLine POINT[5] }
{ rcCalloutRect RECT }
{ dwTextAlign DWORD } ;
TYPEDEF: DIDEVICEIMAGEINFOW* LPDIDEVICEIMAGEINFOW
TYPEDEF: DIDEVICEIMAGEINFOW* LPCDIDEVICEIMAGEINFOW
C-STRUCT: DIDEVICEIMAGEINFOHEADERW
{ "DWORD" "dwSize" }
{ "DWORD" "dwSizeImageInfo" }
{ "DWORD" "dwcViews" }
{ "DWORD" "dwcButtons" }
{ "DWORD" "dwcAxes" }
{ "DWORD" "dwcPOVs" }
{ "DWORD" "dwBufferSize" }
{ "DWORD" "dwBufferUsed" }
{ "DIDEVICEIMAGEINFOW*" "lprgImageInfoArray" } ;
STRUCT: DIDEVICEIMAGEINFOHEADERW
{ dwSize DWORD }
{ dwSizeImageInfo DWORD }
{ dwcViews DWORD }
{ dwcButtons DWORD }
{ dwcAxes DWORD }
{ dwcPOVs DWORD }
{ dwBufferSize DWORD }
{ dwBufferUsed DWORD }
{ lprgImageInfoArray DIDEVICEIMAGEINFOW* } ;
TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPDIDEVICEIMAGEINFOHEADERW
TYPEDEF: DIDEVICEIMAGEINFOHEADERW* LPCDIDEVICEIMAGEINFOHEADERW
C-STRUCT: DIMOUSESTATE2
{ "LONG" "lX" }
{ "LONG" "lY" }
{ "LONG" "lZ" }
{ "BYTE[8]" "rgbButtons" } ;
STRUCT: DIMOUSESTATE2
{ lX LONG }
{ lY LONG }
{ lZ LONG }
{ rgbButtons BYTE[8] } ;
TYPEDEF: DIMOUSESTATE2* LPDIMOUSESTATE2
TYPEDEF: DIMOUSESTATE2* LPCDIMOUSESTATE2
C-STRUCT: DIJOYSTATE2
{ "LONG" "lX" }
{ "LONG" "lY" }
{ "LONG" "lZ" }
{ "LONG" "lRx" }
{ "LONG" "lRy" }
{ "LONG" "lRz" }
{ "LONG[2]" "rglSlider" }
{ "DWORD[4]" "rgdwPOV" }
{ "BYTE[128]" "rgbButtons" }
{ "LONG" "lVX" }
{ "LONG" "lVY" }
{ "LONG" "lVZ" }
{ "LONG" "lVRx" }
{ "LONG" "lVRy" }
{ "LONG" "lVRz" }
{ "LONG[2]" "rglVSlider" }
{ "LONG" "lAX" }
{ "LONG" "lAY" }
{ "LONG" "lAZ" }
{ "LONG" "lARx" }
{ "LONG" "lARy" }
{ "LONG" "lARz" }
{ "LONG[2]" "rglASlider" }
{ "LONG" "lFX" }
{ "LONG" "lFY" }
{ "LONG" "lFZ" }
{ "LONG" "lFRx" }
{ "LONG" "lFRy" }
{ "LONG" "lFRz" }
{ "LONG[2]" "rglFSlider" } ;
STRUCT: DIJOYSTATE2
{ lX LONG }
{ lY LONG }
{ lZ LONG }
{ lRx LONG }
{ lRy LONG }
{ lRz LONG }
{ rglSlider LONG[2] }
{ rgdwPOV DWORD[4] }
{ rgbButtons BYTE[128] }
{ lVX LONG }
{ lVY LONG }
{ lVZ LONG }
{ lVRx LONG }
{ lVRy LONG }
{ lVRz LONG }
{ rglVSlider LONG[2] }
{ lAX LONG }
{ lAY LONG }
{ lAZ LONG }
{ lARx LONG }
{ lARy LONG }
{ lARz LONG }
{ rglASlider LONG[2] }
{ lFX LONG }
{ lFY LONG }
{ lFZ LONG }
{ lFRx LONG }
{ lFRy LONG }
{ lFRz LONG }
{ rglFSlider LONG[2] } ;
TYPEDEF: DIJOYSTATE2* LPDIJOYSTATE2
TYPEDEF: DIJOYSTATE2* LPCDIJOYSTATE2

9
basis/windows/dragdrop-listener/dragdrop-listener.factor
View File

@ -1,16 +1,19 @@
USING: windows.com windows.com.wrapper combinators
windows.kernel32 windows.ole32 windows.shell32 kernel accessors
USING: alien.strings io.encodings.utf16n windows.com
windows.com.wrapper combinators windows.kernel32 windows.ole32
windows.shell32 kernel accessors
prettyprint namespaces ui.tools.listener ui.tools.workspace
alien.c-types alien sequences math ;
IN: windows.dragdrop-listener
<< "WCHAR" require-c-arrays >>
: filenames-from-hdrop ( hdrop -- filenames )
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files
[
2dup f 0 DragQueryFile 1 + ! get size of filename buffer
dup "WCHAR" <c-array>
[ swap DragQueryFile drop ] keep
alien>u16-string
utf16n alien>string
] with map ;
: filenames-from-data-object ( data-object -- filenames )

6
basis/windows/errors/errors.factor
View File

@ -4,6 +4,8 @@ io.encodings.string io.encodings.utf16n alien.strings
arrays literals ;
IN: windows.errors
<< "TCHAR" require-c-arrays >>
CONSTANT: ERROR_SUCCESS 0
CONSTANT: ERROR_INVALID_FUNCTION 1
CONSTANT: ERROR_FILE_NOT_FOUND 2
@ -696,7 +698,7 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK HEX: 000000FF
: make-lang-id ( lang1 lang2 -- n )
10 shift bitor ; inline
<< "TCHAR" require-c-type-arrays >>
<< "TCHAR" require-c-arrays >>
ERROR: error-message-failed id ;
:: n>win32-error-string ( id -- string )
@ -707,7 +709,7 @@ ERROR: error-message-failed id ;
f
id
LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id
32768 [ "TCHAR" <c-type-array> ] [ ] bi
32768 [ "TCHAR" <c-array> ] [ ] bi
f pick [ FormatMessage 0 = [ id error-message-failed ] when ] dip
utf16n alien>string [ blank? ] trim ;

3
basis/windows/ole32/ole32-tests.factor
View File

@ -1,5 +1,6 @@
USING: kernel tools.test windows.ole32 alien.c-types
classes.struct specialized-arrays.uchar windows.kernel32 ;
classes.struct specialized-arrays.uchar windows.kernel32
windows.com.syntax ;
IN: windows.ole32.tests
[ t ] [

14
basis/windows/shell32/shell32.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.strings alien.syntax
combinators io.encodings.utf16n io.files io.pathnames kernel
windows.errors windows.com windows.com.syntax windows.user32
windows.ole32 windows specialized-arrays.ushort classes.struct ;
classes.struct combinators io.encodings.utf16n io.files
io.pathnames kernel windows.errors windows.com
windows.com.syntax windows.user32 windows.ole32 windows
specialized-arrays.ushort ;
IN: windows.shell32
CONSTANT: CSIDL_DESKTOP HEX: 00
@ -194,10 +195,13 @@ CONSTANT: STRRET_WSTR 0
CONSTANT: STRRET_OFFSET 1
CONSTANT: STRRET_CSTR 2
C-UNION: STRRET-union "LPWSTR" "LPSTR" "UINT" "char[260]" ;
UNION-STRUCT: STRRET-union
{ pOleStr LPWSTR }
{ uOffset UINT }
{ cStr char[260] } ;
STRUCT: STRRET
{ uType int }
{ union STRRET-union } ;
{ value STRRET-union } ;
COM-INTERFACE: IEnumIDList IUnknown {000214F2-0000-0000-C000-000000000046}
HRESULT Next ( ULONG celt, LPITEMIDLIST* rgelt, ULONG* pceltFetched )

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

@ -330,9 +330,7 @@ STRUCT: PIXELFORMATDESCRIPTOR
{ dwDamageMask DWORD } ;
: <RECT> ( loc dim -- RECT )
[ RECT <struct> ] 2dip
[ drop [ first >>left ] [ second >>top ] bi ]
[ v+ [ first >>right ] [ second >>bottom ] bi ] 2bi ;
dupd v+ [ first2 ] bi@ RECT <struct-boa> ;
TYPEDEF: RECT* PRECT
TYPEDEF: RECT* LPRECT

20
core/combinators/combinators-docs.factor
View File

@ -275,7 +275,7 @@ $nl
"The simplest combinators do not take an effect declaration. The compiler checks the stack effect at compile time, rejecting the program if this cannot be done:"
{ $subsection call }
{ $subsection execute }
"The second set of combinators takes an effect declaration. The stack effect of the quotation or word is checked at runtime:"
"The second set of combinators takes an effect declaration. Note that the opening parenthesis is actually part of the word name; these are parsing words, and they read a stack effect until the corresponding closing parenthesis. The stack effect of the quotation or word is then checked at runtime:"
{ $subsection POSTPONE: call( }
{ $subsection POSTPONE: execute( }
"The above are syntax sugar. The underlying words are a bit more verbose but allow non-constant effects to be passed in:"
@ -303,11 +303,25 @@ ABOUT: "combinators"
HELP: call-effect
{ $values { "quot" quotation } { "effect" effect } }
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." }
{ $examples
"The following two lines are equivalent:"
{ $code
"call( a b -- c )"
"(( a b -- c )) call-effect"
}
} ;
HELP: execute-effect
{ $values { "word" word } { "effect" effect } }
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
{ $examples
"The following two lines are equivalent:"
{ $code
"execute( a b -- c )"
"(( a b -- c )) execute-effect"
}
} ;
HELP: execute-effect-unsafe
{ $values { "word" word } { "effect" effect } }

10
core/syntax/syntax-docs.factor
View File

@ -834,6 +834,14 @@ HELP: call(
HELP: execute(
{ $syntax "execute( stack -- effect )" }
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." }
{ $examples
{ $code
"IN: scratchpad"
""
": eat ( -- ) ; : sleep ( -- ) ; : hack ( -- ) ;"
"{ eat sleep hack } [ execute( -- ) ] each"
}
} ;
{ POSTPONE: call( POSTPONE: execute( } related-words

54
extra/benchmark/yuv-to-rgb/yuv-to-rgb.factor
View File

@ -2,50 +2,50 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors alien.c-types alien.syntax byte-arrays
destructors generalizations hints kernel libc locals math math.order
sequences sequences.private ;
sequences sequences.private classes.struct accessors ;
IN: benchmark.yuv-to-rgb
C-STRUCT: yuv_buffer
{ "int" "y_width" }
{ "int" "y_height" }
{ "int" "y_stride" }
{ "int" "uv_width" }
{ "int" "uv_height" }
{ "int" "uv_stride" }
{ "void*" "y" }
{ "void*" "u" }
{ "void*" "v" } ;
STRUCT: yuv_buffer
{ y_width int }
{ y_height int }
{ y_stride int }
{ uv_width int }
{ uv_height int }
{ uv_stride int }
{ y void* }
{ u void* }
{ v void* } ;
:: fake-data ( -- rgb yuv )
[let* | w [ 1600 ]
h [ 1200 ]
buffer [ "yuv_buffer" <c-object> ]
buffer [ yuv_buffer <struct> ]
rgb [ w h * 3 * <byte-array> ] |
w buffer set-yuv_buffer-y_width
h buffer set-yuv_buffer-y_height
h buffer set-yuv_buffer-uv_height
w buffer set-yuv_buffer-y_stride
w buffer set-yuv_buffer-uv_stride
w h * [ dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-y
w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-u
w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free buffer set-yuv_buffer-v
rgb buffer
w >>y_width
h >>y_height
h >>uv_height
w >>y_stride
w >>uv_stride
w h * [ dup * ] B{ } map-as malloc-byte-array &free >>y
w h * 2/ [ dup dup * * ] B{ } map-as malloc-byte-array &free >>u
w h * 2/ [ dup * dup * ] B{ } map-as malloc-byte-array &free >>v
] ;
: clamp ( n -- n )
255 min 0 max ; inline
: stride ( line yuv -- uvy yy )
[ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline
[ uv_stride>> swap 2/ * ] [ y_stride>> * ] 2bi ; inline
: compute-y ( yuv uvy yy x -- y )
+ >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
+ >fixnum nip swap y>> swap alien-unsigned-1 16 - ; inline
: compute-v ( yuv uvy yy x -- v )
nip 2/ + >fixnum swap yuv_buffer-u swap alien-unsigned-1 128 - ; inline
nip 2/ + >fixnum swap u>> swap alien-unsigned-1 128 - ; inline
: compute-u ( yuv uvy yy x -- v )
nip 2/ + >fixnum swap yuv_buffer-v swap alien-unsigned-1 128 - ; inline
nip 2/ + >fixnum swap v>> swap alien-unsigned-1 128 - ; inline
:: compute-yuv ( yuv uvy yy x -- y u v )
yuv uvy yy x compute-y
@ -77,16 +77,16 @@ C-STRUCT: yuv_buffer
: yuv>rgb-row ( index rgb yuv y -- index )
over stride
pick yuv_buffer-y_width
pick y_width>>
[ yuv>rgb-pixel ] with with with with each ; inline
: yuv>rgb ( rgb yuv -- )
[ 0 ] 2dip
dup yuv_buffer-y_height
dup y_height>>
[ yuv>rgb-row ] with with each
drop ;
HINTS: yuv>rgb byte-array byte-array ;
HINTS: yuv>rgb byte-array yuv_buffer ;
: yuv>rgb-benchmark ( -- )
[ fake-data yuv>rgb ] with-destructors ;

35
extra/gpu/demos/bunny/bunny.factor
View File

@ -1,11 +1,11 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien.c-types arrays combinators combinators.short-circuit
game-worlds gpu gpu.buffers gpu.util.wasd gpu.framebuffers gpu.render
gpu.shaders gpu.state gpu.textures gpu.util grouping http.client images
images.loader io io.encodings.ascii io.files io.files.temp
kernel math math.matrices math.parser math.vectors
method-chains sequences specialized-arrays.float specialized-vectors.uint splitting
struct-vectors threads ui ui.gadgets ui.gadgets.worlds
USING: accessors alien.c-types arrays classes.struct combinators
combinators.short-circuit game-worlds gpu gpu.buffers gpu.util.wasd
gpu.framebuffers gpu.render gpu.shaders gpu.state gpu.textures gpu.util
grouping http.client images images.loader io io.encodings.ascii io.files
io.files.temp kernel math math.matrices math.parser math.vectors
method-chains sequences specialized-arrays.float specialized-vectors.uint
splitting struct-vectors threads ui ui.gadgets ui.gadgets.worlds
ui.pixel-formats ;
IN: gpu.demos.bunny
@ -73,9 +73,8 @@ UNIFORM-TUPLE: loading-uniforms
" " split [ string>number ] map sift ;
: <bunny-vertex> ( vertex -- struct )
>float-array
"bunny-vertex-struct" <c-object>
[ set-bunny-vertex-struct-vertex ] keep ;
bunny-vertex-struct <struct>
swap >float-array >>vertex ; inline
: (parse-bunny-model) ( vs is -- vs is )
readln [
@ -87,7 +86,7 @@ UNIFORM-TUPLE: loading-uniforms
] when* ;
: parse-bunny-model ( -- vertexes indexes )
100000 "bunny-vertex-struct" <struct-vector>
100000 bunny-vertex-struct <struct-vector>
100000 <uint-vector>
(parse-bunny-model) ;
@ -98,23 +97,15 @@ UNIFORM-TUPLE: loading-uniforms
: calc-bunny-normal ( vertexes indexes -- )
swap
[ [ nth bunny-vertex-struct-vertex ] curry { } map-as normal ]
[
[
nth [ bunny-vertex-struct-normal v+ ] keep
set-bunny-vertex-struct-normal
] curry with each
] 2bi ;
[ [ nth vertex>> ] curry { } map-as normal ]
[ [ nth [ v+ ] change-normal drop ] curry with each ] 2bi ;
: calc-bunny-normals ( vertexes indexes -- )
3 <groups>
[ calc-bunny-normal ] with each ;
: normalize-bunny-normals ( vertexes -- )
[
[ bunny-vertex-struct-normal normalize ] keep
set-bunny-vertex-struct-normal
] each ;
[ [ normalize ] change-normal drop ] each ;
: bunny-data ( filename -- vertexes indexes )
ascii [ parse-bunny-model ] with-file-reader

4
extra/gpu/shaders/shaders-docs.factor
View File

@ -1,5 +1,5 @@
! (c)2009 Joe Groff bsd license
USING: alien.syntax classes gpu.buffers help.markup help.syntax
USING: classes classes.struct gpu.buffers help.markup help.syntax
images kernel math multiline quotations sequences strings ;
IN: gpu.shaders
@ -51,7 +51,7 @@ HELP: VERTEX-FORMAT:
HELP: VERTEX-STRUCT:
{ $syntax <" VERTEX-STRUCT: struct-name format-name "> }
{ $description "Defines a struct C type (like " { $link POSTPONE: C-STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
{ $description "Defines a struct class (like " { $link POSTPONE: STRUCT: } ") with the same binary format and component types as the given " { $link vertex-format } "." } ;
{ POSTPONE: GLSL-PROGRAM: POSTPONE: GLSL-SHADER-FILE: POSTPONE: GLSL-SHADER: } related-words

26
extra/gpu/shaders/shaders.factor
View File

@ -1,7 +1,7 @@
! (c)2009 Joe Groff bsd license
USING: accessors alien alien.c-types alien.strings
alien.structs arrays assocs byte-arrays classes.mixin
classes.parser classes.singleton combinators
arrays assocs byte-arrays classes.mixin classes.parser
classes.singleton classes.struct combinators
combinators.short-circuit definitions destructors
generic.parser gpu gpu.buffers hashtables images
io.encodings.ascii io.files io.pathnames kernel lexer literals
@ -238,8 +238,8 @@ M: f (verify-feedback-format)
{ uint-integer-components [ "uint" ] }
} case ;
: c-array-dim ( dim -- string )
dup 1 = [ drop "" ] [ number>string "[" "]" surround ] if ;
: c-array-dim ( type dim -- type' )
dup 1 = [ drop ] [ 2array ] if ;
SYMBOL: padding-no
padding-no [ 0 ] initialize
@ -250,11 +250,10 @@ padding-no [ 0 ] initialize
"(" ")" surround
padding-no inc ;
: vertex-attribute>c-type ( vertex-attribute -- {type,name} )
[
[ component-type>> component-type>c-type ]
[ dim>> c-array-dim ] bi append
] [ name>> [ padding-name ] unless* ] bi 2array ;
: vertex-attribute>struct-slot ( vertex-attribute -- struct-slot-spec )
[ name>> [ padding-name ] unless* ]
[ [ component-type>> component-type>c-type ] [ dim>> c-array-dim ] bi ] bi
{ } <struct-slot-spec> ;
: shader-filename ( shader/program -- filename )
dup filename>> [ nip ] [ name>> where first ] if* file-name ;
@ -303,13 +302,12 @@ SYNTAX: VERTEX-FORMAT:
[ first4 vertex-attribute boa ] map
define-vertex-format ;
: define-vertex-struct ( struct-name vertex-format -- )
[ current-vocab ] dip
"vertex-format-attributes" word-prop [ vertex-attribute>c-type ] map
define-struct ;
: define-vertex-struct ( class vertex-format -- )
"vertex-format-attributes" word-prop [ vertex-attribute>struct-slot ] map
define-struct-class ;
SYNTAX: VERTEX-STRUCT:
scan scan-word define-vertex-struct ;
CREATE-CLASS scan-word define-vertex-struct ;
TUPLE: vertex-array < gpu-object
{ program-instance program-instance read-only }

5
extra/system-info/linux/linux.factor
View File

@ -1,14 +1,15 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: unix alien alien.c-types kernel math sequences strings
io.backend.unix splitting io.encodings.utf8 io.encodings.string ;
io.backend.unix splitting io.encodings.utf8 io.encodings.string
specialized-arrays.char ;
IN: system-info.linux
: (uname) ( buf -- int )
"int" f "uname" { "char*" } alien-invoke ;
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
65536 <char-array> [ (uname) io-error ] keep
"\0" split harvest [ utf8 decode ] map
6 "" pad-tail ;

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

@ -3,7 +3,7 @@
USING: alien alien.c-types classes.struct accessors kernel
math namespaces windows windows.kernel32 windows.advapi32 words
combinators vocabs.loader system-info.backend system
alien.strings windows.errors ;
alien.strings windows.errors specialized-arrays.ushort ;
IN: system-info.windows
: system-info ( -- SYSTEM_INFO )
@ -49,11 +49,8 @@ IN: system-info.windows
: sse3? ( -- ? )
PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
: <u16-string-object> ( n -- obj )
"ushort" <c-array> ;
: get-directory ( word -- str )
[ MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd ] dip
[ MAX_UNICODE_PATH [ <ushort-array> ] keep dupd ] dip
execute win32-error=0/f alien>native-string ; inline
: windows-directory ( -- str )