diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index 3b847a0060..4c68d94aad 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -48,6 +48,9 @@ M: bit-array new drop ; 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 diff --git a/core/bit-vectors/bit-vectors.factor b/core/bit-vectors/bit-vectors.factor new file mode 100755 index 0000000000..713f7b8a93 --- /dev/null +++ b/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 + +vector ( bit-array -- bit-vector ) + bit-vector construct-boa ; inline + +PRIVATE> + +: ( n -- bit-vector ) + 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 [ ] keep >fixnum bit-array>vector ; + +M: bit-vector equal? + over bit-vector? [ sequence= ] [ 2drop f ] if ; + +INSTANCE: bit-vector growable diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a88729f539..5a928693bc 100755 --- a/core/bootstrap/primitives.factor +++ b/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 - define-slots + dup r> 1 simple-slots 2dup "slots" set-word-prop + dupd define-slots register-builtin ; H{ } clone typemap set @@ -137,14 +134,12 @@ num-types get f builtins set { { "integer" "math" } "numerator" - 1 { "numerator" "math" } f } { { "integer" "math" } "denominator" - 2 { "denominator" "math" } f } @@ -158,14 +153,12 @@ num-types get f 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 builtins set { { "object" "kernel" } "wrapped" - 1 { "wrapped" "kernel" } f } @@ -193,19 +185,16 @@ num-types get f 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 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 builtins set { { "array-capacity" "sequences.private" } "length" - 1 { "length" "sequences" } f } @@ -244,14 +230,12 @@ num-types get f 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 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 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 ; diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index f82569c270..401b151ad0 100755 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -15,6 +15,9 @@ M: byte-array new drop ; 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 diff --git a/core/byte-vectors/byte-vectors.factor b/core/byte-vectors/byte-vectors.factor new file mode 100755 index 0000000000..bf3f01fb72 --- /dev/null +++ b/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 + +vector ( byte-array -- byte-vector ) + byte-vector construct-boa ; inline + +PRIVATE> + +: ( n -- byte-vector ) + 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 [ ] keep >fixnum byte-array>vector ; + +M: byte-vector equal? + over byte-vector? [ sequence= ] [ 2drop f ] if ; + +INSTANCE: byte-vector growable diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor index ba0b2bb61d..445edd550a 100755 --- a/core/float-arrays/float-arrays.factor +++ b/core/float-arrays/float-arrays.factor @@ -29,6 +29,9 @@ M: float-array new drop 0.0 ; 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 diff --git a/core/float-vectors/float-vectors.factor b/core/float-vectors/float-vectors.factor new file mode 100755 index 0000000000..fe623801dd --- /dev/null +++ b/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 + +vector ( float-array -- float-vector ) + float-vector construct-boa ; inline + +PRIVATE> + +: ( n -- float-vector ) + 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 [ ] keep >fixnum float-array>vector ; + +M: float-vector equal? + over float-vector? [ sequence= ] [ 2drop f ] if ; + +INSTANCE: float-vector growable diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 4517ee4363..cd523b05c1 100755 --- a/core/slots/slots.factor +++ b/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 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 ; + : simple-slots ( class slots base -- specs ) - over length [ + ] with map - [ >r >r dup r> r> simple-slot ] 2map nip ; + over length [ + ] with map [ + { + { [ 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 ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor old mode 100644 new mode 100755 index 9c7b5c960a..306c7f4726 --- a/core/tuples/tuples.factor +++ b/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 ; diff --git a/vm/types.c b/vm/types.c index 51dd4c3da4..063b5e966a 100755 --- a/vm/types.c +++ b/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));