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

string sub-primitives

cvs
Slava Pestov 2005-05-06 02:30:58 +00:00
parent 3e3b33d614
commit cc1e664a99
27 changed files with 253 additions and 355 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
TODO.FACTOR.txt
View File

@ -8,14 +8,13 @@
- 2map slow with lists
- nappend: instead of using push, enlarge the sequence with set-length
then add set the elements with set-nth
- generic each some? all? member? memq? all=? index? subseq? map
- generic each some? all? memq? all=? index? subseq? map
- index and index* are very slow with lists
- unsafe-sbuf>string
- generic subseq
- GENERIC: map
- list impl same as now
- code walker & exceptions
- string sub-primitives
- generational gc
- if two tasks write to a unix stream, the buffer can overflow
- rename prettyprint to pprint

2
contrib/cont-responder/todo-example.factor
View File

@ -335,7 +335,7 @@ USE: sequences
: priority-valid? ( string -- bool )
#! Test the string containing a priority to see if it is
#! valid. It should be a single digit from 0-9.
dup length 1 = [ 0 swap string-nth digit? ] [ drop f ] ifte ;
dup length 1 = [ 0 swap nth digit? ] [ drop f ] ifte ;
: todo-details-valid? ( priority description -- bool )
#! Return true if a valid priority and description were entered.

3
library/bootstrap/boot-stage1.factor
View File

@ -29,11 +29,12 @@ hashtables ;
"/library/collections/lists.factor"
"/library/collections/vectors.factor"
"/library/collections/strings.factor"
"/library/collections/sbuf.factor"
"/library/collections/sequences-epilogue.factor"
"/library/collections/vectors-epilogue.factor"
"/library/collections/hashtables.factor"
"/library/collections/namespaces.factor"
"/library/collections/sbuf.factor"
"/library/collections/strings-epilogue.factor"
"/library/math/matrices.factor"
"/library/words.factor"
"/library/vocabularies.factor"

14
library/bootstrap/primitives.factor
View File

@ -43,17 +43,10 @@ vocabularies get [
[ "ifte" "kernel" [ [ object general-list general-list ] [ ] ] ]
[ "cons" "lists" [ [ object object ] [ cons ] ] ]
[ "<vector>" "vectors" [ [ integer ] [ vector ] ] ]
[ "string-nth" "strings" [ [ integer string ] [ integer ] ] ]
[ "string-compare" "strings" [ [ string string ] [ integer ] ] ]
[ "index-of*" "strings" [ [ integer string text ] [ integer ] ] ]
[ "index-of*" "strings" [ [ integer string object ] [ integer ] ] ]
[ "substring" "strings" [ [ integer integer string ] [ string ] ] ]
[ "<sbuf>" "strings" [ [ integer ] [ sbuf ] ] ]
[ "sbuf-length" "strings" [ [ sbuf ] [ integer ] ] ]
[ "set-sbuf-length" "strings" [ [ integer sbuf ] [ ] ] ]
[ "sbuf-nth" "strings" [ [ integer sbuf ] [ integer ] ] ]
[ "set-sbuf-nth" "strings" [ [ integer integer sbuf ] [ ] ] ]
[ "sbuf-append" "strings" [ [ text sbuf ] [ ] ] ]
[ "sbuf-clone" "strings" [ [ sbuf ] [ sbuf ] ] ]
[ "arithmetic-type" "math-internals" [ [ object object ] [ object object fixnum ] ] ]
[ ">fixnum" "math" [ [ number ] [ fixnum ] ] ]
[ ">bignum" "math" [ [ number ] [ bignum ] ] ]
@ -193,7 +186,10 @@ vocabularies get [
[ "set-slot" "kernel-internals" [ [ object object fixnum ] [ ] ] ]
[ "integer-slot" "kernel-internals" [ [ object fixnum ] [ integer ] ] ]
[ "set-integer-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ]
[ "grow-array" "kernel-internals" [ [ integer array ] [ object ] ] ]
[ "char-slot" "kernel-internals" [ [ object fixnum ] [ fixnum ] ] ]
[ "set-char-slot" "kernel-internals" [ [ integer object fixnum ] [ ] ] ]
[ "grow-array" "kernel-internals" [ [ integer array ] [ array ] ] ]
[ "grow-string" "kernel-internals" [ [ integer string ] [ string ] ] ]
[ "<hashtable>" "hashtables" [ [ number ] [ hashtable ] ] ]
[ "<array>" "kernel-internals" [ [ number ] [ array ] ] ]
[ "<tuple>" "kernel-internals" [ [ number ] [ tuple ] ] ]

12
library/collections/arrays.factor
View File

@ -1,7 +1,5 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel-internals
USING: generic kernel lists math-internals sequences vectors ;
! An array is a range of memory storing pointers to other
! objects. Arrays are not used directly, and their access words
@ -13,6 +11,12 @@ USING: generic kernel lists math-internals sequences vectors ;
! low-level... but be aware that vectors are usually a better
! choice.
IN: math
DEFER: repeat
IN: kernel-internals
USING: kernel math-internals sequences ;
BUILTIN: array 8 ;
: array-capacity ( a -- n ) 1 slot ; inline
@ -20,6 +24,10 @@ BUILTIN: array 8 ;
: set-array-nth ( obj n a -- ) swap 2 fixnum+ set-slot ; inline
: dispatch ( n vtable -- ) 2 slot array-nth call ;
: copy-array ( to from n -- )
[ 3dup swap array-nth pick rot set-array-nth ] repeat 2drop ;
M: array length array-capacity ;
M: array nth array-nth ;
M: array set-nth set-array-nth ;
M: array (grow) grow-array ;

2
library/collections/lists.factor
View File

@ -20,7 +20,7 @@ M: cons empty? drop f ;
: 3unlist ( [ a b c ] -- a b c )
uncons uncons car ;
: contains? ( obj list -- ? )
M: general-list contains? ( obj list -- ? )
#! Test if a list contains an element equal to an object.
[ = ] some-with? >boolean ;

8
library/collections/namespaces.factor
View File

@ -106,7 +106,13 @@ SYMBOL: building
: , ( obj -- )
#! Add to the sequence being built with make-seq.
building get dup sbuf? [ sbuf-append ] [ push ] ifte ;
! The behavior where a string can be passed is deprecated;
! use % instead!
building get dup sbuf? [
over string? [ swap nappend ] [ push ] ifte
] [
push
] ifte ;
: literal, ( word -- )
#! Append some code that pushes the word on the stack. Used

97
library/collections/sbuf.factor
View File

@ -1,89 +1,24 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: strings
USING: generic kernel kernel-internals lists math namespaces
sequences strings ;
USING: generic kernel kernel-internals math math-internals
sequences ;
M: sbuf length sbuf-length ;
M: sbuf set-length set-sbuf-length ;
M: sbuf nth sbuf-nth ;
M: sbuf set-nth set-sbuf-nth ;
M: sbuf clone sbuf-clone ;
M: string (grow) grow-string ;
M: sbuf =
over sbuf? [
2dup eq? [
2drop t
] [
swap >string swap >string =
] ifte
] [
2drop f
] ifte ;
BUILTIN: sbuf 13
[ 1 length set-capacity ]
[ 2 underlying set-underlying ] ;
: >sbuf ( seq -- sbuf ) 0 <sbuf> [ swap nappend ] keep ;
M: sbuf set-length ( n sbuf -- )
growable-check 2dup grow set-capacity ;
M: sbuf nth ( n sbuf -- ch )
bounds-check underlying char-slot ;
M: sbuf set-nth ( ch n sbuf -- )
growable-check 2dup ensure underlying
>r >r >fixnum r> r> set-char-slot ;
M: sbuf >string
[ 0 swap length ] keep sbuf-string substring ;
M: object >string >sbuf >string ;
: cat2 ( "a" "b" -- "ab" )
swap
80 <sbuf>
[ sbuf-append ] keep
[ sbuf-append ] keep
>string ;
: cat3 ( "a" "b" "c" -- "abc" )
>r >r >r 80 <sbuf>
r> over sbuf-append
r> over sbuf-append
r> over sbuf-append >string ;
: fill ( count char -- string ) <repeated> >string ;
: pad ( string count char -- string )
>r over length - dup 0 <= [
r> 2drop
] [
r> fill swap append
] ifte ;
: split-next ( index string split -- next )
3dup index-of* dup -1 = [
>r drop string-tail , r> ( end of string )
] [
swap length dupd + >r swap substring , r>
] ifte ;
: (split) ( index string split -- )
2dup >r >r split-next dup -1 = [
drop r> drop r> drop
] [
r> r> (split)
] ifte ;
: split ( string split -- list )
#! Split the string at each occurrence of split, and push a
#! list of the pieces.
[ 0 -rot (split) ] make-list ;
: split-n-advance substring , >r tuck + swap r> ;
: split-n-finish nip dup length swap substring , ;
: (split-n) ( start n str -- )
3dup >r dupd + r> 2dup length < [
split-n-advance (split-n)
] [
split-n-finish 3drop
] ifte ;
: split-n ( n str -- list )
#! Split a string into n-character chunks.
[ 0 -rot (split-n) ] make-list ;
: ch>string ( ch -- str ) 1 <sbuf> [ push ] keep >string ;
M: string thaw >sbuf ;
M: string freeze drop >string ;
[ 0 swap length ] keep underlying substring ;

2
library/collections/sequences-epilogue.factor
View File

@ -105,6 +105,8 @@ M: sequence (tree-each) [ (tree-each) ] seq-each-with ;
#! The index of the object in the sequence.
0 swap index* ;
M: object contains? ( obj seq -- ? ) index -1 > ;
: push ( element sequence -- )
#! Push a value on the end of a sequence.
dup length swap set-nth ;

45
library/collections/sequences.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: sequences
USING: generic kernel math strings vectors ;
USING: errors generic kernel math math-internals strings vectors ;
! This file is needed very early in bootstrap.
@ -20,5 +20,48 @@ GENERIC: thaw ( seq -- mutable-seq )
GENERIC: freeze ( new orig -- new )
GENERIC: reverse ( seq -- seq )
GENERIC: peek ( seq -- elt )
GENERIC: contains? ( elt seq -- ? )
DEFER: append ! remove this when sort is moved from lists to sequences
! Some low-level code used by vectors and string buffers.
IN: kernel-internals
: assert-positive ( fx -- )
0 fixnum<
[ "Sequence index must be positive" throw ] when ; inline
: assert-bounds ( fx seq -- )
over assert-positive
length fixnum>=
[ "Sequence index out of bounds" throw ] when ; inline
: bounds-check ( n seq -- fixnum seq )
>r >fixnum r> 2dup assert-bounds ; inline
: growable-check ( n seq -- fixnum seq )
>r >fixnum dup assert-positive r> ; inline
GENERIC: underlying
GENERIC: set-underlying
GENERIC: set-capacity
GENERIC: (grow)
: grow ( len seq -- )
#! If the sequence cannot accomodate len elements, resize it
#! to exactly len.
[ underlying (grow) ] keep set-underlying ;
: ensure ( n seq -- )
#! If n is beyond the sequence's length, increase the length,
#! growing the underlying storage if necessary, with an
#! optimistic doubling of its size.
2dup length fixnum>= [
>r 1 fixnum+ r>
2dup underlying length fixnum> [
over 2 fixnum* over grow
] when
set-capacity
] [
2drop
] ifte ;

74
library/collections/strings-epilogue.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: strings
USING: generic kernel lists math namespaces sequences strings ;
: sbuf-append ( ch/str sbuf -- )
over string? [ swap nappend ] [ push ] ifte ;
: cat2 ( "a" "b" -- "ab" )
swap
80 <sbuf>
[ sbuf-append ] keep
[ sbuf-append ] keep
>string ;
: cat3 ( "a" "b" "c" -- "abc" )
>r >r >r 80 <sbuf>
r> over sbuf-append
r> over sbuf-append
r> over sbuf-append >string ;
: fill ( count char -- string ) <repeated> >string ;
: pad ( string count char -- string )
>r over length - dup 0 <= [
r> 2drop
] [
r> fill swap append
] ifte ;
: split-next ( index string split -- next )
3dup index-of* dup -1 = [
>r drop string-tail , r> ( end of string )
] [
swap length dupd + >r swap substring , r>
] ifte ;
: (split) ( index string split -- )
2dup >r >r split-next dup -1 = [
drop r> drop r> drop
] [
r> r> (split)
] ifte ;
: split ( string split -- list )
#! Split the string at each occurrence of split, and push a
#! list of the pieces.
[ 0 -rot (split) ] make-list ;
: split-n-advance substring , >r tuck + swap r> ;
: split-n-finish nip dup length swap substring , ;
: (split-n) ( start n str -- )
3dup >r dupd + r> 2dup length < [
split-n-advance (split-n)
] [
split-n-finish 3drop
] ifte ;
: split-n ( n str -- list )
#! Split a string into n-character chunks.
[ 0 -rot (split-n) ] make-list ;
: ch>string ( ch -- str ) 1 <sbuf> [ push ] keep >string ;
: >sbuf ( seq -- sbuf ) 0 <sbuf> [ swap nappend ] keep ;
M: object >string >sbuf >string ;
M: string thaw >sbuf ;
M: string freeze drop >string ;
M: sbuf clone ( sbuf -- sbuf )
[ length <sbuf> dup ] keep nappend ;

10
library/collections/strings.factor
View File

@ -1,15 +1,10 @@
! Copyright (C) 2003, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: kernel-internals
DEFER: sbuf-string
DEFER: set-sbuf-string
IN: strings
USING: generic kernel kernel-internals lists math sequences ;
! Strings
BUILTIN: string 12 [ 1 length f ] [ 2 hashcode f ] ;
UNION: text string integer ;
M: string =
over string? [
@ -22,14 +17,13 @@ M: string =
2drop f
] ifte ;
M: string nth string-nth ;
M: string nth ( n str -- ch )
bounds-check char-slot ;
GENERIC: >string ( seq -- string )
M: string >string ;
BUILTIN: sbuf 13 [ 2 sbuf-string set-sbuf-string ] ;
: string> ( str1 str2 -- ? )
! Returns if the first string lexicographically follows str2
string-compare 0 > ;

9
library/collections/vectors-epilogue.factor
View File

@ -5,9 +5,18 @@ math-internals sequences ;
IN: vectors
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
#! <vector>, which gives an empty vector with a certain
#! capacity.
dup <vector> [ set-length ] keep ;
: >vector ( list -- vector )
dup length <vector> [ swap nappend ] keep ;
M: vector clone ( vector -- vector )
>vector ;
: vector-project ( n quot -- vector )
#! Execute the quotation n times, passing the loop counter
#! the quotation as it ranges from 0..n-1. Collect results

71
library/collections/vectors.factor
View File

@ -1,54 +1,21 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: vectors
USING: errors generic kernel kernel-internals lists math
math-internals sequences ;
IN: kernel-internals
DEFER: set-vector-length
DEFER: vector-array
DEFER: set-vector-array
IN: vectors
BUILTIN: vector 11
[ 1 length set-vector-length ]
[ 2 vector-array set-vector-array ] ;
[ 1 length set-capacity ]
[ 2 underlying set-underlying ] ;
: empty-vector ( len -- vec )
#! Creates a vector with 'len' elements set to f. Unlike
#! <vector>, which gives an empty vector with a certain
#! capacity.
dup <vector> [ set-length ] keep ;
M: vector set-length ( len vec -- )
growable-check 2dup grow set-capacity ;
IN: kernel-internals
M: vector nth ( n vec -- obj )
bounds-check underlying array-nth ;
: assert-positive ( fx -- )
0 fixnum<
[ "Vector index must be positive" throw ] when ; inline
: assert-bounds ( fx seq -- )
over assert-positive
length fixnum>=
[ "Vector index out of bounds" throw ] when ; inline
: grow-capacity ( len vec -- )
#! If the vector cannot accomodate len elements, resize it
#! to exactly len.
[ vector-array grow-array ] keep set-vector-array ;
: ensure-capacity ( n vec -- )
#! If n is beyond the vector's length, increase the length,
#! growing the array if necessary, with an optimistic
#! doubling of its size.
2dup length fixnum>= [
>r 1 fixnum+ r>
2dup vector-array length fixnum> [
over 2 fixnum* over grow-capacity
] when
set-vector-length
] [
2drop
] ifte ;
M: vector set-nth ( obj n vec -- )
growable-check 2dup ensure underlying set-array-nth ;
M: vector hashcode ( vec -- n )
dup length 0 number= [
@ -56,23 +23,3 @@ M: vector hashcode ( vec -- n )
] [
0 swap nth hashcode
] ifte ;
M: vector set-length ( len vec -- )
>r >fixnum dup assert-positive r>
2dup grow-capacity set-vector-length ;
M: vector nth ( n vec -- obj )
>r >fixnum r> 2dup assert-bounds vector-array array-nth ;
M: vector set-nth ( obj n vec -- )
>r >fixnum dup assert-positive r>
2dup ensure-capacity vector-array
set-array-nth ;
: copy-array ( to from n -- )
[ 3dup swap array-nth pick rot set-array-nth ] repeat 2drop ;
M: vector clone ( vector -- vector )
dup length dup empty-vector [
vector-array rot vector-array rot copy-array
] keep ;

4
library/io/directories.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: files
USING: kernel hashtables lists namespaces presentation stdio
streams strings unparser ;
USING: kernel hashtables lists namespaces presentation
sequences stdio streams strings unparser ;
! Hyperlinked directory listings.

3
library/io/stream.factor
View File

@ -23,8 +23,7 @@ GENERIC: stream-write-attr ( string style stream -- )
GENERIC: stream-close ( stream -- )
: stream-read1 ( stream -- char/f )
1 swap stream-read
dup empty? [ drop f ] [ 0 swap string-nth ] ifte ;
1 swap stream-read dup empty? [ drop f ] [ 0 swap nth ] ifte ;
: stream-write ( string stream -- )
f swap stream-write-attr ;

2
library/syntax/parse-syntax.factor
View File

@ -109,7 +109,7 @@ BUILTIN: f 9 ; : f f swons ; parsing
! String literal
: (parse-string) ( n str -- n )
2dup string-nth CHAR: " = [
2dup nth CHAR: " = [
drop 1 +
] [
[ next-char swap , ] keep (parse-string)

6
library/test/sbuf.factor
View File

@ -1,5 +1,7 @@
IN: temporary
USING: kernel namespaces sequences strings test ;
USING: kernel math namespaces sequences strings test ;
[ 5 ] [ "Hello" >sbuf length ] unit-test
[ "Hello" ] [
100 <sbuf> "buf" set
@ -13,3 +15,5 @@ USING: kernel namespaces sequences strings test ;
[ CHAR: H ] [
CHAR: H 0 SBUF" hello world" [ set-nth ] keep 0 swap nth
] unit-test
[ SBUF" x" ] [ 1 <sbuf> [ CHAR: x >bignum over push ] keep ] unit-test

5
library/test/strings.factor
View File

@ -10,8 +10,8 @@ USE: lists
[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] make-string ] unit-test
[ "abc" ] [ "ab" "c" cat2 ] unit-test
[ "abc" ] [ "a" "b" "c" cat3 ] unit-test
[ "abc" ] [ "ab" "c" append ] unit-test
[ "abc" ] [ "a" "b" "c" append3 ] unit-test
[ 3 ] [ "hola" "a" index-of ] unit-test
[ -1 ] [ "hola" "x" index-of ] unit-test
@ -94,3 +94,4 @@ unit-test
[ "666" ] [ "666" 2 CHAR: 0 pad ] unit-test
[ 1 "" nth ] unit-test-fails
[ -6 "hello" nth ] unit-test-fails

2
library/ui/buttons.factor
View File

@ -2,7 +2,7 @@
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
USING: generic kernel lists math namespaces prettyprint sdl
stdio ;
sequences stdio ;
: button-down? ( n -- ? ) hand hand-buttons contains? ;

13
library/ui/gadgets.factor
View File

@ -27,18 +27,21 @@ C: gadget ( shape -- gadget )
gadget-parent [ redraw ] when*
] ifte ;
: relayout ( gadget -- )
#! Relayout a gadget before the next iteration of the event
#! loop. Since relayout also implies the visual
#! representation changed, we redraw the gadget too.
: relayout* ( gadget -- )
#! Relayout and redraw a gadget and its parent before the
#! next iteration of the event loop.
dup gadget-relayout? [
drop
] [
t over set-gadget-redraw?
t over set-gadget-relayout?
gadget-parent [ relayout ] when*
gadget-parent [ relayout* ] when*
] ifte ;
: relayout ( gadget -- )
#! Relayout a gadget and its children.
dup relayout* gadget-children [ relayout ] each ;
: ?move ( x y gadget quot -- )
>r 3dup shape-pos >r rect> r> = [
3drop

3
library/ui/paint.factor
View File

@ -65,7 +65,7 @@ SYMBOL: clip
#! paint, just call the quotation.
f over set-gadget-redraw?
dup gadget-paint [
dup [
dup dup [
[
drop
] [
@ -74,4 +74,5 @@ SYMBOL: clip
] with-trans
] ifte
] with-clip
surface get swap [ shape-x x get + ] keep [ shape-y y get + ] keep [ shape-w pick + 1 - ] keep shape-h pick + 1 - red rgb rectangleColor
] bind ;

10
native/primitives.c
View File

@ -9,17 +9,10 @@ void* primitives[] = {
primitive_ifte,
primitive_cons,
primitive_vector,
primitive_string_nth,
primitive_string_compare,
primitive_index_of,
primitive_substring,
primitive_sbuf,
primitive_sbuf_length,
primitive_set_sbuf_length,
primitive_sbuf_nth,
primitive_set_sbuf_nth,
primitive_sbuf_append,
primitive_sbuf_clone,
primitive_arithmetic_type,
primitive_to_fixnum,
primitive_to_bignum,
@ -159,7 +152,10 @@ void* primitives[] = {
primitive_set_slot,
primitive_integer_slot,
primitive_set_integer_slot,
primitive_char_slot,
primitive_set_char_slot,
primitive_grow_array,
primitive_grow_string,
primitive_hashtable,
primitive_array,
primitive_tuple,

119
native/sbuf.c
View File

@ -6,7 +6,7 @@ F_SBUF* sbuf(F_FIXNUM capacity)
if(capacity < 0)
general_error(ERROR_NEGATIVE_ARRAY_SIZE,tag_fixnum(capacity));
sbuf = allot_object(SBUF_TYPE,sizeof(F_SBUF));
sbuf->top = 0;
sbuf->top = tag_fixnum(0);
sbuf->string = tag_object(string(capacity,'\0'));
return sbuf;
}
@ -17,123 +17,6 @@ void primitive_sbuf(void)
drepl(tag_object(sbuf(to_fixnum(dpeek()))));
}
void primitive_sbuf_length(void)
{
drepl(tag_fixnum(untag_sbuf(dpeek())->top));
}
void primitive_set_sbuf_length(void)
{
F_SBUF* sbuf;
F_FIXNUM length;
F_STRING* str;
maybe_garbage_collection();
sbuf = untag_sbuf(dpop());
str = untag_string(sbuf->string);
length = to_fixnum(dpop());
if(length < 0)
range_error(tag_object(sbuf),0,to_fixnum(length),sbuf->top);
sbuf->top = length;
if(length > string_capacity(str))
sbuf->string = tag_object(grow_string(str,length,F));
}
void primitive_sbuf_nth(void)
{
F_SBUF* sbuf = untag_sbuf(dpop());
CELL index = to_fixnum(dpop());
if(index < 0 || index >= sbuf->top)
range_error(tag_object(sbuf),0,tag_fixnum(index),sbuf->top);
dpush(tag_fixnum(string_nth(untag_string(sbuf->string),index)));
}
void sbuf_ensure_capacity(F_SBUF* sbuf, F_FIXNUM top)
{
F_STRING* string = untag_string(sbuf->string);
if(top >= string_capacity(string))
sbuf->string = tag_object(grow_string(string,top * 2 + 1,F));
sbuf->top = top;
}
void set_sbuf_nth(F_SBUF* sbuf, CELL index, u16 value)
{
if(index < 0)
range_error(tag_object(sbuf),0,tag_fixnum(index),sbuf->top);
else if(index >= sbuf->top)
sbuf_ensure_capacity(sbuf,index + 1);
/* the following does not check bounds! */
set_string_nth(untag_string(sbuf->string),index,value);
}
void primitive_set_sbuf_nth(void)
{
F_SBUF* sbuf;
F_FIXNUM index;
CELL value;
maybe_garbage_collection();
sbuf = untag_sbuf(dpop());
index = to_fixnum(dpop());
value = to_fixnum(dpop());
set_sbuf_nth(sbuf,index,value);
}
void sbuf_append_string(F_SBUF* sbuf, F_STRING* string)
{
CELL top = sbuf->top;
CELL strlen = string_capacity(string);
F_STRING* str;
sbuf_ensure_capacity(sbuf,top + strlen);
str = untag_string(sbuf->string);
memcpy((void*)((CELL)str + sizeof(F_STRING) + top * CHARS),
(void*)((CELL)string + sizeof(F_STRING)),strlen * CHARS);
}
void primitive_sbuf_append(void)
{
F_SBUF* sbuf;
CELL object;
maybe_garbage_collection();
sbuf = untag_sbuf(dpop());
object = dpop();
switch(type_of(object))
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
set_sbuf_nth(sbuf,sbuf->top,to_fixnum(object));
break;
case STRING_TYPE:
sbuf_append_string(sbuf,untag_string(object));
break;
default:
type_error(STRING_TYPE,object);
break;
}
}
void primitive_sbuf_clone(void)
{
F_SBUF* s;
F_SBUF* new_s;
maybe_garbage_collection();
s = untag_sbuf(dpeek());
new_s = sbuf(s->top);
sbuf_append_string(new_s,untag_string(s->string));
drepl(tag_object(new_s));
}
void fixup_sbuf(F_SBUF* sbuf)
{
data_fixup(&sbuf->string);

16
native/sbuf.h
View File

@ -1,12 +1,17 @@
typedef struct {
/* always tag_header(SBUF_TYPE) */
CELL header;
/* untagged */
/* tagged */
CELL top;
/* tagged */
CELL string;
} F_SBUF;
INLINE CELL sbuf_capacity(F_SBUF* sbuf)
{
return untag_fixnum_fast(sbuf->top);
}
INLINE F_SBUF* untag_sbuf(CELL tagged)
{
type_check(SBUF_TYPE,tagged);
@ -16,14 +21,5 @@ INLINE F_SBUF* untag_sbuf(CELL tagged)
F_SBUF* sbuf(F_FIXNUM capacity);
void primitive_sbuf(void);
void primitive_sbuf_length(void);
void primitive_set_sbuf_length(void);
void primitive_sbuf_nth(void);
void sbuf_ensure_capacity(F_SBUF* sbuf, F_FIXNUM top);
void set_sbuf_nth(F_SBUF* sbuf, CELL index, u16 value);
void primitive_set_sbuf_nth(void);
void sbuf_append_string(F_SBUF* sbuf, F_STRING* string);
void primitive_sbuf_append(void);
void primitive_sbuf_clone(void);
void fixup_sbuf(F_SBUF* sbuf);
void collect_sbuf(F_SBUF* sbuf);

60
native/string.c
View File

@ -56,6 +56,15 @@ F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, u16 fill)
return new_string;
}
void primitive_grow_string(void)
{
F_STRING* string; CELL capacity;
maybe_garbage_collection();
string = untag_string_fast(dpop());
capacity = to_fixnum(dpop());
dpush(tag_object(grow_string(string,capacity,F)));
}
F_STRING* memory_to_string(const BYTE* string, CELL length)
{
F_STRING* s = allot_string(length);
@ -145,30 +154,19 @@ u16* unbox_utf16_string(void)
return (u16*)(untag_string(dpop()) + 1);
}
void primitive_string_nth(void)
void primitive_char_slot(void)
{
F_STRING* string = untag_string(dpop());
CELL index = to_fixnum(dpop());
CELL capacity = string_capacity(string);
if(index < 0 || index >= capacity)
range_error(tag_object(string),0,tag_fixnum(index),capacity);
F_STRING* string = untag_string_fast(dpop());
CELL index = untag_fixnum_fast(dpop());
dpush(tag_fixnum(string_nth(string,index)));
}
F_FIXNUM string_compare_head(F_STRING* s1, F_STRING* s2, CELL len)
void primitive_set_char_slot(void)
{
CELL i = 0;
while(i < len)
{
u16 c1 = string_nth(s1,i);
u16 c2 = string_nth(s2,i);
if(c1 != c2)
return c1 - c2;
i++;
}
return 0;
F_STRING* string = untag_string_fast(dpop());
CELL index = untag_fixnum_fast(dpop());
CELL value = untag_fixnum_fast(dpop());
set_string_nth(string,index,value);
}
F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2)
@ -178,11 +176,17 @@ F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2)
CELL limit = (len1 < len2 ? len1 : len2);
CELL comp = string_compare_head(s1,s2,limit);
if(comp != 0)
return comp;
else
return len1 - len2;
CELL i = 0;
while(i < limit)
{
u16 c1 = string_nth(s1,i);
u16 c2 = string_nth(s2,i);
if(c1 != c2)
return c1 - c2;
i++;
}
return len1 - len2;
}
void primitive_string_compare(void)
@ -293,11 +297,3 @@ void primitive_substring(void)
start = to_fixnum(dpop());
dpush(tag_object(substring(start,end,string)));
}
/* Doesn't rehash the string! */
F_STRING* string_clone(F_STRING* s, int len)
{
F_STRING* copy = allot_string(len);
memcpy(copy + 1,s + 1,len * CHARS);
return copy;
}

13
native/string.h
View File

@ -8,10 +8,15 @@ typedef struct {
#define SREF(string,index) ((CELL)string + sizeof(F_STRING) + index * CHARS)
INLINE F_STRING* untag_string_fast(CELL tagged)
{
return (F_STRING*)UNTAG(tagged);
}
INLINE F_STRING* untag_string(CELL tagged)
{
type_check(STRING_TYPE,tagged);
return (F_STRING*)UNTAG(tagged);
return untag_string_fast(tagged);
}
INLINE CELL string_capacity(F_STRING* str)
@ -26,6 +31,7 @@ F_STRING* allot_string(CELL capacity);
F_STRING* string(CELL capacity, CELL fill);
void rehash_string(F_STRING* str);
F_STRING* grow_string(F_STRING* string, F_FIXNUM capacity, u16 fill);
void primitive_grow_string(void);
char* to_c_string(F_STRING* s);
char* to_c_string_unchecked(F_STRING* s);
void string_to_memory(F_STRING* s, BYTE* string);
@ -49,10 +55,9 @@ INLINE void set_string_nth(F_STRING* string, CELL index, u16 value)
cput(SREF(string,index),value);
}
void primitive_string_nth(void);
F_FIXNUM string_compare_head(F_STRING* s1, F_STRING* s2, CELL len);
void primitive_char_slot(void);
void primitive_set_char_slot(void);
F_FIXNUM string_compare(F_STRING* s1, F_STRING* s2);
void primitive_string_compare(void);
void primitive_index_of(void);
void primitive_substring(void);
F_STRING* string_clone(F_STRING* s, int len);