From c171527b8de91a42eb65db842cc9f47e36f84c6f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 7 Jul 2009 14:34:08 -0500
Subject: [PATCH] Add vectors.functor for generating vector types from arrays;
 re-implement bit-vectors and specialized-vectors using this. Add DEFERS
 directive to functors

---
 basis/bit-vectors/bit-vectors-docs.factor     |  4 +--
 basis/bit-vectors/bit-vectors.factor          | 28 ++--------------
 basis/functors/functors.factor                |  2 ++
 .../functor/functor.factor                    | 26 ++++-----------
 basis/vectors/functor/functor.factor          | 33 +++++++++++++++++++
 5 files changed, 45 insertions(+), 48 deletions(-)
 create mode 100644 basis/vectors/functor/functor.factor

diff --git a/basis/bit-vectors/bit-vectors-docs.factor b/basis/bit-vectors/bit-vectors-docs.factor
index f0e4e47586..66d3d603fe 100644
--- a/basis/bit-vectors/bit-vectors-docs.factor
+++ b/basis/bit-vectors/bit-vectors-docs.factor
@@ -22,11 +22,11 @@ HELP: bit-vector
 { $description "The class of resizable bit vectors. See " { $link "bit-vectors" } " for information." } ;
 
 HELP: <bit-vector>
-{ $values { "n" "a positive integer specifying initial capacity" } { "bit-vector" bit-vector } }
+{ $values { "capacity" "a positive integer specifying initial capacity" } { "vector" bit-vector } }
 { $description "Creates a new bit vector that can hold " { $snippet "n" } " bits before resizing." } ;
 
 HELP: >bit-vector
-{ $values { "seq" "a sequence" } { "bit-vector" bit-vector } }
+{ $values { "seq" "a sequence" } { "vector" bit-vector } }
 { $description "Outputs a freshly-allocated bit vector with the same elements as a given sequence." } ;
 
 HELP: ?V{
diff --git a/basis/bit-vectors/bit-vectors.factor b/basis/bit-vectors/bit-vectors.factor
index a238f61244..cdfe48b164 100644
--- a/basis/bit-vectors/bit-vectors.factor
+++ b/basis/bit-vectors/bit-vectors.factor
@@ -2,34 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
 sequences.private growable bit-arrays prettyprint.custom
-parser accessors ;
+parser accessors vectors.functor classes.parser ;
 IN: bit-vectors
 
-TUPLE: bit-vector
-{ underlying bit-array initial: ?{ } }
-{ length array-capacity } ;
-
-: <bit-vector> ( n -- bit-vector )
-    <bit-array> 0 bit-vector boa ; inline
-
-: >bit-vector ( seq -- bit-vector )
-    T{ bit-vector f ?{ } 0 } clone-like ;
-
-M: bit-vector like
-    drop dup bit-vector? [
-        dup bit-array?
-        [ dup length bit-vector boa ] [ >bit-vector ] if
-    ] unless ;
-
-M: bit-vector new-sequence
-    drop [ <bit-array> ] [ >fixnum ] bi bit-vector boa ;
-
-M: bit-vector equal?
-    over bit-vector? [ sequence= ] [ 2drop f ] if ;
-
-M: bit-array new-resizable drop <bit-vector> ;
-
-INSTANCE: bit-vector growable
+<< "bit-vector" create-class-in \ bit-array \ <bit-array> define-vector >>
 
 SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
 
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index b7dab0d6af..6ffc4d8112 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -121,6 +121,8 @@ PRIVATE>
 
 SYNTAX: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ;
 
+SYNTAX: DEFERS [ current-vocab create ] (INTERPOLATE) ;
+
 SYNTAX: DEFINES [ create-in ] (INTERPOLATE) ;
 
 SYNTAX: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ;
diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor
index 412e5b4689..e4534e5948 100644
--- a/basis/specialized-vectors/functor/functor.factor
+++ b/basis/specialized-vectors/functor/functor.factor
@@ -1,37 +1,23 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: functors sequences sequences.private growable
 prettyprint.custom kernel words classes math parser ;
+QUALIFIED: vectors.functor
 IN: specialized-vectors.functor
 
 FUNCTOR: define-vector ( T -- )
 
+V   DEFINES-CLASS ${T}-vector
+
 A   IS      ${T}-array
 <A> IS      <${A}>
 
-V   DEFINES-CLASS ${T}-vector
-<V> DEFINES <${V}>
->V  DEFINES >${V}
+>V  DEFERS >${V}
 V{  DEFINES ${V}{
 
 WHERE
 
-TUPLE: V { underlying A } { length array-capacity } ;
-
-: <V> ( capacity -- vector ) <A> 0 V boa ; inline
-
-M: V like
-    drop dup V instance? [
-        dup A instance? [ dup length V boa ] [ >V ] if
-    ] unless ;
-
-M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
-
-M: A new-resizable drop <V> ;
-
-M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
-
-: >V ( seq -- vector ) V new clone-like ; inline
+V A <A> vectors.functor:define-vector
 
 M: V pprint-delims drop \ V{ \ } ;
 
diff --git a/basis/vectors/functor/functor.factor b/basis/vectors/functor/functor.factor
new file mode 100644
index 0000000000..47a6c2090a
--- /dev/null
+++ b/basis/vectors/functor/functor.factor
@@ -0,0 +1,33 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors sequences sequences.private growable
+kernel words classes math parser ;
+IN: vectors.functor
+
+FUNCTOR: define-vector ( V A <A> -- )
+
+<V> DEFINES <${V}>
+>V  DEFINES >${V}
+
+WHERE
+
+TUPLE: V { underlying A } { length array-capacity } ;
+
+: <V> ( capacity -- vector ) <A> 0 V boa ; inline
+
+M: V like
+    drop dup V instance? [
+        dup A instance? [ dup length V boa ] [ >V ] if
+    ] unless ;
+
+M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
+
+M: A new-resizable drop <V> ;
+
+M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
+
+: >V ( seq -- vector ) V new clone-like ; inline
+
+INSTANCE: V growable
+
+;FUNCTOR