From 37c6405927ccb0b386970452ebc20c651f9081d6 Mon Sep 17 00:00:00 2001
From: Joe Groff <joe@victoria.(none)>
Date: Thu, 13 Aug 2009 13:28:00 -0400
Subject: [PATCH] coercers and array type relations for c-type classes

---
 extra/classes/c-types/c-types.factor | 81 +++++++++++++++++++++-------
 1 file changed, 62 insertions(+), 19 deletions(-)

diff --git a/extra/classes/c-types/c-types.factor b/extra/classes/c-types/c-types.factor
index ad7f061464..fe9940ad11 100644
--- a/extra/classes/c-types/c-types.factor
+++ b/extra/classes/c-types/c-types.factor
@@ -1,5 +1,21 @@
 USING: alien alien.c-types classes classes.predicate kernel
-math math.order words ;
+math math.bitwise math.order namespaces sequences words
+specialized-arrays.direct.alien
+specialized-arrays.direct.bool
+specialized-arrays.direct.char
+specialized-arrays.direct.complex-double
+specialized-arrays.direct.complex-float
+specialized-arrays.direct.double
+specialized-arrays.direct.float
+specialized-arrays.direct.int
+specialized-arrays.direct.long
+specialized-arrays.direct.longlong
+specialized-arrays.direct.short
+specialized-arrays.direct.uchar
+specialized-arrays.direct.uint
+specialized-arrays.direct.ulong
+specialized-arrays.direct.ulonglong
+specialized-arrays.direct.ushort ;
 IN: classes.c-types
 
 PREDICATE: char < fixnum
@@ -26,44 +42,71 @@ PREDICATE: longlong < integer
 PREDICATE: ulonglong < integer
     HEX: 0 HEX: ffff,ffff,ffff,ffff between? ;
 
-SYMBOLS: long ulong ;
+UNION: single-float float ;
+UNION: single-complex complex ;
+
+SYMBOLS: long ulong long-bits ;
 
 <<
     "long" heap-size 8 =
     [
         \  long integer [ HEX: -8000,0000,0000,0000 HEX: 7fff,ffff,ffff,ffff between? ] define-predicate-class
         \ ulong integer [ HEX:                    0 HEX: ffff,ffff,ffff,ffff between? ] define-predicate-class
+        64 long-bits set-global
     ] [
         \  long integer [ HEX: -8000,0000 HEX: 7fff,ffff between? ] define-predicate-class
         \ ulong integer [ HEX:          0 HEX: ffff,ffff between? ] define-predicate-class
+        32 long-bits set-global
     ] if
 >>
 
-: set-class-c-type ( class c-type -- )
-    "class-c-type" set-word-prop ;
+: set-class-c-type ( class c-type <direct-array> -- )
+    [ "class-c-type" set-word-prop ]
+    [ "class-direct-array" set-word-prop ] bi-curry* bi ;
 
 : class-c-type ( class -- c-type )
     "class-c-type" word-prop ;
+: class-direct-array ( class -- <direct-array> )
+    "class-direct-array" word-prop ;
 
-alien        "void*"     set-class-c-type
-\ f          "void*"     set-class-c-type
-pinned-c-ptr "void*"     set-class-c-type
-boolean      "bool"      set-class-c-type
-char         "char"      set-class-c-type
-uchar        "uchar"     set-class-c-type
-short        "short"     set-class-c-type
-ushort       "ushort"    set-class-c-type
-int          "int"       set-class-c-type
-uint         "uint"      set-class-c-type
-long         "long"      set-class-c-type
-ulong        "ulong"     set-class-c-type
-longlong     "longlong"  set-class-c-type
-ulonglong    "ulonglong" set-class-c-type
-float        "double"    set-class-c-type
+alien          "void*"          \ <direct-void*-array>          set-class-c-type
+\ f            "void*"          \ <direct-void*-array>          set-class-c-type
+pinned-c-ptr   "void*"          \ <direct-void*-array>          set-class-c-type
+boolean        "bool"           \ <direct-bool-array>           set-class-c-type
+char           "char"           \ <direct-char-array>           set-class-c-type
+uchar          "uchar"          \ <direct-uchar-array>          set-class-c-type
+short          "short"          \ <direct-short-array>          set-class-c-type
+ushort         "ushort"         \ <direct-ushort-array>         set-class-c-type
+int            "int"            \ <direct-int-array>            set-class-c-type
+uint           "uint"           \ <direct-uint-array>           set-class-c-type
+long           "long"           \ <direct-long-array>           set-class-c-type
+ulong          "ulong"          \ <direct-ulong-array>          set-class-c-type
+longlong       "longlong"       \ <direct-longlong-array>       set-class-c-type
+ulonglong      "ulonglong"      \ <direct-ulonglong-array>      set-class-c-type
+float          "double"         \ <direct-double-array>         set-class-c-type
+single-float   "float"          \ <direct-float-array>          set-class-c-type
+complex        "complex-double" \ <direct-complex-double-array> set-class-c-type
+single-complex "complex-float"  \ <direct-complex-float-array>  set-class-c-type
+
+char      [  8 bits  8 >signed ] "coercer" set-word-prop
+uchar     [  8 bits            ] "coercer" set-word-prop
+short     [ 16 bits 16 >signed ] "coercer" set-word-prop
+ushort    [ 16 bits            ] "coercer" set-word-prop
+int       [ 32 bits 32 >signed ] "coercer" set-word-prop
+uint      [ 32 bits            ] "coercer" set-word-prop
+long      [ [ bits ] [ >signed ] ] long-bits get-global prefix "coercer" set-word-prop
+ulong     [   bits               ] long-bits get-global prefix "coercer" set-word-prop
+longlong  [ 64 bits 64 >signed ] "coercer" set-word-prop
+ulonglong [ 64 bits            ] "coercer" set-word-prop
 
 PREDICATE: c-type-class < class
     "class-c-type" word-prop ;
 
+GENERIC: direct-array-of ( alien len class -- array )
+
+M: c-type-class direct-array-of
+    class-direct-array execute( alien len -- array ) ; inline
+
 M: c-type-class c-type class-c-type c-type ;
 M: c-type-class c-type-align class-c-type c-type-align ;
 M: c-type-class c-type-getter class-c-type c-type-getter ;