functors: workin on it

basis/bit-vectors/bit-vectors.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel kernel.private math sequences
+USING: bit-arrays classes growable kernel math parser
-sequences.private growable bit-arrays prettyprint.custom
+prettyprint.custom sequences sequences.private vectors.functor ;
-parser accessors vectors.functor classes.parser ;
 IN: bit-vectors
 
-SPECIAL-VECTOR: bit-vector bit-array
+VECTORIZED: bit bit-array <bit-array>
 
 SYNTAX: \?V{ \ } [ >bit-vector ] parse-literal ;
 

basis/specialized-arrays/specialized-arrays.factor

@@ -41,8 +41,8 @@ M: byte-array direct-like drop uchar <c-direct-array> ; inline
 
 PRIVATE>
 
-VARIABLES-FUNCTOR: specialized-array ( T: existing-word -- ) {
+VARIABLES-FUNCTOR: specialized-array ( type: existing-word -- ) {
-    { "A" "${T}-array" }
+    { "A" "${type}-array" }
     { "<A>" "<${A}>" }
     { "(A)" "(${A})" }
     { "<direct-A>" "<direct-${A}>" }
@@ -62,13 +62,13 @@ INSTANCE: ${A} specialized-array-mixin
 : ${<direct-A>} ( alien len -- specialized-array ) ${A} boa ; inline
 
 : ${<A>} ( n -- specialized-array )
-    [ \ ${T} <underlying> ] keep ${<direct-A>} ; inline
+    [ \ ${type} <underlying> ] keep ${<direct-A>} ; inline
 
 : ${(A)} ( n -- specialized-array )
-    [ \ ${T} (underlying) ] keep ${<direct-A>} ; inline
+    [ \ ${type} (underlying) ] keep ${<direct-A>} ; inline
 >>
 
-SYNTAX: ${A}{ \ } [ \ ${T} >c-array ] parse-literal ;
+SYNTAX: ${A}{ \ } [ \ ${type} >c-array ] parse-literal ;
 
 M: ${A} direct-like drop ${<direct-A>} ; inline
 
@@ -76,13 +76,13 @@ M: ${A} clone [ underlying>> clone ] [ length>> ] bi ${<direct-A>} ; inline
 
 M: ${A} length length>> ; inline
 
-M: ${A} nth-unsafe underlying>> \ ${T} alien-element ; inline
+M: ${A} nth-unsafe underlying>> \ ${type} alien-element ; inline
 
-M: ${A} nth-c-ptr underlying>> \ ${T} array-accessor drop swap <displaced-alien> ; inline
+M: ${A} nth-c-ptr underlying>> \ ${type} array-accessor drop swap <displaced-alien> ; inline
 
-M: ${A} set-nth-unsafe underlying>> \ ${T} set-alien-element ; inline
+M: ${A} set-nth-unsafe underlying>> \ ${type} set-alien-element ; inline
 
-M: ${A} like drop dup ${A} instance? [ \ ${T} >c-array ] unless ; inline
+M: ${A} like drop dup ${A} instance? [ \ ${type} >c-array ] unless ; inline
 
 M: ${A} new-sequence drop ${(A)} ; inline
 
@@ -90,24 +90,24 @@ M: ${A} equal? over ${A} instance? [ sequence= ] [ 2drop f ] if ;
 
 M: ${A} resize
     [
-        [ \ ${T} heap-size * ] [ underlying>> ] bi*
+        [ \ ${type} heap-size * ] [ underlying>> ] bi*
         resize-byte-array
     ] [ drop ] 2bi
     ${<direct-A>} ; inline
 
-M: ${A} element-size drop \ ${T} heap-size ; inline
+M: ${A} element-size drop \ ${type} heap-size ; inline
 
-M: ${A} underlying-type drop \ ${T} ;
+M: ${A} underlying-type drop \ ${type} ;
 
 M: ${A} pprint-delims drop \ ${A}{ \ } ;
 
 M: ${A} >pprint-sequence ;
 
-M: ${A} vs+ [ + \ ${T} c-type-clamp ] 2map ; inline
+M: ${A} vs+ [ + \ ${type} c-type-clamp ] 2map ; inline
-M: ${A} vs- [ - \ ${T} c-type-clamp ] 2map ; inline
+M: ${A} vs- [ - \ ${type} c-type-clamp ] 2map ; inline
-M: ${A} vs* [ * \ ${T} c-type-clamp ] 2map ; inline
+M: ${A} vs* [ * \ ${type} c-type-clamp ] 2map ; inline
 
-M: ${A} v*high [ * \ ${T} heap-size neg shift ] 2map ; inline
+M: ${A} v*high [ * \ ${type} heap-size neg shift ] 2map ; inline
 ]]
 
 <PRIVATE

basis/specialized-vectors/specialized-vectors-tests.factor

@@ -1,10 +1,10 @@
 IN: specialized-vectors.tests
 USING: specialized-arrays specialized-vectors
 tools.test kernel sequences alien.c-types vectors.functor ;
-SPECIALIZED-ARRAY: float
+SPECIALIZED-ARRAYS: float double ;
 SPECIALIZED-VECTORS: float double ;
-SPECIAL-VECTOR: double
+VECTORIZED: double double-array <double-array>
-SPECIAL-VECTOR: float
+VECTORIZED: float float-array <float-array>
 
 { 3 } [ double-vector{ 1 2 } 3 suffix! length ] unit-test
 

basis/specialized-vectors/specialized-vectors.factor

@@ -8,7 +8,7 @@ IN: specialized-vectors
 
 MIXIN: specialized-vector
 
-FUNCTOR: specialized-vector ( T: existing-word -- ) [[
+FUNCTOR: specialized-vector ( type: existing-word -- ) [[
 
 USING: accessors alien alien.c-types alien.data classes growable
 kernel math parser prettyprint.custom sequences
@@ -16,39 +16,40 @@ sequences.private specialized-arrays specialized-arrays.private
 specialized-vectors vectors.functor ;
 FROM: specialized-arrays.private => nth-c-ptr direct-like ;
 
-SPECIALIZED-ARRAY: ${T}
+<<
+SPECIALIZED-ARRAY: ${type}
+>>
 
 <<
 ! For >foo-vector to be defined in time
-SPECIAL-VECTOR: ${T}
+VECTORIZED: ${type} ${type}-array <${type}-array>
 >>
 
-SYNTAX: ${T}-vector{ \ } [ >${T}-vector ] parse-literal ;
+SYNTAX: ${type}-vector{ \ } [ >${type}-vector ] parse-literal ;
 
-INSTANCE: ${T}-vector specialized-vector
+INSTANCE: ${type}-vector specialized-vector
-INSTANCE: ${T}-vector growable
 
-M: ${T}-vector contract 2drop ; inline
+M: ${type}-vector contract 2drop ; inline
 
-M: ${T}-vector element-size drop \ ${T} heap-size ; inline
+M: ${type}-vector element-size drop \ ${type} heap-size ; inline
 
-M: ${T}-vector pprint-delims drop \ ${T}-vector{ \ } ;
+M: ${type}-vector pprint-delims drop \ ${type}-vector{ \ } ;
 
-M: ${T}-vector >pprint-sequence ;
+M: ${type}-vector >pprint-sequence ;
 
-M: ${T}-vector pprint* pprint-object ;
+M: ${type}-vector pprint* pprint-object ;
 
-M: ${T}-vector >c-ptr underlying>> underlying>> ; inline
+M: ${type}-vector >c-ptr underlying>> underlying>> ; inline
-M: ${T}-vector byte-length [ length ] [ element-size ] bi * ; inline
+M: ${type}-vector byte-length [ length ] [ element-size ] bi * ; inline
 
-M: ${T}-vector direct-like drop <direct-${T}-array> ; inline
+M: ${type}-vector direct-like drop <direct-${type}-array> ; inline
-M: ${T}-vector nth-c-ptr underlying>> nth-c-ptr ; inline
+M: ${type}-vector nth-c-ptr underlying>> nth-c-ptr ; inline
 
-M: ${T}-array like
+M: ${type}-array like
-    drop dup ${T}-array instance? [
+    drop dup ${type}-array instance? [
-        dup ${T}-vector instance? [
+        dup ${type}-vector instance? [
-            [ >c-ptr ] [ length>> ] bi <direct-${T}-array>
+            [ >c-ptr ] [ length>> ] bi <direct-${type}-array>
-        ] [ \ ${T} >c-array ] if
+        ] [ \ ${type} >c-array ] if
     ] unless ; inline
 
 ]]

basis/vectors/functor/functor.factor

@@ -4,28 +4,32 @@ USING: classes functors growable kernel math sequences
 sequences.private functors2 ;
 IN: vectors.functor
 
-SAME-FUNCTOR: special-vector ( vector: name underlying: existing-class -- ) [[
+! VECTORIZED: bit bit-array <bit-array> ! bit is not necessarily a word
-    USING: classes growable kernel math sequences sequences.private
+! VECTORIZED: int int-array <int-array> ! int is a word already
-    specialized-arrays ;
 
-    TUPLE: ${vector} { underlying ${underlying} } { length array-capacity } ;
+SAME-FUNCTOR: vectorized ( type: name underlying: existing-word constructor: existing-word -- ) [[
+    USING: classes growable kernel math sequences sequences.private ;
 
-    : >${vector} ( seq -- vector ) ${vector} new clone-like ; inline
+    <<
+    TUPLE: ${type}-vector { underlying ${underlying} } { length array-capacity } ;
+    >>
 
-    : <${vector}> ( capacity -- vector ) <${underlying}> 0 ${vector} boa ; inline
+    : >${type}-vector ( seq -- vector ) ${type}-vector new clone-like ; inline
 
-    M: ${vector} like
+    : <${type}-vector> ( capacity -- vector ) ${constructor} 0 ${type}-vector boa ; inline
-        drop dup ${vector} instance? [
+
-            dup ${underlying} instance? [ dup length ${vector} boa ] [ >${vector} ] if
+    M: ${type}-vector like
+        drop dup ${type}-vector instance? [
+            dup ${underlying} instance? [ dup length ${type}-vector boa ] [ >${type}-vector ] if
         ] unless ; inline
 
-    M: ${vector} new-sequence drop [ <${underlying}> ] [ >fixnum ] bi ${vector} boa ; inline
+    M: ${type}-vector new-sequence drop [ ${constructor} ] [ >fixnum ] bi ${type}-vector boa ; inline
 
-    M: ${underlying} new-resizable drop <${vector}> ; inline
+    M: ${underlying} new-resizable drop <${type}-vector> ; inline
 
-    M: ${vector} new-resizable drop <${vector}> ; inline
+    M: ${type}-vector new-resizable drop <${type}-vector> ; inline
 
-    M: ${vector} equal? over ${vector} instance? [ sequence= ] [ 2drop f ] if ;
+    M: ${type}-vector equal? over ${type}-vector instance? [ sequence= ] [ 2drop f ] if ;
 
-    INSTANCE: ${vector} growable
+    INSTANCE: ${type}-vector growable
 ]]

core/functors2/functors2.factor

@@ -63,8 +63,12 @@ ERROR: not-all-unique seq ;
         ] [
             [
                 [
-                    [ dup word? [ vocabulary>> ] [ drop current-vocab name>> ] if ] [ dup word? [ name>> ] when ] bi
+                    dup { [ word? ] } 1|| [
-                    " => " glue "FROM: " " ;\n" surround
+                        [ dup word? [ vocabulary>> ] [ drop current-vocab name>> ] if ] [ dup word? [ name>> ] when ] bi
+                        " => " glue "FROM: " " ;\n" surround
+                    ] [
+                        drop ""
+                    ] if
                 ]
             ] replicate
         ] [ ] tri dup
@@ -75,7 +79,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 use-vocab ]
+            '[ @ over '[ _ <string-reader> _ parse-stream call( -- ) ] generate-vocab use-vocab ]
         ] dip
     ] 3tri ;