support <c-type-array> of structs using struct-arrays

basis/alien/c-types/c-types.factor

@@ -21,19 +21,19 @@ TUPLE: abstract-c-type
 { getter callable }
 { setter callable }
 size
-align ;
+align
-
-TUPLE: c-type < abstract-c-type
-boxer
-unboxer
-{ rep initial: int-rep }
-stack-align?
 array-class
 array-constructor
 direct-array-class
 direct-array-constructor
 sequence-mixin-class ;
 
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
+stack-align? ;
+
 : <c-type> ( -- type )
     \ c-type new ;
 
@@ -79,15 +79,12 @@ 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: array-c-type require-c-type-arrays
+M: c-type require-c-type-arrays
     [ array-class>> ?require-word ]
     [ sequence-mixin-class>> ?require-word ]
     [ direct-array-class>> ?require-word ] tri ;
@@ -100,33 +97,29 @@ M: array require-c-type-arrays
 
 ERROR: specialized-array-vocab-not-loaded vocab word ;
 
-GENERIC: c-type-array-constructor ( c-type -- word ) foldable
+: c-type-array-constructor ( c-type -- word )
-
-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: array-c-type c-type-array-constructor
     array-constructor>> dup word?
-    [ first2 specialized-array-vocab-not-loaded ] unless ;
+    [ first2 specialized-array-vocab-not-loaded ] unless ; foldable
 
-GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable
+: c-type-direct-array-constructor ( c-type -- word )
-
-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: array-c-type c-type-direct-array-constructor
     direct-array-constructor>> dup word?
-    [ first2 specialized-array-vocab-not-loaded ] unless ;
+    [ first2 specialized-array-vocab-not-loaded ] unless ; 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-type-class ( name -- class )
 

basis/alien/complex/functor/functor.factor

@@ -1,18 +1,10 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.structs.fields alien.c-types
+USING: alien.structs alien.c-types math math.functions sequences
-math math.functions sequences arrays kernel functors
+arrays kernel functors vocabs.parser namespaces accessors
-vocabs.parser namespaces accessors quotations ;
+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
@@ -31,10 +23,9 @@ WHERE
 : *T ( alien -- z )
     [ T-real ] [ T-imaginary ] bi rect> ; inline
 
-T  N c-type-align [ 2 * ] [ ] bi
+T current-vocab
-T current-vocab N "real" <field-spec>
+{ { N "real" } { N "imaginary" } }
-T current-vocab N "imaginary" <field-spec> N c-type-align >>offset
+define-struct
-2array complex-c-type (define-struct)
 
 T c-type
 <T> 1quotation >>unboxer-quot

basis/alien/structs/structs.factor

@@ -3,7 +3,7 @@
 USING: accessors arrays assocs generic hashtables kernel kernel.private
 math namespaces parser sequences strings words libc fry
 alien.c-types alien.structs.fields cpu.architecture math.order
-quotations byte-arrays ;
+quotations byte-arrays struct-arrays ;
 IN: alien.structs
 
 TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
@@ -12,6 +12,16 @@ M: struct-type c-type ;
 
 M: struct-type c-type-stack-align? drop f ;
 
+M: struct-type <c-type-array> ( len c-type -- array )
+    dup c-type-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
+    [ execute( alien len -- array ) ]
+    [ <direct-struct-array> ] ?if ; inline
+
 : if-value-struct ( ctype true false -- )
     [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline