Working on new resizables

core/bit-arrays/bit-arrays.factor

@@ -48,6 +48,9 @@ M: bit-array new drop <bit-array> ;
 M: bit-array equal?
     over bit-array? [ sequence= ] [ 2drop f ] if ;
 
+M: bit-array resize
+    resize-bit-array ;
+
 INSTANCE: bit-array sequence
 INSTANCE: bit-array simple-c-ptr
 INSTANCE: bit-array c-ptr

core/bit-vectors/bit-vectors.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math sequences
+sequences.private growable ;
+IN: bit-vectors
+
+<PRIVATE
+
+: bit-array>vector ( bit-array -- bit-vector )
+    bit-vector construct-boa ; inline
+
+PRIVATE>
+
+: <bit-vector> ( n -- bit-vector )
+    <bit-array> 0 bit-array>vector ; inline
+
+: >bit-vector ( seq -- bit-vector ) V{ } clone-like ;
+
+M: bit-vector like
+    drop dup bit-vector? [
+        dup bit-array?
+        [ dup length bit-array>vector ] [ >bit-vector ] if
+    ] unless ;
+
+M: bit-vector new
+    drop [ <bit-array> ] keep >fixnum bit-array>vector ;
+
+M: bit-vector equal?
+    over bit-vector? [ sequence= ] [ 2drop f ] if ;
+
+INSTANCE: bit-vector growable

core/bootstrap/primitives.factor

@@ -39,11 +39,14 @@ call
     "alien"
     "arrays"
     "bit-arrays"
+    "bit-vectors"
     "byte-arrays"
+    "byte-vectors"
     "classes.private"
     "compiler.units"
     "continuations.private"
     "float-arrays"
+    "float-vectors"
     "generator"
     "growable"
     "hashtables"
@@ -96,12 +99,6 @@ H{ } clone update-map set
 : register-builtin ( class -- )
     dup "type" word-prop builtins get set-nth ;
 
-: intern-slots ( spec -- spec )
-    [
-        [ dup array? [ first2 create ] when ] map
-        { slot-spec f } swap append >tuple
-    ] map ;
-
 : lookup-type-number ( word -- n )
     global [ target-word ] bind type-number ;
 
@@ -110,8 +107,8 @@ H{ } clone update-map set
     dup dup lookup-type-number "type" set-word-prop
     dup f f builtin-class define-class
     dup r> builtin-predicate
-    dup r> intern-slots 2dup "slots" set-word-prop
+    dup r> 1 simple-slots 2dup "slots" set-word-prop
-    define-slots
+    dupd define-slots
     register-builtin ;
 
 H{ } clone typemap set
@@ -137,14 +134,12 @@ num-types get f <array> builtins set
     {
         { "integer" "math" }
         "numerator"
-        1
         { "numerator" "math" }
         f
     }
     {
         { "integer" "math" }
         "denominator"
-        2
         { "denominator" "math" }
         f
     }
@@ -158,14 +153,12 @@ num-types get f <array> builtins set
     {
         { "real" "math" }
         "real-part"
-        1
         { "real-part" "math" }
         f
     }
     {
         { "real" "math" }
         "imaginary-part"
-        2
         { "imaginary-part" "math" }
         f
     }
@@ -182,7 +175,6 @@ num-types get f <array> builtins set
     {
         { "object" "kernel" }
         "wrapped"
-        1
         { "wrapped" "kernel" }
         f
     }
@@ -193,19 +185,16 @@ num-types get f <array> builtins set
     {
         { "array-capacity" "sequences.private" }
         "count"
-        1
         { "hash-count" "hashtables.private" }
         { "set-hash-count" "hashtables.private" }
     } {
         { "array-capacity" "sequences.private" }
         "deleted"
-        2
         { "hash-deleted" "hashtables.private" }
         { "set-hash-deleted" "hashtables.private" }
     } {
         { "array" "arrays" }
         "array"
-        3
         { "hash-array" "hashtables.private" }
         { "set-hash-array" "hashtables.private" }
     }
@@ -216,13 +205,11 @@ num-types get f <array> builtins set
     {
         { "array-capacity" "sequences.private" }
         "fill"
-        1
         { "length" "sequences" }
         { "set-fill" "growable" }
     } {
         { "array" "arrays" }
         "underlying"
-        2
         { "underlying" "growable" }
         { "set-underlying" "growable" }
     }
@@ -233,7 +220,6 @@ num-types get f <array> builtins set
     {
         { "array-capacity" "sequences.private" }
         "length"
-        1
         { "length" "sequences" }
         f
     }
@@ -244,14 +230,12 @@ num-types get f <array> builtins set
     {
         { "array-capacity" "sequences.private" }
         "length"
-        1
         { "length" "sequences" }
         { "set-fill" "growable" }
     }
     {
         { "string" "strings" }
         "underlying"
-        2
         { "underlying" "growable" }
         { "set-underlying" "growable" }
     }
@@ -262,14 +246,12 @@ num-types get f <array> builtins set
     {
         { "object" "kernel" }
         "array"
-        1
         { "quotation-array" "quotations.private" }
         f
     }
     {
         { "object" "kernel" }
         "compiled?"
-        2
         { "quotation-compiled?" "quotations" }
         f
     }
@@ -280,7 +262,6 @@ num-types get f <array> builtins set
     {
         { "byte-array" "byte-arrays" }
         "path"
-        1
         { "(dll-path)" "alien" }
         f
     }
@@ -292,13 +273,11 @@ define-builtin
     {
         { "c-ptr" "alien" }
         "alien"
-        1
         { "underlying-alien" "alien" }
         f
     } {
         { "object" "kernel" }
         "expired?"
-        2
         { "expired?" "alien" }
         f
     }
@@ -307,45 +286,40 @@ define-builtin
 
 "word" "words" create "word?" "words" create
 {
+    f
     {
         { "object" "kernel" }
         "name"
-        2
         { "word-name" "words" }
         { "set-word-name" "words" }
     }
     {
         { "object" "kernel" }
         "vocabulary"
-        3
         { "word-vocabulary" "words" }
         { "set-word-vocabulary" "words" }
     }
     {
         { "quotation" "quotations" }
         "def"
-        4
         { "word-def" "words" }
         { "set-word-def" "words.private" }
     }
     {
         { "object" "kernel" }
         "props"
-        5
         { "word-props" "words" }
         { "set-word-props" "words" }
     }
     {
         { "object" "kernel" }
         "?"
-        6
         { "compiled?" "words" }
         f
     }
     {
         { "fixnum" "math" }
         "counter"
-        7
         { "profile-counter" "tools.profiler.private" }
         { "set-profile-counter" "tools.profiler.private" }
     }
@@ -369,14 +343,12 @@ define-builtin
     {
         { "object" "kernel" }
         "obj"
-        1
         { "curry-obj" "kernel" }
         f
     }
     {
         { "object" "kernel" }
         "obj"
-        2
         { "curry-quot" "kernel" }
         f
     }
@@ -414,6 +386,52 @@ builtins get num-tags get tail f union-class define-class
 "tombstone" "hashtables.private" lookup t
 2array >tuple 1quotation define-inline
 
+! Some tuple classes
+"byte-vector" "byte-vectors" create
+{
+    {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    } {
+        { "byte-array" "byte-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    }
+} define-tuple-class
+
+"bit-vector" "bit-vectors" create
+{
+    {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    } {
+        { "bit-array" "bit-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    }
+} define-tuple-class
+
+"float-vector" "float-vectors" create
+{
+    {
+        { "array-capacity" "sequences.private" }
+        "fill"
+        { "length" "sequences" }
+        { "set-fill" "growable" }
+    } {
+        { "float-array" "float-arrays" }
+        "underlying"
+        { "underlying" "growable" }
+        { "set-underlying" "growable" }
+    }
+} define-tuple-class
+
 ! Primitive words
 : make-primitive ( word vocab n -- )
     >r create dup reset-word r> [ do-primitive ] curry [ ] like define ;

core/byte-arrays/byte-arrays.factor

@@ -15,6 +15,9 @@ M: byte-array new drop <byte-array> ;
 M: byte-array equal?
     over byte-array? [ sequence= ] [ 2drop f ] if ;
 
+M: byte-array resize
+    resize-byte-array ;
+
 INSTANCE: byte-array sequence
 INSTANCE: byte-array simple-c-ptr
 INSTANCE: byte-array c-ptr

core/byte-vectors/byte-vectors.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math sequences
+sequences.private growable ;
+IN: byte-vectors
+
+<PRIVATE
+
+: byte-array>vector ( byte-array -- byte-vector )
+    byte-vector construct-boa ; inline
+
+PRIVATE>
+
+: <byte-vector> ( n -- byte-vector )
+    <byte-array> 0 byte-array>vector ; inline
+
+: >byte-vector ( seq -- byte-vector ) V{ } clone-like ;
+
+M: byte-vector like
+    drop dup byte-vector? [
+        dup byte-array?
+        [ dup length byte-array>vector ] [ >byte-vector ] if
+    ] unless ;
+
+M: byte-vector new
+    drop [ <byte-array> ] keep >fixnum byte-array>vector ;
+
+M: byte-vector equal?
+    over byte-vector? [ sequence= ] [ 2drop f ] if ;
+
+INSTANCE: byte-vector growable

core/float-arrays/float-arrays.factor

@@ -29,6 +29,9 @@ M: float-array new drop 0.0 <float-array> ;
 M: float-array equal?
     over float-array? [ sequence= ] [ 2drop f ] if ;
 
+M: float-array resize
+    resize-float-array ;
+
 INSTANCE: float-array sequence
 INSTANCE: float-array simple-c-ptr
 INSTANCE: float-array c-ptr

core/float-vectors/float-vectors.factor

@@ -0,0 +1,31 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays kernel kernel.private math sequences
+sequences.private growable ;
+IN: float-vectors
+
+<PRIVATE
+
+: float-array>vector ( float-array -- float-vector )
+    float-vector construct-boa ; inline
+
+PRIVATE>
+
+: <float-vector> ( n -- float-vector )
+    <float-array> 0 float-array>vector ; inline
+
+: >float-vector ( seq -- float-vector ) V{ } clone-like ;
+
+M: float-vector like
+    drop dup float-vector? [
+        dup float-array?
+        [ dup length float-array>vector ] [ >float-vector ] if
+    ] unless ;
+
+M: float-vector new
+    drop [ <float-array> ] keep >fixnum float-array>vector ;
+
+M: float-vector equal?
+    over float-vector? [ sequence= ] [ 2drop f ] if ;
+
+INSTANCE: float-vector growable

core/slots/slots.factor

@@ -1,8 +1,8 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel kernel.private math namespaces
 sequences strings words effects generic generic.standard
-classes slots.private ;
+classes slots.private combinators ;
 IN: slots
 
 TUPLE: slot-spec type name offset reader writer ;
@@ -87,14 +87,23 @@ PREDICATE: word slot-writer "writing" word-prop >boolean ;
 : simple-writer-word ( class name -- word )
     (simple-slot-word) writer-word ;
 
-: simple-slot ( class name # -- spec )
+: short-slot ( class name # -- spec )
     >r object bootstrap-word over r> f f <slot-spec>
     2over simple-reader-word over set-slot-spec-reader
     -rot simple-writer-word over set-slot-spec-writer ;
 
+: long-slot ( spec # -- spec )
+    >r [ dup array? [ first2 create ] when ] map first4 r>
+    -rot <slot-spec> ;
+
 : simple-slots ( class slots base -- specs )
-    over length [ + ] with map
+    over length [ + ] with map [
-    [ >r >r dup r> r> simple-slot ] 2map nip ;
+        {
+            { [ over not ] [ 2drop f ] }
+            { [ over string? ] [ >r dupd r> short-slot ] }
+            { [ over array? ] [ long-slot ] }
+        } cond
+    ] 2map [ ] subset nip ;
 
 : slot-of-reader ( reader specs -- spec/f )
     [ slot-spec-reader eq? ] with find nip ;

core/tuples/tuples.factor

@@ -80,8 +80,8 @@ PRIVATE>
     } ;
 
 : define-tuple-slots ( class slots -- )
-    2dup "slot-names" set-word-prop
     dupd 4 simple-slots
+    2dup [ slot-spec-name ] map "slot-names" set-word-prop
     2dup delegate-slot-spec add* "slots" set-word-prop
     define-slots ;
 

vm/types.c

@@ -235,6 +235,34 @@ DEFINE_PRIMITIVE(resize_array)
 	dpush(tag_object(reallot_array(array,capacity,F)));
 }
 
+F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity)
+{
+	CELL to_copy = array_capacity(array);
+	if(capacity < to_copy)
+		to_copy = capacity;
+
+	REGISTER_UNTAGGED(array);
+
+	F_BYTE_ARRAY *new_array = allot_array_internal(untag_header(array->header),capacity);
+
+	UNREGISTER_UNTAGGED(array);
+
+	memcpy(new_array + 1,array + 1,to_copy * CELLS);
+	memset(AREF(new_array,to_copy),0,capacity - to_copy)   ;
+
+	for(i = to_copy; i < capacity; i++)
+		set_array_nth(new_array,i,fill);
+
+	return new_array;
+}
+
+DEFINE_PRIMITIVE(resize_array)
+{
+	F_ARRAY* array = untag_array(dpop());
+	CELL capacity = unbox_array_size();
+	dpush(tag_object(reallot_array(array,capacity,F)));
+}
+
 DEFINE_PRIMITIVE(array_to_vector)
 {
 	F_VECTOR *vector = allot_object(VECTOR_TYPE,sizeof(F_VECTOR));