associate specialized-arrays vocabs with c-types; add words for requiring vocabs and constructing arrays by C type

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

@@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
 cpu.architecture alien alien.accessors alien.strings quotations
 layouts system compiler.units io io.files io.encodings.binary
 io.streams.memory accessors combinators effects continuations fry
-classes ;
+classes vocabs vocabs.loader ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -27,7 +27,12 @@ TUPLE: c-type < abstract-c-type
 boxer
 unboxer
 { rep initial: int-rep }
-stack-align? ;
+stack-align?
+array-class
+array-constructor
+direct-array-class
+direct-array-constructor
+sequence-mixin-class ;
 
 : <c-type> ( -- type )
     \ c-type new ;
@@ -71,6 +76,48 @@ M: string c-type ( name -- type )
         ] ?if
     ] if ;
 
+: ?require-word ( word/pair -- )
+    dup word? [ drop ] [ first require ] ?if ;
+
+GENERIC: require-c-type-arrays ( c-type -- )
+
+M: object require-c-type-arrays
+    drop ;
+
+M: c-type require-c-type-arrays
+    [ array-class>> ?require-word ]
+    [ sequence-mixin-class>> ?require-word ]
+    [ direct-array-class>> ?require-word ] tri ;
+
+M: string require-c-type-arrays
+    c-type require-c-type-arrays ;
+
+M: array require-c-type-arrays
+    first c-type require-c-type-arrays ;
+
+GENERIC: c-type-array-constructor ( c-type -- word ) foldable
+
+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
+    array-constructor>> ;
+
+GENERIC: c-type-direct-array-constructor ( c-type -- word ) foldable
+
+M: string c-type-direct-array-constructor 
+    c-type c-type-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
+    direct-array-constructor>> ;
+
+: <c-type-array> ( len c-type -- array )
+    c-type-array-constructor execute( len -- array ) ; inline
+: <c-type-direct-array> ( len c-type -- array )
+    c-type-direct-array-constructor execute( len -- array ) ; inline
+
 GENERIC: c-type-class ( name -- class )
 
 M: abstract-c-type c-type-class class>> ;
@@ -293,6 +340,36 @@ M: long-long-type box-return ( type -- )
 : if-void ( type true false -- )
     pick "void" = [ drop nip call ] [ nip call ] if ; inline
 
+: ?lookup ( vocab word -- word/pair )
+    over vocab [ swap lookup ] [ 2array ] if ;
+
+: set-array-class* ( c-type vocab-stem type-stem -- c-type )
+    {
+        [
+            [ "specialized-arrays." prepend ]
+            [ "-array" append ] bi* ?lookup >>array-class
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "<" "-array>" surround ] bi* ?lookup >>array-constructor
+        ]
+        [
+            [ "specialized-arrays." prepend ]
+            [ "-sequence" append ] bi* ?lookup >>sequence-mixin-class
+        ]
+        [
+            [ "specialized-arrays.direct." prepend ]
+            [ "direct-" "-array" surround ] bi* ?lookup >>direct-array-class
+        ]
+        [
+            [ "specialized-arrays.direct." prepend ]
+            [ "<direct-" "-array>" surround ] bi* ?lookup >>direct-array-constructor
+        ]
+    } 2cleave ;
+
+: set-array-class ( c-type stem -- c-type )
+    dup set-array-class* ;
+
 CONSTANT: primitive-types
     {
         "char" "uchar"
@@ -315,6 +392,7 @@ CONSTANT: primitive-types
         [ >c-ptr ] >>unboxer-quot
         "box_alien" >>boxer
         "alien_offset" >>unboxer
+        "alien" "void*" set-array-class*
     "void*" define-primitive-type
 
     <long-long-type>
@@ -326,6 +404,7 @@ CONSTANT: primitive-types
         8 >>align
         "box_signed_8" >>boxer
         "to_signed_8" >>unboxer
+        "longlong" set-array-class
     "longlong" define-primitive-type
 
     <long-long-type>
@@ -337,6 +416,7 @@ CONSTANT: primitive-types
         8 >>align
         "box_unsigned_8" >>boxer
         "to_unsigned_8" >>unboxer
+        "ulonglong" set-array-class
     "ulonglong" define-primitive-type
 
     <c-type>
@@ -348,6 +428,7 @@ CONSTANT: primitive-types
         bootstrap-cell >>align
         "box_signed_cell" >>boxer
         "to_fixnum" >>unboxer
+        "long" set-array-class
     "long" define-primitive-type
 
     <c-type>
@@ -359,6 +440,7 @@ CONSTANT: primitive-types
         bootstrap-cell >>align
         "box_unsigned_cell" >>boxer
         "to_cell" >>unboxer
+        "ulong" set-array-class
     "ulong" define-primitive-type
 
     <c-type>
@@ -370,6 +452,7 @@ CONSTANT: primitive-types
         4 >>align
         "box_signed_4" >>boxer
         "to_fixnum" >>unboxer
+        "int" set-array-class
     "int" define-primitive-type
 
     <c-type>
@@ -381,6 +464,7 @@ CONSTANT: primitive-types
         4 >>align
         "box_unsigned_4" >>boxer
         "to_cell" >>unboxer
+        "uint" set-array-class
     "uint" define-primitive-type
 
     <c-type>
@@ -392,6 +476,7 @@ CONSTANT: primitive-types
         2 >>align
         "box_signed_2" >>boxer
         "to_fixnum" >>unboxer
+        "short" set-array-class
     "short" define-primitive-type
 
     <c-type>
@@ -403,6 +488,7 @@ CONSTANT: primitive-types
         2 >>align
         "box_unsigned_2" >>boxer
         "to_cell" >>unboxer
+        "ushort" set-array-class
     "ushort" define-primitive-type
 
     <c-type>
@@ -414,6 +500,7 @@ CONSTANT: primitive-types
         1 >>align
         "box_signed_1" >>boxer
         "to_fixnum" >>unboxer
+        "char" set-array-class
     "char" define-primitive-type
 
     <c-type>
@@ -425,6 +512,7 @@ CONSTANT: primitive-types
         1 >>align
         "box_unsigned_1" >>boxer
         "to_cell" >>unboxer
+        "uchar" set-array-class
     "uchar" define-primitive-type
 
     <c-type>
@@ -434,6 +522,7 @@ CONSTANT: primitive-types
         1 >>align
         "box_boolean" >>boxer
         "to_boolean" >>unboxer
+        "bool" set-array-class
     "bool" define-primitive-type
 
     <c-type>
@@ -447,6 +536,7 @@ CONSTANT: primitive-types
         "to_float" >>unboxer
         single-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "float" set-array-class
     "float" define-primitive-type
 
     <c-type>
@@ -460,9 +550,11 @@ CONSTANT: primitive-types
         "to_double" >>unboxer
         double-float-rep >>rep
         [ >float ] >>unboxer-quot
+        "double" set-array-class
     "double" define-primitive-type
 
     "long" "ptrdiff_t" typedef
     "long" "intptr_t" typedef
     "ulong" "size_t" typedef
 ] with-compilation-unit
+

basis/specialized-arrays/direct/functor/functor.factor

@@ -25,8 +25,6 @@ TUPLE: A
 { underlying c-ptr read-only }
 { length fixnum read-only } ;
 
-INSTANCE: A S
-
 : <A> ( alien len -- direct-array ) A boa ; inline
 M: A length length>> ;
 M: A nth-unsafe underlying>> NTH call ;
@@ -41,5 +39,11 @@ M: A >pprint-sequence ;
 M: A pprint* pprint-object ;
 
 INSTANCE: A sequence
+INSTANCE: A S
+
+T c-type
+    \ A >>direct-array-class
+    \ <A> >>direct-array-constructor
+    drop
 
 ;FUNCTOR

basis/specialized-arrays/functor/functor.factor

@@ -34,8 +34,6 @@ TUPLE: A
 { length array-capacity read-only }
 { underlying byte-array read-only } ;
 
-INSTANCE: A S
-
 : <A> ( n -- specialized-array ) dup T <c-array> A boa ; inline
 
 : (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline
@@ -78,7 +76,14 @@ M: A pprint* pprint-object ;
 SYNTAX: A{ \ } [ >A ] parse-literal ;
 
 INSTANCE: A sequence
+INSTANCE: A S
 
 A T c-type-boxed-class specialize-vector-words
 
+T c-type
+    \ A >>array-class
+    \ <A> >>array-constructor
+    \ S >>sequence-mixin-class
+    drop
+
 ;FUNCTOR

basis/specialized-vectors/functor/functor.factor

@@ -20,8 +20,6 @@ WHERE
 
 V A <A> vectors.functor:define-vector
 
-INSTANCE: V S
-
 M: V contract 2drop ;
 
 M: V byte-length underlying>> byte-length ;
@@ -35,5 +33,6 @@ M: V pprint* pprint-object ;
 SYNTAX: V{ \ } [ >V ] parse-literal ;
 
 INSTANCE: V growable
+INSTANCE: V S
 
 ;FUNCTOR