growable vocabulary: make 'contract' generic so that only real vectors clear popped elements; add resize method for struct-arrays, add new struct-vectors vocabulary

basis/bit-vectors/bit-vectors.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math sequences
 sequences.private growable bit-arrays prettyprint.custom
@@ -9,6 +9,7 @@ IN: bit-vectors
 
 SYNTAX: ?V{ \ } [ >bit-vector ] parse-literal ;
 
+M: bit-vector contract 2drop ;
 M: bit-vector >pprint-sequence ;
 M: bit-vector pprint-delims drop \ ?V{ \ } ;
 M: bit-vector pprint* pprint-object ;

basis/specialized-vectors/functor/functor.factor

@@ -19,6 +19,8 @@ WHERE
 
 V A <A> vectors.functor:define-vector
 
+M: V contract 2drop ;
+
 M: V pprint-delims drop \ V{ \ } ;
 
 M: V >pprint-sequence ;

basis/struct-arrays/struct-arrays-tests.factor

@@ -36,3 +36,5 @@ C-STRUCT: test-struct
         &free drop
     ] with-destructors
 ] unit-test
+
+[ 15 ] [ 15 10 "point" <struct-array> resize length ] unit-test

basis/struct-arrays/struct-arrays.factor

@@ -20,6 +20,10 @@ M: struct-array set-nth-unsafe
 M: struct-array new-sequence
     element-size>> [ * <byte-array> ] 2keep struct-array boa ; inline
 
+M: struct-array resize ( n seq -- newseq )
+    [ [ element-size>> * ] [ underlying>> ] bi resize ] [ element-size>> ] 2bi
+    struct-array boa ;
+
 : <struct-array> ( length c-type -- struct-array )
     heap-size [ * <byte-array> ] 2keep struct-array boa ; inline
 

basis/struct-vectors/struct-vectors-docs.factor

@@ -0,0 +1,16 @@
+IN: struct-vectors
+USING: help.markup help.syntax alien strings math ;
+
+HELP: struct-vector
+{ $class-description "The class of growable C struct and union arrays." } ;
+
+HELP: <struct-vector>
+{ $values { "capacity" integer } { "c-type" string } { "struct-vector" struct-vector } }
+{ $description "Creates a new vector with the given initial capacity." } ;
+
+ARTICLE: "struct-vectors" "C struct and union vectors"
+"The " { $vocab-link "struct-vectors" } " vocabulary implements vectors specialized for holding C struct and union values. These are growable versions of " { $vocab-link "struct-arrays" } "."
+{ $subsection struct-vector }
+{ $subsection <struct-vector> } ;
+
+ABOUT: "struct-vectors"

basis/struct-vectors/struct-vectors-tests.factor

@@ -0,0 +1,20 @@
+IN: struct-vectors.tests
+USING: struct-vectors tools.test alien.c-types kernel sequences ;
+
+C-STRUCT: point
+    { "float" "x" }
+    { "float" "y" } ;
+
+: make-point ( x y -- point )
+    "point" <c-object>
+    [ set-point-y ] keep
+    [ set-point-x ] keep ;
+
+[ ] [ 1 "point" <struct-vector> "v" set ] unit-test
+
+[ 1.5 6.0 ] [
+    1.0 2.0 make-point "v" get push
+    3.0 4.5 make-point "v" get push
+    1.5 6.0 make-point "v" get push
+    "v" get pop [ point-x ] [ point-y ] bi
+] unit-test

basis/struct-vectors/struct-vectors.factor

@@ -0,0 +1,23 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors byte-arrays growable kernel math sequences
+sequences.private struct-arrays ;
+IN: struct-vectors
+
+TUPLE: struct-vector
+{ underlying struct-array }
+{ length array-capacity }
+{ c-type read-only } ;
+
+: <struct-vector> ( capacity c-type -- struct-vector )
+    [ <struct-array> 0 ] keep struct-vector boa ; inline
+
+M: struct-vector new-sequence
+    [ c-type>> <struct-array> ] [ [ >fixnum ] [ c-type>> ] bi ] 2bi
+    struct-vector boa ;
+
+M: struct-vector contract 2drop ;
+
+M: struct-array new-resizable c-type>> <struct-vector> ;
+
+INSTANCE: struct-vector growable

core/byte-vectors/byte-vectors.factor

@@ -26,6 +26,8 @@ M: byte-vector new-sequence
 M: byte-vector equal?
     over byte-vector? [ sequence= ] [ 2drop f ] if ;
 
+M: byte-vector contract 2drop ;
+
 M: byte-array like
     #! If we have an byte-array, we're done.
     #! If we have a byte-vector, and it's at full capacity,

core/growable/growable.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel kernel.private math math.private
 sequences sequences.private ;
@@ -18,10 +18,12 @@ M: growable set-nth-unsafe underlying>> set-nth-unsafe ;
 : expand ( len seq -- )
     [ resize ] change-underlying drop ; inline
 
-: contract ( len seq -- )
+GENERIC: contract ( len seq -- )
+
+M: growable contract ( len seq -- )
     [ length ] keep
     [ [ 0 ] 2dip set-nth-unsafe ] curry
-    (each-integer) ; inline
+    (each-integer) ;
 
 : growable-check ( n seq -- n seq )
     over 0 < [ bounds-error ] when ; inline