string sub-primitives

TODO.FACTOR.txt

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

contrib/cont-responder/todo-example.factor

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

library/bootstrap/boot-stage1.factor

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

library/bootstrap/primitives.factor

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

library/collections/arrays.factor

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

library/collections/lists.factor

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

library/collections/namespaces.factor

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

library/collections/sbuf.factor

@@ -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
+USING: generic kernel kernel-internals math math-internals
-sequences strings ;
+sequences ;
 
-M: sbuf length sbuf-length ;
+M: string (grow) grow-string ;
-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: sbuf =
+BUILTIN: sbuf 13
-    over sbuf? [
+    [ 1 length set-capacity ]
-        2dup eq? [
+    [ 2 underlying set-underlying ] ;
-            2drop t
-        ] [
-            swap >string swap >string =
-        ] ifte
-    ] [
-        2drop f
-    ] ifte ;
 
-: >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 ;
+    [ 0 swap length ] keep underlying 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 ;

library/collections/sequences-epilogue.factor

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

library/collections/sequences.factor

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

library/collections/strings-epilogue.factor

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

library/collections/strings.factor

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

library/collections/vectors-epilogue.factor

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

library/collections/vectors.factor

@@ -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 ]
+    [ 1 length set-capacity ]
-    [ 2 vector-array set-vector-array ] ;
+    [ 2 underlying set-underlying ] ;
 
-: empty-vector ( len -- vec )
+M: vector set-length ( len vec -- )
-    #! Creates a vector with 'len' elements set to f. Unlike
+    growable-check 2dup grow set-capacity ;
-    #! <vector>, which gives an empty vector with a certain
-    #! capacity.
-    dup <vector> [ set-length ] keep ;
 
-IN: kernel-internals
+M: vector nth ( n vec -- obj )
+    bounds-check underlying array-nth ;
 
-: assert-positive ( fx -- )
+M: vector set-nth ( obj n vec -- )
-    0 fixnum<
+    growable-check 2dup ensure underlying set-array-nth ;
-    [ "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 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 ;

library/io/directories.factor

@@ -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
+USING: kernel hashtables lists namespaces presentation
-streams strings unparser ;
+sequences stdio streams strings unparser ;
 
 ! Hyperlinked directory listings.
 

library/io/stream.factor

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

library/syntax/parse-syntax.factor

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

library/test/sbuf.factor

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

library/test/strings.factor

@@ -10,8 +10,8 @@ USE: lists
 
 [ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] make-string ] unit-test
 
-[ "abc" ] [ "ab" "c" cat2 ] unit-test
+[ "abc" ] [ "ab" "c" append ] unit-test
-[ "abc" ] [ "a" "b" "c" cat3 ] 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

library/ui/buttons.factor

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

library/ui/gadgets.factor

@@ -27,18 +27,21 @@ C: gadget ( shape -- gadget )
         gadget-parent [ redraw ] when*
     ] ifte ;
 
-: relayout ( gadget -- )
+: relayout* ( gadget -- )
-    #! Relayout a gadget before the next iteration of the event
+    #! Relayout and redraw a gadget and its parent before the
-    #! loop. Since relayout also implies the visual
+    #! next iteration of the event loop.
-    #! representation changed, we redraw the gadget too.
     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

library/ui/paint.factor

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

native/primitives.c

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

native/sbuf.c

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

native/sbuf.h

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

native/string.c

@@ -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());
+	F_STRING* string = untag_string_fast(dpop());
-	CELL index = to_fixnum(dpop());
+	CELL index = untag_fixnum_fast(dpop());
-	CELL capacity = string_capacity(string);
-
-	if(index < 0 || index >= capacity)
-		range_error(tag_object(string),0,tag_fixnum(index),capacity);
 	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;
+	F_STRING* string = untag_string_fast(dpop());
-	while(i < len)
+	CELL index = untag_fixnum_fast(dpop());
-	{
+	CELL value = untag_fixnum_fast(dpop());
-		u16 c1 = string_nth(s1,i);
+	set_string_nth(string,index,value);
-		u16 c2 = string_nth(s2,i);
-		if(c1 != c2)
-			return c1 - c2;
-		i++;
-	}
-	
-	return 0;
 }
 
 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);
+	CELL i = 0;
-	if(comp != 0)
+	while(i < limit)
-		return comp;
+	{
-	else
+		u16 c1 = string_nth(s1,i);
-		return len1 - len2;
+		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;
-}

native/string.h

@@ -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);
+void primitive_char_slot(void);
-F_FIXNUM string_compare_head(F_STRING* s1, F_STRING* s2, CELL len);
+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);