\ lcstr.fs -- Long counted string data type
\ 2016 David Meyer <papa@sdf.org>  +JMJ

\ Long counted strings (lcstr) are similar to standard counted strings, except
\ that the string length is stored as an unsigned single-precision integer (4
\ bytes) instead of a character (which limits standard counted strings to 255
\ character maximum length). Long counted sting maximum length is 
\ 256^4-1 bytes subject to the limit of heap space allocation.

\ Stack effects, variables, etc. representing long counted strings will 
\ conventionally start with "L", addresses of long counted strings with "L-".

: lcount ( l-str -- c-str u )
\g Extract pointer C-STR and length U of lcstr L-STR
	dup 1 cells + swap @ ;

: ltype ( l-str -- )
\g Output lcstr to standard output
	lcount type ;

: lalloc ( c-str u -- l-str )
\g Allocate heap space for lcstr version of string C-STR,U 
	dup chars 1 cells + allocate if  ( a-str u l-str)
		drop 2drop 0  \ Returns pointer 0 for alloc. error 
	else
		2dup ! dup >r 1 cells + swap cmove r>
	then
;

: clalloc ( c-str -- l-str )
\g Allocate heap space and convery counted string for C-STR tp lcstr
	count lalloc ;

: $catcpy { a-str1 u1 a-str2 u2 a-cat ucat -- }
\g Copy characters from STR1 and STR2 to pre-allocated CAT
	a-str1 a-cat u1 cmove
	a-str2 a-cat u1 chars + u2 cmove
;

: c$cat ( c-str1 c-str2 -- c-cat )
\g Concatenate two counted strings in heap, preserve original strings
	count dup >r rot count dup >r 2swap  ( a-str1 u1 a-str2 u2 R: u2 u1 )
	r> r> + dup 1+ chars allocate if  ( a-str1 u1 a-str2 u2 ucat c-cat ) 
		clearstack 0  \ Returns 0 c-pointer for alloc. error
	else
		tuck c!  ( a-str1 u1 a-str2 u2 c-cat )
		dup >r count $catcpy r>
	then
;

: c$catx ( c-str1 c-str2 ux -- c-cat )
\g Concatenate two counted strings in heap, recycle original strings according to UX: 0 -- recycle STR1 and STR2, 1 -- recycle STR1 only, 2 -- recycle STR2 only
	>r 2dup c$cat r> ( c-str1 c-str2 c-cat ux )
	dup 2 = if
		drop swap free drop nip
	else dup 1 = if
		drop nip swap free drop
	else 0= if
		swap free drop
		swap free drop
	then then then
;