steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Working on new resizables

db4
Slava Pestov 2008-01-28 18:15:21 -06:00
parent bc67dbb2f2
commit 03db080df7
10 changed files with 197 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
core/bit-arrays/bit-arrays.factor
View File

@ -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

31
core/bit-vectors/bit-vectors.factor Executable file
View File

@ -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

86
core/bootstrap/primitives.factor
View File

@ -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 <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 ;

3
core/byte-arrays/byte-arrays.factor
View File

@ -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

31
core/byte-vectors/byte-vectors.factor Executable file
View File

@ -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

3
core/float-arrays/float-arrays.factor
View File

@ -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

31
core/float-vectors/float-vectors.factor Executable file
View File

@ -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

19
core/slots/slots.factor
View File

@ -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
[ >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 ;

2
core/tuples/tuples.factor Normal file → Executable file
View File

@ -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 ;

28
vm/types.c
View File

@ -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));