specialized-arrays, specialized-vectors: fix some code duplication and prettyprinting

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -1,9 +1,10 @@
 IN: specialized-arrays.tests
 USING: tools.test alien.syntax specialized-arrays
-specialized-arrays sequences alien.c-types accessors
+specialized-arrays.private sequences alien.c-types accessors
-kernel arrays combinators compiler classes.struct
+kernel arrays combinators compiler compiler.units classes.struct
 combinators.smart compiler.tree.debugger math libc destructors
-sequences.private ;
+sequences.private multiline eval words vocabs namespaces
+assocs prettyprint ;
 
 SPECIALIZED-ARRAY: int
 SPECIALIZED-ARRAY: bool
@@ -106,3 +107,43 @@ SPECIALIZED-ARRAY: fixed-string
 [ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
     ALIEN: 123 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
 ] unit-test
+
+! Ensure that byte-length works with direct arrays
+[ 400 ] [
+    ALIEN: 123 100 <direct-int-array> byte-length
+] unit-test
+
+! Test prettyprinting
+[ "int-array{ 1 2 3 }" ] [ int-array{ 1 2 3 } unparse ] unit-test
+[ "int-array@ f 100" ] [ f 100 <direct-int-array> unparse ] unit-test
+
+! If the C type doesn't exist, don't generate a vocab
+[ ] [
+    [ "__does_not_exist__" specialized-array-vocab forget-vocab ] with-compilation-unit
+    "__does_not_exist__" c-types get delete-at
+] unit-test
+
+[
+    <"
+IN: specialized-arrays.tests
+USING: specialized-arrays ;
+
+SPECIALIZED-ARRAY: __does_not_exist__ "> eval( -- )
+] must-fail
+
+[ ] [
+    <"
+IN: specialized-arrays.tests
+USING: classes.struct specialized-arrays ;
+
+STRUCT: __does_not_exist__ { x int } ;
+
+SPECIALIZED-ARRAY: __does_not_exist__
+"> eval( -- )
+] unit-test
+
+[ f ] [
+    "__does_not_exist__-array{"
+    "__does_not_exist__" specialized-array-vocab lookup
+    deferred?
+] unit-test

basis/specialized-arrays/specialized-arrays.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types assocs byte-arrays classes
-compiler.units functors io kernel lexer libc math
+compiler.units functors kernel lexer libc math
-math.vectors.specialization namespaces parser
+math.vectors.specialization namespaces parser prettyprint.custom
-prettyprint.custom sequences sequences.private strings summary
+sequences sequences.private strings summary vocabs vocabs.loader
-vocabs vocabs.loader vocabs.parser words ;
+vocabs.parser words fry combinators ;
 IN: specialized-arrays
 
 MIXIN: specialized-array
@@ -86,8 +86,12 @@ M: A resize
     ] [ drop ] 2bi
     <direct-A> ; inline
 
-M: A byte-length underlying>> length ; inline
+M: A byte-length length T heap-size * ; inline
+
+M: A direct-array-syntax drop \ A@ ;
+
 M: A pprint-delims drop \ A{ \ } ;
+
 M: A >pprint-sequence ;
 
 SYNTAX: A{ \ } [ >A ] parse-literal ;
@@ -100,34 +104,30 @@ A T c-type-boxed-class f specialize-vector-words
 ;FUNCTOR
 
 : underlying-type ( c-type -- c-type' )
-    dup c-types get at string? [
+    dup c-types get at {
-        c-types get at underlying-type
+        { [ dup not ] [ drop no-c-type ] }
-    ] when ;
+        { [ dup string? ] [ nip underlying-type ] }
+        [ drop ]
+    } cond ;
 
 : specialized-array-vocab ( c-type -- vocab )
     "specialized-arrays.instances." prepend ;
 
-: defining-array-message ( type -- )
-    "quiet" get [ drop ] [
-        "Generating specialized " " arrays..." surround print
-    ] if ;
-
 PRIVATE>
 
+: generate-vocab ( vocab-name quot -- vocab )
+    [ dup vocab [ ] ] dip '[
+        [
+            [
+                 _ with-current-vocab
+            ] with-compilation-unit
+        ] keep
+    ] ?if ; inline
+
 : define-array-vocab ( type -- vocab )
     underlying-type
-    dup specialized-array-vocab vocab
+    [ specialized-array-vocab ] [ '[ _ define-array ] ] bi
-    [ ] [
+    generate-vocab ;
-        [ defining-array-message ]
-        [
-            [
-                dup specialized-array-vocab
-                [ define-array ] with-current-vocab
-            ] with-compilation-unit
-        ]
-        [ specialized-array-vocab ]
-        tri
-    ] ?if ;
 
 M: string require-c-array define-array-vocab drop ;
 

basis/specialized-vectors/specialized-vectors.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien.c-types assocs compiler.units functors
-growable io kernel lexer namespaces parser prettyprint.custom
+growable kernel lexer namespaces parser prettyprint.custom
 sequences specialized-arrays specialized-arrays.private strings
 vocabs vocabs.parser ;
 QUALIFIED: vectors.functor
@@ -44,27 +44,12 @@ INSTANCE: V S
 : specialized-vector-vocab ( type -- vocab )
     "specialized-vectors.instances." prepend ;
 
-: defining-vector-message ( type -- )
-    "quiet" get [ drop ] [
-        "Generating specialized " " vectors..." surround print
-    ] if ;
-
 PRIVATE>
 
 : define-vector-vocab ( type -- vocab )
     underlying-type
-    dup specialized-vector-vocab vocab
+    [ specialized-vector-vocab ] [ '[ _ define-vector ] ] bi
-    [ ] [
+    generate-vocab ;
-        [ defining-vector-message ]
-        [
-            [
-                dup specialized-vector-vocab
-                [ define-vector ] with-current-vocab
-            ] with-compilation-unit
-        ]
-        [ specialized-vector-vocab ]
-        tri
-    ] ?if ;
 
 SYNTAX: SPECIALIZED-VECTOR:
     scan