( str day 31.05.2001 )
( dynamic strings 'a la Perl' )
( Run-time vocs are used! )

0
cell -- sHandle
cell -- sAddr
cell -- sSize
constant /str

api: MemHandleNew
api: MemHandleFree
: "" ( -- str )
   /str allocate throw >r
   2 MemHandleNew 
   dup r@ sHandle !
   MemHandleLock r@ sAddr !
   r@ sSize 0! r>
;

: str@ ( str -- addr u )
   dup sAddr @ swap sSize @
;

: strfree ( str -- )
   dup sHandle @ dup
   MemHandleUnlock throw
   MemHandleFree throw
   free throw
;

: str+ ( addr u s )
  dup >r
  sHandle @ dup
  MemHandleUnlock throw 
  over r@ sSize @ + 1+ ( newLen)
  MemHandleResize throw 
  r@ sHandle @ 
  MemHandleLock >rel dup r@ sAddr !
  r@ sSize @ +
  swap dup >r cmove
  r> r@ sSize +!
  0 r> str@ + c!
;

: s! ( addr u var_addr -- )
  "" dup rot ! str+
;

: s+
  over str@ rot str+ strfree
;

: s'
  [char] ' parse [compile] sliteral
; immediate

create lt 0x0A0D w,
: crlf
  lt 1
;

: stype ( str -- )
  dup str@ type
  strfree
;

variable sp_save

: {r}  ( addr u n -- )
   nip nip rp@ + dup @ 
   swap cell+ @ - e{ . }e 1-
;

: eval-str ( addr u s -- )
  >r sp@ sp_save !
  dup 1 =
  if
    over c@ [char] n = if 2drop e{ . }e 1- r> str+ exit then
    over c@ [char] s = if 2drop r> str+ exit then
    over c@ [char] i = if 56 {r} r> str+ exit then
    over c@ [char] j = if 68 {r} r> str+ exit then
  then
  ['] evaluate catch ?dup
  if nip nip
     base @ >r decimal
     e{ ." (error: " . [char] ) emit }e
     r> base !
     sp@ sp_save !
  then
  sp@ sp_save @ -  dup 4 =
  if drop e{ . }e 1- r> str+
  else 0 = if r> str+ then
  then
;

: Parse{}
  "" >r
  begin
    >in @ #tib @ <
  while
    [char] { parse
    r@ str+
    [char] } parse ?dup
    if r@ eval-str
    else drop
    then
  repeat r>
;

: (")  ( addr u -- s )
  ['] Parse{} evaluate-with
;

: strLiteral ( str -- )
   state @
   if   dup str@ [compile] sliteral
        postpone (")
        strfree
   else dup >r str@ (")
        r> strfree
   then
; immediate

: parse" ( -- str )
  [char] " parse
  2dup + c@ [char] " <>
  if \ read line by line
    "" >r r@ str+
    begin
      refill
    while
      crlf r@ str+
      [char] " parse tuck r@ str+
      #tib @ <>
      if r> exit then
    repeat
  else "" dup >r str+ r>
  then
;

: " ( "ccc" -- )
   parse" postpone strLiteral
; immediate

+names on