Merge branch 'master' of git://factorcode.org/git/factor
commit
8caece6928
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: alien alien.strings alien.c-types alien.accessors alien.structs
|
USING: alien alien.strings alien.c-types alien.accessors alien.structs
|
||||||
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
arrays words sequences math kernel namespaces fry libc cpu.architecture
|
||||||
io.encodings.utf8 ;
|
io.encodings.utf8 accessors ;
|
||||||
IN: alien.arrays
|
IN: alien.arrays
|
||||||
|
|
||||||
UNION: value-type array struct-type ;
|
UNION: value-type array struct-type ;
|
||||||
|
@ -13,7 +13,10 @@ M: array c-type-class drop object ;
|
||||||
|
|
||||||
M: array c-type-boxed-class drop object ;
|
M: array c-type-boxed-class drop object ;
|
||||||
|
|
||||||
M: array heap-size unclip [ product ] [ heap-size ] bi* * ;
|
: array-length ( seq -- n )
|
||||||
|
[ dup word? [ def>> call( -- object ) ] when ] [ * ] map-reduce ;
|
||||||
|
|
||||||
|
M: array heap-size unclip [ array-length ] [ heap-size ] bi* * ;
|
||||||
|
|
||||||
M: array c-type-align first c-type-align ;
|
M: array c-type-align first c-type-align ;
|
||||||
|
|
||||||
|
@ -31,7 +34,7 @@ M: array stack-size drop "void*" stack-size ;
|
||||||
|
|
||||||
M: array c-type-boxer-quot
|
M: array c-type-boxer-quot
|
||||||
unclip
|
unclip
|
||||||
[ product ]
|
[ array-length ]
|
||||||
[ [ require-c-type-arrays ] keep ] bi*
|
[ [ require-c-type-arrays ] keep ] bi*
|
||||||
[ <c-type-direct-array> ] 2curry ;
|
[ <c-type-direct-array> ] 2curry ;
|
||||||
|
|
||||||
|
|
|
@ -4,7 +4,7 @@ IN: alien.c-types.tests
|
||||||
|
|
||||||
CONSTANT: xyz 123
|
CONSTANT: xyz 123
|
||||||
|
|
||||||
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
|
[ 492 ] [ { "int" xyz } heap-size ] unit-test
|
||||||
|
|
||||||
[ -1 ] [ -1 <char> *char ] unit-test
|
[ -1 ] [ -1 <char> *char ] unit-test
|
||||||
[ -1 ] [ -1 <short> *short ] unit-test
|
[ -1 ] [ -1 <short> *short ] unit-test
|
||||||
|
|
|
@ -326,17 +326,6 @@ M: long-long-type box-return ( type -- )
|
||||||
[ define-out ]
|
[ define-out ]
|
||||||
tri ;
|
tri ;
|
||||||
|
|
||||||
: expand-constants ( c-type -- c-type' )
|
|
||||||
dup array? [
|
|
||||||
unclip [
|
|
||||||
[
|
|
||||||
dup word? [
|
|
||||||
def>> call( -- object )
|
|
||||||
] when
|
|
||||||
] map
|
|
||||||
] dip prefix
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: malloc-file-contents ( path -- alien len )
|
: malloc-file-contents ( path -- alien len )
|
||||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
||||||
|
|
||||||
|
|
|
@ -7,16 +7,16 @@ IN: alien.structs.fields
|
||||||
TUPLE: field-spec name offset type reader writer ;
|
TUPLE: field-spec name offset type reader writer ;
|
||||||
|
|
||||||
: reader-word ( class name vocab -- word )
|
: reader-word ( class name vocab -- word )
|
||||||
[ "-" glue ] dip create ;
|
[ "-" glue ] dip create dup make-deprecated ;
|
||||||
|
|
||||||
: writer-word ( class name vocab -- word )
|
: writer-word ( class name vocab -- word )
|
||||||
[ [ swap "set-" % % "-" % % ] "" make ] dip create ;
|
[ [ swap "set-" % % "-" % % ] "" make ] dip create dup make-deprecated ;
|
||||||
|
|
||||||
: <field-spec> ( struct-name vocab type field-name -- spec )
|
: <field-spec> ( struct-name vocab type field-name -- spec )
|
||||||
field-spec new
|
field-spec new
|
||||||
0 >>offset
|
0 >>offset
|
||||||
swap >>name
|
swap >>name
|
||||||
swap expand-constants >>type
|
swap >>type
|
||||||
3dup name>> swap reader-word >>reader
|
3dup name>> swap reader-word >>reader
|
||||||
3dup name>> swap writer-word >>writer
|
3dup name>> swap writer-word >>writer
|
||||||
2nip ;
|
2nip ;
|
||||||
|
|
|
@ -55,12 +55,11 @@ M: struct-type stack-size
|
||||||
[ struct-offsets ] keep
|
[ struct-offsets ] keep
|
||||||
[ [ type>> ] map compute-struct-align ] keep
|
[ [ type>> ] map compute-struct-align ] keep
|
||||||
[ struct-type (define-struct) ] keep
|
[ struct-type (define-struct) ] keep
|
||||||
[ define-field ] each ;
|
[ define-field ] each ; deprecated
|
||||||
|
|
||||||
: define-union ( name members -- )
|
: define-union ( name members -- )
|
||||||
[ expand-constants ] map
|
|
||||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||||
compute-struct-align f struct-type (define-struct) ;
|
compute-struct-align f struct-type (define-struct) ; deprecated
|
||||||
|
|
||||||
: offset-of ( field struct -- offset )
|
: offset-of ( field struct -- offset )
|
||||||
c-types get at fields>>
|
c-types get at fields>>
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: alien.syntax
|
IN: alien.syntax
|
||||||
USING: alien alien.c-types alien.parser alien.structs
|
USING: alien alien.c-types alien.parser alien.structs
|
||||||
help.markup help.syntax ;
|
classes.struct help.markup help.syntax ;
|
||||||
|
|
||||||
HELP: DLL"
|
HELP: DLL"
|
||||||
{ $syntax "DLL\" path\"" }
|
{ $syntax "DLL\" path\"" }
|
||||||
|
@ -55,12 +55,14 @@ HELP: TYPEDEF:
|
||||||
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
{ $notes "This word differs from " { $link typedef } " in that it runs at parse time, to ensure correct ordering of operations when loading source files. Words defined in source files are compiled before top-level forms are run, so if a source file defines C binding words and uses " { $link typedef } ", the type alias won't be available at compile time." } ;
|
||||||
|
|
||||||
HELP: C-STRUCT:
|
HELP: C-STRUCT:
|
||||||
|
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: STRUCT: } " word." }
|
||||||
{ $syntax "C-STRUCT: name pairs... ;" }
|
{ $syntax "C-STRUCT: name pairs... ;" }
|
||||||
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
|
{ $values { "name" "a new C type name" } { "pairs" "C type / field name string pairs" } }
|
||||||
{ $description "Defines a C struct layout and accessor words." }
|
{ $description "Defines a C struct layout and accessor words." }
|
||||||
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
|
{ $notes "C type names are documented in " { $link "c-types-specs" } "." } ;
|
||||||
|
|
||||||
HELP: C-UNION:
|
HELP: C-UNION:
|
||||||
|
{ $deprecated "New code should use " { $link "classes.struct" } ". See the " { $link POSTPONE: UNION-STRUCT: } " word." }
|
||||||
{ $syntax "C-UNION: name members... ;" }
|
{ $syntax "C-UNION: name members... ;" }
|
||||||
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
|
{ $values { "name" "a new C type name" } { "members" "a sequence of C types" } }
|
||||||
{ $description "Defines a new C type sized to fit its largest member." }
|
{ $description "Defines a new C type sized to fit its largest member." }
|
||||||
|
|
|
@ -22,10 +22,10 @@ SYNTAX: TYPEDEF:
|
||||||
scan scan typedef ;
|
scan scan typedef ;
|
||||||
|
|
||||||
SYNTAX: C-STRUCT:
|
SYNTAX: C-STRUCT:
|
||||||
scan current-vocab parse-definition define-struct ;
|
scan current-vocab parse-definition define-struct ; deprecated
|
||||||
|
|
||||||
SYNTAX: C-UNION:
|
SYNTAX: C-UNION:
|
||||||
scan parse-definition define-union ;
|
scan parse-definition define-union ; deprecated
|
||||||
|
|
||||||
SYNTAX: C-ENUM:
|
SYNTAX: C-ENUM:
|
||||||
";" parse-tokens
|
";" parse-tokens
|
||||||
|
|
|
@ -14,9 +14,6 @@ TUPLE: alien-indirect-params < alien-node-params ;
|
||||||
|
|
||||||
TUPLE: alien-callback-params < alien-node-params quot xt ;
|
TUPLE: alien-callback-params < alien-node-params quot xt ;
|
||||||
|
|
||||||
: pop-parameters ( -- seq )
|
|
||||||
pop-literal nip [ expand-constants ] map ;
|
|
||||||
|
|
||||||
: param-prep-quot ( node -- quot )
|
: param-prep-quot ( node -- quot )
|
||||||
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
parameters>> [ c-type c-type-unboxer-quot ] map spread>quot ;
|
||||||
|
|
||||||
|
@ -31,7 +28,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
||||||
: infer-alien-invoke ( -- )
|
: infer-alien-invoke ( -- )
|
||||||
alien-invoke-params new
|
alien-invoke-params new
|
||||||
! Compile-time parameters
|
! Compile-time parameters
|
||||||
pop-parameters >>parameters
|
pop-literal nip >>parameters
|
||||||
pop-literal nip >>function
|
pop-literal nip >>function
|
||||||
pop-literal nip >>library
|
pop-literal nip >>library
|
||||||
pop-literal nip >>return
|
pop-literal nip >>return
|
||||||
|
@ -50,7 +47,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
||||||
alien-indirect-params new
|
alien-indirect-params new
|
||||||
! Compile-time parameters
|
! Compile-time parameters
|
||||||
pop-literal nip >>abi
|
pop-literal nip >>abi
|
||||||
pop-parameters >>parameters
|
pop-literal nip >>parameters
|
||||||
pop-literal nip >>return
|
pop-literal nip >>return
|
||||||
! Quotation which coerces parameters to required types
|
! Quotation which coerces parameters to required types
|
||||||
dup param-prep-quot [ dip ] curry infer-quot-here
|
dup param-prep-quot [ dip ] curry infer-quot-here
|
||||||
|
@ -71,7 +68,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
|
||||||
alien-callback-params new
|
alien-callback-params new
|
||||||
pop-literal nip >>quot
|
pop-literal nip >>quot
|
||||||
pop-literal nip >>abi
|
pop-literal nip >>abi
|
||||||
pop-parameters >>parameters
|
pop-literal nip >>parameters
|
||||||
pop-literal nip >>return
|
pop-literal nip >>return
|
||||||
gensym >>xt
|
gensym >>xt
|
||||||
dup callback-bottom
|
dup callback-bottom
|
||||||
|
|
Loading…
Reference in New Issue