63 lines
2.0 KiB
Forth
Executable File
63 lines
2.0 KiB
Forth
Executable File
\ 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
|
|
;
|