From d19c403feebf19bd510efa8cdb96286b5df86c17 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 9 Aug 2009 16:10:11 -0500
Subject: [PATCH] alien.structs: struct-type now has a class slot; fix
 specialized complex-float/double arrays

---
 basis/alien/c-types/c-types.factor            | 22 ++++++++++---------
 basis/alien/complex/functor/functor.factor    |  1 +
 basis/alien/structs/structs.factor            | 21 ++----------------
 .../specialization-tests.factor               |  9 ++++++++
 4 files changed, 24 insertions(+), 29 deletions(-)

diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index 3be2074056..7807113999 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -13,17 +13,19 @@ DEFER: *char
 
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
 
-TUPLE: c-type
+TUPLE: abstract-c-type
 { class class initial: object }
-boxer
 { boxer-quot callable }
-unboxer
 { unboxer-quot callable }
 { getter callable }
 { setter callable }
-{ rep initial: int-rep }
 size
-align
+align ;
+
+TUPLE: c-type < abstract-c-type
+boxer
+unboxer
+{ rep initial: int-rep }
 stack-align? ;
 
 : <c-type> ( -- type )
@@ -70,7 +72,7 @@ M: string c-type ( name -- type )
 
 GENERIC: c-type-class ( name -- class )
 
-M: c-type c-type-class class>> ;
+M: abstract-c-type c-type-class class>> ;
 
 M: string c-type-class c-type c-type-class ;
 
@@ -82,7 +84,7 @@ M: string c-type-boxer c-type c-type-boxer ;
 
 GENERIC: c-type-boxer-quot ( name -- quot )
 
-M: c-type c-type-boxer-quot boxer-quot>> ;
+M: abstract-c-type c-type-boxer-quot boxer-quot>> ;
 
 M: string c-type-boxer-quot c-type c-type-boxer-quot ;
 
@@ -94,7 +96,7 @@ M: string c-type-unboxer c-type c-type-unboxer ;
 
 GENERIC: c-type-unboxer-quot ( name -- quot )
 
-M: c-type c-type-unboxer-quot unboxer-quot>> ;
+M: abstract-c-type c-type-unboxer-quot unboxer-quot>> ;
 
 M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
 
@@ -118,7 +120,7 @@ M: string c-type-setter c-type c-type-setter ;
 
 GENERIC: c-type-align ( name -- n )
 
-M: c-type c-type-align align>> ;
+M: abstract-c-type c-type-align align>> ;
 
 M: string c-type-align c-type c-type-align ;
 
@@ -167,7 +169,7 @@ GENERIC: heap-size ( type -- size ) foldable
 
 M: string heap-size c-type heap-size ;
 
-M: c-type heap-size size>> ;
+M: abstract-c-type heap-size size>> ;
 
 GENERIC: stack-size ( type -- size ) foldable
 
diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor
index fc9e594be5..59bf3451b8 100644
--- a/basis/alien/complex/functor/functor.factor
+++ b/basis/alien/complex/functor/functor.factor
@@ -30,6 +30,7 @@ define-struct
 T c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
+number >>class
 drop
 
 ;FUNCTOR
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index b618e7974b..4154ad1dd8 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -6,30 +6,12 @@ alien.c-types alien.structs.fields cpu.architecture math.order
 quotations byte-arrays ;
 IN: alien.structs
 
-TUPLE: struct-type
-size
-align
-fields
-{ boxer-quot callable }
-{ unboxer-quot callable }
-{ getter callable }
-{ setter callable }
-return-in-registers? ;
+TUPLE: struct-type < abstract-c-type fields return-in-registers? ;
 
 M: struct-type c-type ;
 
-M: struct-type heap-size size>> ;
-
-M: struct-type c-type-class drop byte-array ;
-
-M: struct-type c-type-align align>> ;
-
 M: struct-type c-type-stack-align? drop f ;
 
-M: struct-type c-type-boxer-quot boxer-quot>> ;
-
-M: struct-type c-type-unboxer-quot unboxer-quot>> ;
-
 : if-value-struct ( ctype true false -- )
     [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
 
@@ -56,6 +38,7 @@ M: struct-type stack-size
 : (define-struct) ( name size align fields -- )
     [ [ align ] keep ] dip
     struct-type new
+        byte-array >>class
         swap >>fields
         swap >>align
         swap >>size
diff --git a/basis/math/vectors/specialization/specialization-tests.factor b/basis/math/vectors/specialization/specialization-tests.factor
index 36f4fadf00..5b6f1eac71 100644
--- a/basis/math/vectors/specialization/specialization-tests.factor
+++ b/basis/math/vectors/specialization/specialization-tests.factor
@@ -1,6 +1,7 @@
 IN: math.vectors.specialization.tests
 USING: compiler.tree.debugger math.vectors tools.test kernel
 kernel.private math specialized-arrays.double
+specialized-arrays.complex-float
 specialized-arrays.float ;
 
 [ V{ t } ] [
@@ -9,4 +10,12 @@ specialized-arrays.float ;
 
 [ V{ float } ] [
     [ { float-array float } declare v*n norm ] final-classes
+] unit-test
+
+[ V{ number } ] [
+    [ { complex-float-array complex-float-array } declare v. ] final-classes
+] unit-test
+
+[ V{ real } ] [
+    [ { complex-float-array complex } declare v*n norm ] final-classes
 ] unit-test
\ No newline at end of file