diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index c3ae644b47..ae148e3ac0 100644 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -204,7 +204,7 @@ M: byte-array byte-length length ; dup length [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) - [ nip dup ] 2keep memcpy ; + [ nip (byte-array) dup ] 2keep memcpy ; : byte-array>memory ( byte-array base -- ) swap dup length memcpy ; diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor index 78355a4670..fb7292b989 100644 --- a/basis/bootstrap/stage2.factor +++ b/basis/bootstrap/stage2.factor @@ -100,4 +100,8 @@ SYMBOL: bootstrap-time "output-image" get save-image-and-exit ] if -] [ drop "resource:basis/bootstrap/bootstrap-error.factor" run-file ] recover +] [ + drop + load-help? off + "resource:basis/bootstrap/bootstrap-error.factor" run-file +] recover diff --git a/basis/byte-vectors/byte-vectors.factor b/basis/byte-vectors/byte-vectors.factor index e24c808bbc..d146017db0 100644 --- a/basis/byte-vectors/byte-vectors.factor +++ b/basis/byte-vectors/byte-vectors.factor @@ -10,7 +10,7 @@ TUPLE: byte-vector { length array-capacity } ; : ( n -- byte-vector ) - 0 byte-vector boa ; inline + (byte-array) 0 byte-vector boa ; inline : >byte-vector ( seq -- byte-vector ) T{ byte-vector f B{ } 0 } clone-like ; @@ -22,7 +22,7 @@ M: byte-vector like ] unless ; M: byte-vector new-sequence - drop [ ] [ >fixnum ] bi byte-vector boa ; + drop [ (byte-array) ] [ >fixnum ] bi byte-vector boa ; M: byte-vector equal? over byte-vector? [ sequence= ] [ 2drop f ] if ; diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index ceac5e960c..3a4c702bc5 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -54,15 +54,19 @@ IN: compiler.cfg.intrinsics.allot : bytes>cells ( m -- n ) cell align cell /i ; -:: emit- ( node -- ) - [let | len [ node node-input-infos first literal>> ] | - len expand-? [ - [let | elt [ 0 ^^load-literal ] - reg [ len ^^allot-byte-array ] | - ds-drop - len reg store-length - elt reg len bytes>cells store-initial-element - reg ds-push - ] - ] [ node emit-primitive ] if - ] ; +: emit-allot-byte-array ( len -- dst ) + ds-drop + dup ^^allot-byte-array + [ store-length ] [ ds-push ] [ ] tri ; + +: emit-(byte-array) ( node -- ) + dup node-input-infos first literal>> dup expand-? + [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; + +: emit- ( node -- ) + dup node-input-infos first literal>> dup expand-? [ + nip + [ 0 ^^load-literal ] dip + [ emit-allot-byte-array ] keep + bytes>cells store-initial-element + ] [ drop emit-primitive ] if ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 6656cd11f7..5f75330865 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -52,6 +52,7 @@ IN: compiler.cfg.intrinsics classes.tuple.private: arrays: byte-arrays: + byte-arrays:(byte-array) math.private: math.private: kernel: @@ -139,6 +140,7 @@ IN: compiler.cfg.intrinsics { \ classes.tuple.private: [ emit- iterate-next ] } { \ arrays: [ emit- iterate-next ] } { \ byte-arrays: [ emit- iterate-next ] } + { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } { \ math.private: [ emit-simple-allot iterate-next ] } { \ math.private: [ emit-simple-allot iterate-next ] } { \ kernel: [ emit-simple-allot iterate-next ] } diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 83e71c3363..8192b1c520 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -14,12 +14,13 @@ IN: compiler.tree.propagation.slots UNION: fixed-length-sequence array byte-array string ; : sequence-constructor? ( word -- ? ) - { } memq? ; + { (byte-array) } memq? ; : constructor-output-class ( word -- class ) { { array } { byte-array } + { (byte-array) byte-array } { string } } at ; diff --git a/basis/specialized-arrays/double/double.factor b/basis/specialized-arrays/double/double.factor index 0501458532..02e47ca140 100644 --- a/basis/specialized-arrays/double/double.factor +++ b/basis/specialized-arrays/double/double.factor @@ -9,6 +9,8 @@ USING: hints math.vectors arrays kernel math accessors sequences ; HINTS: { 2 } { 3 } ; +HINTS: (double-array) { 2 } { 3 } ; + HINTS: vneg { array } { double-array } ; HINTS: v*n { array object } { double-array float } ; HINTS: n*v { array object } { float double-array } ; diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 2894649428..579da5b84a 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -10,10 +10,14 @@ ERROR: bad-byte-array-length byte-array type ; M: bad-byte-array-length summary drop "Byte array length doesn't divide type width" ; +: (c-array) ( n c-type -- array ) + heap-size * (byte-array) ; inline + FUNCTOR: define-array ( T -- ) A DEFINES ${T}-array DEFINES <${A}> +(A) DEFINES (${A}) >A DEFINES >${A} byte-array>A DEFINES byte-array>${A} A{ DEFINES ${A}{ @@ -29,6 +33,8 @@ TUPLE: A : ( n -- specialized-array ) dup T A boa ; inline +: (A) ( n -- specialized-array ) dup T (c-array) A boa ; inline + : byte-array>A ( byte-array -- specialized-array ) dup length T heap-size /mod 0 = [ drop T bad-byte-array-length ] unless swap A boa ; inline @@ -45,7 +51,7 @@ M: A set-nth-unsafe underlying>> SET-NTH call ; M: A like drop dup A instance? [ >A execute ] unless ; -M: A new-sequence drop execute ; +M: A new-sequence drop (A) execute ; M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ; diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index a998e5394b..bce42f1456 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -480,6 +480,9 @@ M: object infer-call* \ { integer } { byte-array } define-primitive \ make-flushable +\ (byte-array) { integer } { byte-array } define-primitive +\ (byte-array) make-flushable + \ { integer c-ptr } { c-ptr } define-primitive \ make-flushable diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor index 27358b53fc..8915d2d611 100644 --- a/basis/tools/walker/walker.factor +++ b/basis/tools/walker/walker.factor @@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words sequences.private assocs models models.filter arrays accessors -generic generic.standard definitions make ; +generic generic.standard definitions make sbufs ; IN: tools.walker SYMBOL: show-walker-hook ! ( status continuation thread -- ) @@ -147,6 +147,7 @@ SYMBOL: +stopped+ { (call-next-method) [ (step-into-call-next-method) ] } } [ "step-into" set-word-prop ] assoc-each +! Never step into these words { >n ndrop >c c> continue continue-with diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index cc05efc46e..6cc97531a4 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -468,6 +468,7 @@ tuple { "dlsym" "alien" } { "dlclose" "alien" } { "" "byte-arrays" } + { "(byte-array)" "byte-arrays" } { "" "alien" } { "alien-signed-cell" "alien.accessors" } { "set-alien-signed-cell" "alien.accessors" } diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor index f981e758d7..f0d188ce4a 100644 --- a/core/byte-arrays/byte-arrays.factor +++ b/core/byte-arrays/byte-arrays.factor @@ -9,7 +9,7 @@ M: byte-array length length>> ; M: byte-array nth-unsafe swap >fixnum alien-unsigned-1 ; M: byte-array set-nth-unsafe swap >fixnum set-alien-unsigned-1 ; : >byte-array ( seq -- byte-array ) B{ } clone-like ; inline -M: byte-array new-sequence drop ; +M: byte-array new-sequence drop (byte-array) ; M: byte-array equal? over byte-array? [ sequence= ] [ 2drop f ] if ; diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index 0b3e0003ac..7354759bb6 100644 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -1,6 +1,6 @@ USING: arrays help.markup help.syntax math sequences.private vectors strings kernel math.order layouts -quotations ; +quotations generic.standard ; IN: sequences HELP: sequence @@ -14,8 +14,8 @@ HELP: length HELP: set-length { $values { "n" "a non-negative integer" } { "seq" "a resizable sequence" } } -{ $contract "Resizes the sequence. Not all sequences are resizable." } -{ $errors "Throws a " { $link bounds-error } " if the new length is negative." } +{ $contract "Resizes a sequence. The initial contents of the new area is undefined." } +{ $errors "Throws a " { $link no-method } " error if the sequence is not resizable, and a " { $link bounds-error } " if the new length is negative." } { $side-effects "seq" } ; HELP: lengthen @@ -59,7 +59,7 @@ HELP: immutable HELP: new-sequence { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a mutable sequence" } } -{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } "." } ; +{ $contract "Outputs a mutable sequence of length " { $snippet "n" } " which can hold the elements of " { $snippet "seq" } ". The initial contents of the sequence are undefined." } ; HELP: new-resizable { $values { "len" "a non-negative integer" } { "seq" sequence } { "newseq" "a resizable mutable sequence" } } diff --git a/vm/primitives.c b/vm/primitives.c index a01a8653b7..dcf082d40d 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -74,6 +74,7 @@ void *primitives[] = { primitive_dlsym, primitive_dlclose, primitive_byte_array, + primitive_uninitialized_byte_array, primitive_displaced_alien, primitive_alien_signed_cell, primitive_set_alien_signed_cell, diff --git a/vm/types.c b/vm/types.c index 1afbcd3a40..c9e657f8ee 100755 --- a/vm/types.c +++ b/vm/types.c @@ -243,6 +243,12 @@ void primitive_byte_array(void) dpush(tag_object(allot_byte_array(size))); } +void primitive_uninitialized_byte_array(void) +{ + CELL size = unbox_array_size(); + dpush(tag_object(allot_byte_array_internal(size))); +} + F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) { CELL to_copy = array_capacity(array); @@ -250,7 +256,7 @@ F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) to_copy = capacity; REGISTER_UNTAGGED(array); - F_BYTE_ARRAY *new_array = allot_byte_array(capacity); + F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); UNREGISTER_UNTAGGED(array); memcpy(new_array + 1,array + 1,to_copy); diff --git a/vm/types.h b/vm/types.h index ba8d9689fe..5850489a4c 100755 --- a/vm/types.h +++ b/vm/types.h @@ -116,6 +116,7 @@ void primitive_tuple(void); void primitive_tuple_boa(void); void primitive_tuple_layout(void); void primitive_byte_array(void); +void primitive_uninitialized_byte_array(void); void primitive_clone(void); F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity); @@ -125,6 +126,7 @@ void primitive_resize_byte_array(void); F_STRING* allot_string_internal(CELL capacity); F_STRING* allot_string(CELL capacity, CELL fill); +void primitive_uninitialized_string(void); void primitive_string(void); F_STRING *reallot_string(F_STRING *string, CELL capacity); void primitive_resize_string(void);