support <c-type-array> on complex ffi types
parent
d42edd4e3b
commit
8aa9327dcc
|
@ -79,12 +79,15 @@ M: string c-type ( name -- type )
|
|||
: ?require-word ( word/pair -- )
|
||||
dup word? [ drop ] [ first require ] ?if ;
|
||||
|
||||
MIXIN: array-c-type
|
||||
INSTANCE: c-type array-c-type
|
||||
|
||||
GENERIC: require-c-type-arrays ( c-type -- )
|
||||
|
||||
M: object require-c-type-arrays
|
||||
drop ;
|
||||
|
||||
M: c-type require-c-type-arrays
|
||||
M: array-c-type require-c-type-arrays
|
||||
[ array-class>> ?require-word ]
|
||||
[ sequence-mixin-class>> ?require-word ]
|
||||
[ direct-array-class>> ?require-word ] tri ;
|
||||
|
@ -103,7 +106,7 @@ M: string c-type-array-constructor
|
|||
c-type c-type-array-constructor ;
|
||||
M: array c-type-array-constructor
|
||||
first c-type c-type-array-constructor ;
|
||||
M: c-type c-type-array-constructor
|
||||
M: array-c-type c-type-array-constructor
|
||||
array-constructor>> dup word?
|
||||
[ first2 specialized-array-vocab-not-loaded ] unless ;
|
||||
|
||||
|
@ -113,7 +116,7 @@ M: string c-type-direct-array-constructor
|
|||
c-type c-type-direct-array-constructor ;
|
||||
M: array c-type-direct-array-constructor
|
||||
first c-type c-type-direct-array-constructor ;
|
||||
M: c-type c-type-direct-array-constructor
|
||||
M: array-c-type c-type-direct-array-constructor
|
||||
direct-array-constructor>> dup word?
|
||||
[ first2 specialized-array-vocab-not-loaded ] unless ;
|
||||
|
||||
|
|
|
@ -1,10 +1,18 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.structs alien.c-types math math.functions sequences
|
||||
arrays kernel functors vocabs.parser namespaces accessors
|
||||
quotations ;
|
||||
USING: alien.structs alien.structs.fields alien.c-types
|
||||
math math.functions sequences arrays kernel functors
|
||||
vocabs.parser namespaces accessors quotations ;
|
||||
IN: alien.complex.functor
|
||||
|
||||
TUPLE: complex-c-type < struct-type
|
||||
array-class
|
||||
array-constructor
|
||||
direct-array-class
|
||||
direct-array-constructor
|
||||
sequence-mixin-class ;
|
||||
INSTANCE: complex-c-type array-c-type
|
||||
|
||||
FUNCTOR: define-complex-type ( N T -- )
|
||||
|
||||
T-real DEFINES ${T}-real
|
||||
|
@ -23,14 +31,16 @@ WHERE
|
|||
: *T ( alien -- z )
|
||||
[ T-real ] [ T-imaginary ] bi rect> ; inline
|
||||
|
||||
T current-vocab
|
||||
{ { N "real" } { N "imaginary" } }
|
||||
define-struct
|
||||
T N c-type-align [ 2 * ] [ ] bi
|
||||
T current-vocab N "real" <field-spec>
|
||||
T current-vocab N "imaginary" <field-spec> N c-type-align >>offset
|
||||
2array complex-c-type (define-struct)
|
||||
|
||||
T c-type
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
number >>boxed-class
|
||||
T set-array-class
|
||||
drop
|
||||
|
||||
;FUNCTOR
|
||||
|
|
|
@ -35,9 +35,8 @@ M: struct-type stack-size
|
|||
|
||||
: c-struct? ( type -- ? ) (c-type) struct-type? ;
|
||||
|
||||
: (define-struct) ( name size align fields -- )
|
||||
[ [ align ] keep ] dip
|
||||
struct-type new
|
||||
: (define-struct) ( name size align fields class -- )
|
||||
[ [ align ] keep ] 2dip new
|
||||
byte-array >>class
|
||||
byte-array >>boxed-class
|
||||
swap >>fields
|
||||
|
@ -55,13 +54,13 @@ M: struct-type stack-size
|
|||
[ 2drop ] [ make-fields ] 3bi
|
||||
[ struct-offsets ] keep
|
||||
[ [ type>> ] map compute-struct-align ] keep
|
||||
[ (define-struct) ] keep
|
||||
[ struct-type (define-struct) ] keep
|
||||
[ define-field ] each ;
|
||||
|
||||
: define-union ( name members -- )
|
||||
[ expand-constants ] map
|
||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||
compute-struct-align f (define-struct) ;
|
||||
compute-struct-align f struct-type (define-struct) ;
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
|
|
|
@ -117,7 +117,7 @@ M: struct-class writer-quot
|
|||
[ "struct-align" word-prop ]
|
||||
[ struct-slots [ slot>field ] map ]
|
||||
} cleave
|
||||
(define-struct)
|
||||
struct-type (define-struct)
|
||||
] [
|
||||
{
|
||||
[ name>> c-type ]
|
||||
|
|
Loading…
Reference in New Issue