forth/str.fs

   1 : safe-type ( str-addr str-len -- )
   2     dup 256 > if
   3         drop 256 type ." ...<lots more>"
   4     else
   5         type
   6     endif ;
   7
   8 \ === mutable string buffer === /
   9 \ string buffer that maintains an allocation larger than the current
  10 \ string size.  When appending would cause the string size exceed the
  11 \ current allocation, resize is used to double the allocation. The
  12 \ current allocation is not stored anywhere, but computed based on
  13 \ current string size or str-base-size, whichever is larger.
  14 64 constant str-base-size
  15
  16 : new-str ( -- addr length )
  17   str-base-size allocate throw 0 ;
  18
  19 : round-up ( n -- n )
  20   2
  21   begin
  22     1 lshift 2dup <
  23   until
  24   nip ;
  25
  26 : str-append { buf-addr buf-str-len str-addr str-len }
  27   buf-str-len str-len +
  28   { new-len }
  29   new-len str-base-size >= if
  30     buf-str-len new-len xor buf-str-len > if
  31       buf-addr new-len round-up resize throw
  32       to buf-addr
  33     endif
  34   endif
  35   str-addr buf-addr buf-str-len + str-len cmove
  36   buf-addr new-len ;
  37
  38 \ define a-space, to append a space char to a string
  39 bl c,
  40 here constant space-str
  41 : a-space space-str 1 str-append ;
  42
  43 : str-append-char ( buf-addr buf-str-len char -- buf-addr buf-str-len )
  44     pad ! pad 1 str-append ;
  45
  46 \ from gforth docs, there named 'my-.'
  47 : int>str ( num -- str-addr str-len )
  48     \ handling negatives.. behaves like Standard .
  49     s>d            \ convert to signed double
  50     swap over dabs \ leave sign byte followed by unsigned double
  51     <<#            \ start conversion
  52     #s             \ convert all digits
  53     rot sign       \ get at sign byte, append "-" if needed
  54     #>             \ complete conversion
  55     #>> ;          \ release hold area
  56
  57 defer MalString.
  58
  59 : ...str
  60     new-str
  61     begin
  62         2swap
  63         over 0 <>
  64     while
  65         str-append
  66     repeat
  67     2drop MalString. ;
  68
  69 nil value exception-object
  70
  71 : ...throw-str
  72     ...str to exception-object
  73     1 throw ;