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

db4
Doug Coleman 2009-08-27 21:58:47 -05:00
commit 8caece6928
9 changed files with 21 additions and 31 deletions

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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>>

View File

@ -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." }

View File

@ -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

View File

@ -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