"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
-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
[ 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
} 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*
[ 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 ;
{ $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" } }
! (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
<<
] 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 ;
] 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
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
{
[ [ 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
} 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 ;
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 )
+ [ 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 ] }
: 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 DIDEVICEINSTANCEW memory>struct 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>> ;
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 -- )
+: 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
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
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
} 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 )
{
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 ;
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> 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 ;
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
[ 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 )
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 ;
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) ;
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
[ 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@ ;
! 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
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
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> ;
! 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 ;
+: 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 [-]
{ $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 -- )
+ [ [ underlying>> ] [ length>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
+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 -- )
+ \ 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 ;
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."
{ $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"
! 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 )
{ 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
[ 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
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
] when ;
: strip-destructors ( -- )
- "libc" vocab [
- "Stripping destructor debug code" show
- "vocab:tools/deploy/shaker/strip-destructors.factor"
+ "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 ;
: strip ( -- )
init-stripper
strip-libc
+ strip-struct-arrays
strip-destructors
strip-call
strip-cocoa
! 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 ;
+
+IN: compiler.tree.propagation.call-effect
+
+: call-effect-unsafe? ( quot effect -- ? ) 2drop t ; inline
-: execute-effect ( word effect -- ) execute-effect-unsafe ; inline
\ No newline at end of file
+: execute-effect-unsafe? ( word effect -- ? ) 2drop t ; inline
\ No newline at end of file
--- /dev/null
+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
+
+>>
\ No newline at end of file
: 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 ;
: 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 )
! 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
{ "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
! 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 ;
<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 ;
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
: (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>
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 ;
: 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
<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>
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
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
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
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
- [ utime ] unix-system-call drop ;
+ utimbuf <struct>
+ swap >>modtime
+ swap >>actime
+ [ utime ] unix-system-call drop ;
FUNCTION: int pclose ( void* file ) ;
FUNCTION: int pipe ( int* filedes ) ;
! 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 ;
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 ;
! 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 ;
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
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
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
<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>
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 ;
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
: (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 ]
[ 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
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
{
c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
- } [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
+ } [ [ rgodf>> free ] uninitialize ] each ;
PRIVATE>
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 ;
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 ] [
! 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 )
{ 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
"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:"
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 } }
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
! 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
: 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 ;
! (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