specialized-arrays: Works as a new functor!!

basis/classes/struct/struct.factor

@@ -144,7 +144,7 @@ M: struct-class initial-value* <struct> t ; inline
 GENERIC: struct-slot-values ( struct -- sequence )
 
 M: struct-class reader-quot
-    dup type>> array? [ dup type>> first define-array-vocab drop ] when
+    dup type>> array? [ dup type>> first underlying-type define-specialized-array ] when
     nip '[ _ read-struct-slot ] ;
 
 M: struct-class writer-quot

basis/specialized-arrays/specialized-arrays.factor

@@ -4,12 +4,14 @@ USING: accessors alien alien.c-types alien.data alien.parser
 byte-arrays classes combinators fry functors kernel lexer locals
 make math math.vectors parser prettyprint.custom sequences
 sequences.private vocabs.generated vocabs.loader vocabs.parser
-words ;
+words math.parser arrays ;
 IN: specialized-arrays
 
 MIXIN: specialized-array
+MIXIN: specialized-array2
 
 INSTANCE: specialized-array sequence
+INSTANCE: specialized-array2 sequence
 
 : (underlying) ( n c-type -- array )
     heap-size * (byte-array) ; inline
@@ -27,8 +29,7 @@ M: c-type-word underlying-type
         [ drop ]
     } cond ;
 
-M: pointer underlying-type
+M: pointer underlying-type drop void* ;
-    drop void* ;
 
 <PRIVATE
 
@@ -38,84 +39,89 @@ GENERIC: direct-like ( alien len exemplar -- seq )
 M: byte-array nth-c-ptr <displaced-alien> ; inline
 M: byte-array direct-like drop uchar <c-direct-array> ; inline
 
-<FUNCTOR: define-array ( T -- )
+PRIVATE>
 
-A          DEFINES-CLASS ${T}-array
+VARIABLES-FUNCTOR: specialized-array ( T -- ) {
-<A>        DEFINES <${A}>
+    { "A" "${T}-array" }
-(A)        DEFINES (${A})
+    { "<A>" "<${A}>" }
-<direct-A> DEFINES <direct-${A}>
+    { "(A)" "(${A})" }
-A{         DEFINES ${A}{
+    { "<direct-A>" "<direct-${A}>" }
+} [[
+USING: accessors alien alien.c-types alien.data byte-arrays
+classes kernel math math.vectors parser prettyprint.custom
+sequences sequences.private specialized-arrays
+specialized-arrays.private ;
 
-WHERE
+<<
-
+TUPLE: ${A}
-TUPLE: A
 { underlying c-ptr read-only }
 { length array-capacity read-only } ; final
 
-: <direct-A> ( alien len -- specialized-array ) A boa ; inline
+INSTANCE: ${A} specialized-array2
 
-M: A direct-like drop <direct-A> ; inline
+: ${<direct-A>} ( alien len -- specialized-array ) ${A} boa ; inline
 
-: <A> ( n -- specialized-array )
+: ${<A>} ( n -- specialized-array )
-    [ \ T <underlying> ] keep <direct-A> ; inline
+    [ \ ${T} <underlying> ] keep ${<direct-A>} ; inline
 
-: (A) ( n -- specialized-array )
+: ${(A)} ( n -- specialized-array )
-    [ \ T (underlying) ] keep <direct-A> ; inline
+    [ \ ${T} (underlying) ] keep ${<direct-A>} ; inline
+>>
 
-M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
+SYNTAX: ${A}{ \ } [ \ ${T} >c-array ] parse-literal ;
 
-M: A length length>> ; inline
+M: ${A} direct-like drop ${<direct-A>} ; inline
 
-M: A nth-unsafe underlying>> \ T alien-element ; inline
+M: ${A} clone [ underlying>> clone ] [ length>> ] bi ${<direct-A>} ; inline
 
-M: A nth-c-ptr underlying>> \ T array-accessor drop swap <displaced-alien> ; inline
+M: ${A} length length>> ; inline
 
-M: A set-nth-unsafe underlying>> \ T set-alien-element ; inline
+M: ${A} nth-unsafe underlying>> \ ${T} alien-element ; inline
 
-M: A like drop dup A instance? [ \ T >c-array ] unless ; inline
+M: ${A} nth-c-ptr underlying>> \ ${T} array-accessor drop swap <displaced-alien> ; inline
 
-M: A new-sequence drop (A) ; inline
+M: ${A} set-nth-unsafe underlying>> \ ${T} set-alien-element ; inline
 
-M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
+M: ${A} like drop dup ${A} instance? [ \ ${T} >c-array ] unless ; inline
 
-M: A resize
+M: ${A} new-sequence drop ${(A)} ; inline
+
+M: ${A} equal? over ${A} instance? [ sequence= ] [ 2drop f ] if ;
+
+M: ${A} resize
     [
-        [ \ T heap-size * ] [ underlying>> ] bi*
+        [ \ ${T} heap-size * ] [ underlying>> ] bi*
         resize-byte-array
     ] [ drop ] 2bi
-    <direct-A> ; inline
+    ${<direct-A>} ; inline
 
-M: A element-size drop \ T heap-size ; inline
+M: ${A} element-size drop \ ${T} heap-size ; inline
 
-M: A underlying-type drop \ T ;
+M: ${A} underlying-type drop \ ${T} ;
 
-M: A pprint-delims drop \ A{ \ } ;
+M: ${A} pprint-delims drop \ ${A}{ \ } ;
 
-M: A >pprint-sequence ;
+M: ${A} >pprint-sequence ;
 
-SYNTAX: A{ \ } [ \ T >c-array ] parse-literal ;
+M: ${A} vs+ [ + \ ${T} c-type-clamp ] 2map ; inline
+M: ${A} vs- [ - \ ${T} c-type-clamp ] 2map ; inline
+M: ${A} vs* [ * \ ${T} c-type-clamp ] 2map ; inline
 
-INSTANCE: A specialized-array
+M: ${A} v*high [ * \ ${T} heap-size neg shift ] 2map ; inline
-
+]]
-M: A vs+ [ + \ T c-type-clamp ] 2map ; inline
-M: A vs- [ - \ T c-type-clamp ] 2map ; inline
-M: A vs* [ * \ T c-type-clamp ] 2map ; inline
-
-M: A v*high [ * \ T heap-size neg shift ] 2map ; inline
-
-;FUNCTOR>
 
+<PRIVATE
 : specialized-array-vocab ( c-type -- vocab )
     [
-        "specialized-arrays.instances." %
+        "specialized-arrays:functors:specialized-array:" %
-        [ vocabulary>> % "." % ]
+        ! [ vocabulary>> % "." % ]
-        [ name>> % ]
+        ! [ name>> % ":" % ]
-        bi
+        [ drop ]
+        [ 1array hashcode number>string % ] bi
     ] "" make ;
 
 :: direct-slice-unsafe ( from to seq -- seq' )
     from seq nth-c-ptr to from - seq direct-like ; inline
-
 PRIVATE>
 
 : direct-slice ( from to seq -- seq' )
@@ -126,11 +132,6 @@ PRIVATE>
 : direct-head* ( seq n -- seq' ) from-end direct-head ; inline
 : direct-tail* ( seq n -- seq' ) from-end direct-tail ; inline
 
-: define-array-vocab ( type -- vocab )
-    underlying-type
-    [ specialized-array-vocab ] [ '[ _ define-array ] ] bi
-    generate-vocab ;
-
 ERROR: specialized-array-vocab-not-loaded c-type ;
 
 M: c-type-word c-array-constructor
@@ -169,13 +170,10 @@ M: c-type-word c-array-type?
 M: pointer c-array-type? drop void* c-array-type? ;
 
 SYNTAX: \SPECIALIZED-ARRAYS:
-    ";" [ parse-c-type define-array-vocab use-vocab ] each-token ;
+    ";" [ parse-c-type define-specialized-array ] each-token ;
 
-SYNTAX: \SPECIALIZED-ARRAY:
+! { "specialized-arrays" "prettyprint" } "specialized-arrays.prettyprint" require-when
-    scan-c-type define-array-vocab use-vocab ;
 
-{ "specialized-arrays" "prettyprint" } "specialized-arrays.prettyprint" require-when
+! { "specialized-arrays" "mirrors" } "specialized-arrays.mirrors" require-when
 
-{ "specialized-arrays" "mirrors" } "specialized-arrays.mirrors" require-when
+! uchar define-specialized-array
-
-uchar define-array-vocab drop

basis/specialized-vectors/specialized-vectors.factor

@@ -79,13 +79,13 @@ PRIVATE>
 SYNTAX: \SPECIALIZED-VECTORS:
     ";" [
         parse-c-type
-        [ define-array-vocab use-vocab ]
+        [ define-specialized-array use-vocab ]
         [ define-vector-vocab use-vocab ] bi
     ] each-token ;
 
 SYNTAX: \SPECIALIZED-VECTOR:
     scan-c-type
-    [ define-array-vocab use-vocab ]
+    [ define-specialized-array use-vocab ]
     [ define-vector-vocab use-vocab ] bi ;
 
 { "specialized-vectors" "mirrors" } "specialized-vectors.mirrors" require-when

basis/tools/deploy/shaker/strip-specialized-arrays.factor

@@ -2,4 +2,4 @@ IN: specialized-arrays
 
 ERROR: cannot-define-array-in-deployed-app type ;
 
-: define-array-vocab ( type -- ) cannot-define-array-in-deployed-app ;
+: define-specialized-array ( type -- ) cannot-define-array-in-deployed-app ;

core/functors2/functors2.factor

@@ -32,6 +32,9 @@ ERROR: not-all-unique seq ;
 : functor-syntax-word-name ( word -- string )
     name>> >upper ":" append ;
 
+: functor-word-name ( word -- string )
+    name>> "-functor" append ;
+
 : functor-instantiated-vocab-name ( functor-word parameters -- string )
     dupd
     '[
@@ -65,7 +68,7 @@ ERROR: not-all-unique seq ;
         ! append the IN: and the FROM: quot generator and the functor code
         [
             append
-            '[ @ over '[ _ <string-reader> _ parse-stream drop ] generate-vocab drop ]
+            '[ @ over '[ _ <string-reader> _ parse-stream drop ] generate-vocab use-vocab ]
         ] dip
     ] 3tri ;
 
@@ -100,7 +103,9 @@ ERROR: not-all-unique seq ;
     ] 3bi ; inline
 
 : make-functor-word ( word effect string -- )
-    nip 1quotation ( -- string ) define-declared ;
+    nip
+    ! [ functor-word-name ] dip
+    1quotation ( -- string ) define-declared ;
 
 : make-variable-functor ( word effect bindings string -- )
     [

extra/classes/struct/vectored/vectored.factor

@@ -8,11 +8,11 @@ IN: classes.struct.vectored
 <PRIVATE
 
 : array-class-of ( type -- array-type )
-    [ define-array-vocab ] [ name>> "-array" append swap lookup-word ] bi ;
+    [ underlying-type define-specialized-array ] [ name>> "-array" append swap lookup-word ] bi ;
 : <array-class>-of ( type -- array-type )
-    [ define-array-vocab ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
+    [ underlying-type define-specialized-array ] [ name>> "<" "-array>" surround swap lookup-word ] bi ;
 : (array-class)-of ( type -- array-type )
-    [ define-array-vocab ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
+    [ underlying-type define-specialized-array ] [ name>> "(" "-array)" surround swap lookup-word ] bi ;
 
 : >vectored-slot ( struct-slot offset -- tuple-slot )
     {