"C type specifiers for array types are documented in " { $link "c-types-specs" } "."\r
$nl\r
"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:"\r
-{ $subsection require-c-type-arrays }\r
-{ $subsection <c-type-array> }\r
-{ $subsection <c-type-direct-array> } ;\r
+{ $subsection require-c-arrays }\r
+{ $subsection <c-array> }\r
+{ $subsection <c-direct-array> } ;\r
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 ] ;
{ $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 } }
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." } ;
{ $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 } }
}
} ;
-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."
align
array-class
array-constructor
+(array)-constructor
direct-array-class
direct-array-constructor
sequence-mixin-class ;
: ?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: string heap-size c-type heap-size ;
+
+M: abstract-c-type heap-size size>> ;
-M: object require-c-type-arrays
+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-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-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 )
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 ;
[ "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
[ "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
! (c)Joe Groff bsd license
-USING: accessors assocs classes classes.struct combinators
-kernel math prettyprint.backend prettyprint.custom
+USING: accessors alien assocs classes classes.struct
+combinators kernel math prettyprint.backend prettyprint.custom
prettyprint.sections see.private sequences strings words ;
IN: classes.struct.prettyprint
} cleave
\ } pprint-word block> ;
+: pprint-struct ( struct -- )
+ [ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
+
+: pprint-struct-pointer ( struct -- )
+ <block
+ \ S@ pprint-word
+ [ class pprint-word ]
+ [ >c-ptr pprint* ] bi
+ block> ;
+
PRIVATE>
M: struct-class see-class*
[ 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 ;
{ $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." } ;
+
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" } }
! (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
<<
[ "S{ struct-test-foo { y 7654 } }" ]
[
- 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 ;
] 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 } ;
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
{
[ [ 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
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 {
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 {
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
:: (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
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
] [
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>
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 ( -- )
[ +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
: find-device-axes-callback ( -- alien )
[ ! ( lpddoi pvRef -- BOOL )
+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 ] }
: 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 -- ? )
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 ]
: find-controller-callback ( -- alien )
[ ! ( lpddi pvRef -- BOOL )
- drop DIDEVICEINSTANCEW-guidInstance add-controller
+ drop guidInstance>> add-controller
DIENUM_CONTINUE
- ] LPDIENUMDEVICESCALLBACKW ;
+ ] LPDIENUMDEVICESCALLBACKW ; inline
: find-controllers ( -- )
+dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
[ 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>> <guid> ;
M: dinput-game-input-backend instance-id
handle>> device-guid ;
}
: >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 ] }
} 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 -- )
[ dup IDirectInputDevice8W::Poll ole32-error ] dip
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
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
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
M: netbsd file-systems ( -- array )
f 0 0 getvfsstat dup io-error
- \ statvfs <c-type-array>
+ \ statvfs <struct-array>
[ dup length 0 getvfsstat io-error ]
[ [ f_mntonname>> utf8 alien>string file-system-info ] map ] bi ;
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 ;
IN: io.files.unix.openbsd
TUPLE: freebsd-file-system-info < unix-file-system-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
] 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
! 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 ;
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) ;
! 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 ;
M: tuple pprint*
pprint-tuple ;
+: pprint-c-object ( object content-quot pointer-quot -- )
+ [ c-object-pointers? get ] 2dip
+ [ nip ]
+ [ [ drop ] prepose [ recover ] 2curry ] 2bi if ; inline
+
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
{ $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." } ;
SYMBOL: line-limit
SYMBOL: string-limit?
SYMBOL: boa-tuples?
+SYMBOL: c-object-pointers?
4 tab-size set-global
64 margin set-global
{ $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."
! 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 -- )
+ <block
+ pprint-word
+ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@
+ block> ;
+
+PRIVATE>
+
FUNCTOR: define-direct-array ( T -- )
A' IS ${T}-array
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 ]
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
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 -- )
{ 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
T c-type
\ A >>array-class
\ <A> >>array-constructor
+ \ (A) >>(array)-constructor
\ S >>sequence-mixin-class
drop
! (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
M: struct-array >pprint-sequence
[ >array ] [ class>> ] bi prefix ;
-M: struct-array pprint* pprint-object ;
+: pprint-struct-array-pointer ( struct-array -- )
+ <block
+ \ struct-array@ pprint-word
+ [ class>> ] [ underlying>> ] [ length>> ] tri [ pprint* ] tri@
+ block> ;
+
+M: struct-array pprint*
+ [ pprint-object ]
+ [ pprint-struct-array-pointer ] pprint-c-object ;
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
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
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
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
-USING: windows.com windows.com.wrapper combinators\r
-windows.kernel32 windows.ole32 windows.shell32 kernel accessors\r
+USING: alien.strings io.encodings.utf16n windows.com\r
+windows.com.wrapper combinators windows.kernel32 windows.ole32\r
+windows.shell32 kernel accessors\r
prettyprint namespaces ui.tools.listener ui.tools.workspace\r
alien.c-types alien sequences math ;\r
IN: windows.dragdrop-listener\r
\r
+<< "WCHAR" require-c-arrays >>\r
+\r
: filenames-from-hdrop ( hdrop -- filenames )\r
dup HEX: FFFFFFFF f 0 DragQueryFile ! get count of files\r
[\r
2dup f 0 DragQueryFile 1 + ! get size of filename buffer\r
dup "WCHAR" <c-array>\r
[ swap DragQueryFile drop ] keep\r
- alien>u16-string\r
+ utf16n alien>string\r
] with map ;\r
\r
: filenames-from-data-object ( data-object -- filenames )\r
arrays literals ;
IN: windows.errors
+<< "TCHAR" require-c-arrays >>
+
CONSTANT: ERROR_SUCCESS 0
CONSTANT: ERROR_INVALID_FUNCTION 1
CONSTANT: ERROR_FILE_NOT_FOUND 2
: 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 )
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 ;
! 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
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 )
! (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
" " 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 [
] when* ;
: parse-bunny-model ( -- vertexes indexes )
- 100000 "bunny-vertex-struct" <struct-vector>
+ 100000 bunny-vertex-struct <struct-vector>
100000 <uint-vector>
(parse-bunny-model) ;
: 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
! (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
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
! (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
{ 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
"(" ")" 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 ;
[ 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 }
! 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 ;
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 )
: 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 )
projects / factor.git / commitdiff