From 8aa9327dccf2686c0e216751102693b85597e3b3 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 25 Aug 2009 19:58:04 -0500
Subject: [PATCH] support <c-type-array> on complex ffi types

---
 basis/alien/c-types/c-types.factor         |  9 ++++++---
 basis/alien/complex/functor/functor.factor | 22 ++++++++++++++++------
 basis/alien/structs/structs.factor         |  9 ++++-----
 extra/classes/struct/struct.factor         |  2 +-
 4 files changed, 27 insertions(+), 15 deletions(-)

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 675bc56503..779a5e18de 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -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 ;
 
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
index 98d412639f..a5580318a9 100644
--- a/basis/alien/complex/functor/functor.factor
+++ b/basis/alien/complex/functor/functor.factor
@@ -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
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 5c1fb4063b..3d9cae1202 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -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>> 
diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor
index 7d4eed80af..e9de2f7e36 100644
--- a/extra/classes/struct/struct.factor
+++ b/extra/classes/struct/struct.factor
@@ -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 ]