\ stringstack v0.10
\ download as http://forthfreak.net/stringstack
warnings dup @ swap off
false / true \ assume no library support
constant use_library
warnings !
\ strings.f string words (should be) ANS conform. compiles with vanilla gforth
\ v0.10 20050107 Speuler added -scan$, -skip$, searchn$ and dropn$
\ v0.09a 20041008 Speuler added scan$ skip$ description
\ v0.09 20020305 Speuler added scan$ skip$
\ v0.08, 20020211 Speuler added mid$ reverse$ translate$
\ v0.07, 20020211 Speuler improved left$, right$, split$, pick$, roll$, .s$, constants for throw values
\ v0.06, 20020211 Speuler fixed bug in example, speeded up dup$ drop$ swap$ over$, added left$ right$
\ v0.05, 20020210 Speuler added split$ merge$
\ v0.04, 20020210 Speuler added compare$ roll$ search$ subsearch$
\ v0.03, 20020210 Speuler added depth$ .s$ pick$
\ v0.02, 20020210 Speuler factored out refcount decrementing, pushing to flushstrings
\ v0.01, 20020210 Speuler initial implementation
\ stringstack words:
\ tos$ ( -- a n ) gives topmost string, same as 0 pick$ (but no test whether topmost elements actually exists)
\ push$ ( a n -- ) pushs a string to stringstack
\ pop$ ( -- a n ) pops a string from stringstack, marks it as freeable if last ref
\ dup$ ( -- ) duplicates string on stringstack
\ drop$ ( -- ) drops a string on stringstack, marks as freeable if last ref
\ dropn$ ( n -- ) drop top n strings
\ swap$ ( -- ) swaps top two strings on stringstack
\ over$ ( -- ) pushs a copy of nos string
\ free$ ( -- ) frees memory used by freeable strings
\ depth$ ( -- n ) number of items on string stack
\ compare$ ( n1 n2 -- n3 ) compare strings at stack pos n1 and n2
\ pick$ ( n1 -- a n2 ) return nth string, counting from top of string stack
\ roll$ ( n -- ) roll string at string stack pos n to top of string stack
\ searchn$ ( a n1 n2 -- n3 -1 | 0 ) search for a n1 through n2 elements
\ search$ ( a n -- n -1 | 0 ) search through stringstack, return stack position of match, or 0
\ subsearch ( a n -- n -1 | 0 ) substring search through stringstack.
\ left$ ( n -- ) leaves n left chars, or cuts off -n right chars
\ right$ ( n -- ) leaves n right chars, or cuts off -n left chars
\ mid$ ( index len -- ) extracts string subsection. negative index counts from the right.
\ reverse$ ( -- ) mirror image of string
\ split$ ( n -- ) splits top string into two at position n. n<0 counts fromon string end
\ merge$ ( -- ) appends top string to nos string
\ translate$ ( a n -- ) replace chars in string against chars from table at a
\ skip$ ( c -- n ) returns length of string after skipping leading cs
\ scan$ ( c -- n ) returns length of string from first c to string end
\ -scan$ ( c -- n ) reverse scan, from right end of string
\ -skip$ ( c -- n ) reverse skip, from right end of string
\ .s$ ( -- ) display stack dump of string stack. number shown is string reference count
\ string count is cell size, i.e. strings > 255 bytes are ok.
\ split$ and merge$ have been implemented to avoid having to use length-limited strings words
base @ decimal
1024 constant maxstrings
\ ---------- general stuff ----------
\ throw values
-4 constant stack_underflow \ string stack underflow
-24 constant invalid_argument \ pick$, roll$ index too high
32 constant maxtype \ max chars per string typed by .s$
cell 2 = [if] ' 2/ alias cell/ ( n1 -- n2 ) [then]
cell 4 = [if] : cell/ ( n1 -- n2 ) 2 rshift ; [then]
cell 8 = [if] : cell/ ( n1 -- n2 ) 3 rshift ; [then]
use_library [if]
require cell- require inc require dec require skim
require pluck require 3dup require exchange require swapchars
[else]
: cell- ( x1 -- x2 ) cell - ;
: inc ( a -- ) 1 swap +! ;
: dec ( a -- ) -1 swap +! ;
: skim ( a1 -- a2 x ) cell+ dup cell- @ ;
: pluck ( x1 x2 x3 -- x1 x2 x3 x1 ) 2 pick ;
: 3dup ( x1 x2 x3 -- x1 x2 x3 x1 x2 x3 ) pluck pluck pluck ;
: exchange ( x1 a -- x2 ) dup @ -rot ! ;
: swapchars ( a1 a2 -- ) dup >r c@ swap dup c@ r> c! c! ;
[then]
\ builds stack with structure maxdepth, depth, stackdata.
\ expects that stack space has been allocated already at a
\ depth and maxdepth are given in bytes.
: stack ( n a -- ) 0 over cell+ ! ! ;
: stack: ( n -- ) create here over cell+ cell+ allot stack ;
: sp ( a1 -- a2 ) cell+ dup @ + ; \ return address of top stack element
: push ( x a -- ) cell+ cell over +! dup @ + ! ;
: pop ( a -- x )
cell+ dup >r
dup @
dup 0<=
if
stack_underflow throw
then
+ @ \ read stacked data.
[ cell negate ] literal
r> +! \ unbump stack pointer
;
: stackused ( a -- n ) cell+ @ cell/ ; \ given a stack, returns depth
: stackfree ( a -- n ) skim swap @ - cell/ ; \ given a stack, returns free
\ --------------- string stack stuff -------------------
maxstrings cells stack: stringstack
maxstrings cells stack: flushstack
: depth$ ( -- n ) stringstack stackused ;
: 'tos$ ( -- a ) stringstack sp ; \ returns address of top element in string stack
: tos$ ( -- a n ) 'tos$ @ cell+ skim ; \ same as 0 pick$
\ allocates space for refcount, stringlen, string
\ refcount and stringlen are cell size
: alloc$ ( len -- addr 0 | 0 err ) cell+ cell+ allocate ;
\ push string to flushstrings if refcount is 0. decrement refcount
: ?free$ ( a -- )
dup @ 0= if \ refcount = 0 ?
dup flushstack push \ string freeable
then
dec \ decrement refcount
;
: assure_valid_index ( n -- ) depth$ u>= if invalid_argument throw then ;
\ releases unused string space. right now there is the risk of
\ flushstack overflow. you need to call free$ before that happens.
: free$ ( a -- 0 | err ) flushstack stackused 0 ?do flushstack pop free throw loop ;
: push$ ( a n -- )
dup alloc$ throw \ a1 n a2
dup off \ set refcount
dup stringstack push
cell+ 2dup ! \ set stringlen
cell+ swap move \ copy string
;
: pop$ ( -- a n ) stringstack pop dup ?free$ cell+ skim ;
\ ------------------- string stack primitives -------------------
\ (calling them primitives because there exist data stack, non-string equivalents for these)
: drop$ ( -- ) stringstack pop ?free$ ;
: dropn$ ( n -- ) 0 ?do drop$ loop ;
: dup$ ( -- ) 'tos$ @ dup inc stringstack push ;
: swap$ ( -- ) 'tos$ cell- dup skim swap exchange swap ! ;
: over$ ( -- ) 'tos$ cell- @ dup inc stringstack push ;
\ return the nth string from top of string stack as address/count.
\ beware that pick$ does NOT put the nth string on top of string stack.
: pick$ ( n -- a n ) dup assure_valid_index cells negate 'tos$ + @ cell+ skim ;
: roll$ ( n -- )
dup assure_valid_index
cells 'tos$ dup >r \ address tos, keep
over - dup @ >r \ read target string handle
cell+ dup cell- rot move \ move all down
r> r> ! \ write rolled string to tos
;
\ compares string1 at stack pos n1 with string2 at n2, returns -1 if
\ string1, string2 are in descending order, 0 if strings are identical,
\ 1 if string1, string2 are in ascending order.
: compare$ ( n1 n2 -- -1 | 0 | 1 ) >r pick$ r> pick$ compare ;
\ -------------- more operations on stacked strings ----------------
\ show string stack dump. first number is string reference count
: .s$ ( -- )
depth$ 0 ?do
cr i pick$
over cell- cell- @ . \ ref count
tuck maxtype min
tuck type
- ?dup if \ string was truncated
." ... +" . \ indicate "there's more"
then
loop
;
\ n gives len of remainder of string incl char scanned for
: skip$ ( c -- n ) tos$ rot skip nip ;
\ n gives len of remainder of string incl char scanned for
: scan$ ( c -- n ) tos$ rot scan nip ;
\ search for last occurance of c
: -scan$ ( c -- n ) tos$ over >r tuck + swap 0 ?do 2dup 1- c@ = ?leave 1- loop nip r> - ;
\ returns len of remaining string, after having skipped any c at the end of the string
: -skip$ ( c -- n ) tos$ over >r tuck + swap 0 ?do 2dup 1- c@ <> ?leave 1- loop nip r> - ;
\ seperate string stack top at bl into words
\ : scanskipdemo ( a n -- )
\ begin
\ bl scan$ \ search next space
\ ?dup while \ space found:
\ negate split$ \ split string at space
\ bl skip$ right$ \ cut off leading space
\ repeat ;
\ search for string a n1 in top n2 string stack elements
: searchn$ ( a n1 n2 -- n -1 | 0 )
begin dup
while
1- 3dup pick$ compare
0= if
nip nip true
exit
then
repeat
nip nip
;
: search$ ( a n1 -- n2 -1 | 0 ) depth$ searchn$ ;
: subsearch$ ( a n1 -- n2 -1 | 0 )
depth$
begin dup
while
1- 3dup pick$
pluck over u>
if
2drop 2drop true
else
drop over compare
then
0= if
nip nip true
exit
then
repeat
nip nip
;
\ appends tos string to nos string
: merge$ ( -- ) pop$ >r pop$ tuck r@ + push$ 'tos$ @ cell+ cell+ + r> move ;
\ splits string on stringstack into two strings at position n.
\ also accepts negative index, which counts from end of string.
\ index out of bounds will be truncated to string boundary.
: split$ ( n -- )
>r pop$
r@ 0< if
dup r> + 0 max >r
then
dup r> min
pluck over push$
/string push$
;
\ if top string is referenced more than once, detach it, and create a single-ref copy
\ returns address and len of top string
\ used before in-sito modification of top string, like reverse$
: detach$ ( -- a n )
'tos$ @ @ ( refcount )
if ( multiple references )
pop$ push$ ( create physical duplicate of string )
then tos$ ;
\ helper word for left$ and right$
: clipped ( n1 n2 n3-- n4 ) 0< if + 0 max else min then ;
\ n>=0 : leaves left n chars of string
\ n<0 : cuts -n chars off the end of string
\ index out of bounds will be truncated to string boundary.
: left$ ( n -- ) >r pop$ r> dup clipped push$ ;
\ n>=0 : leaves right n chars of string
\ n<0 : cuts -n chars off the left of string
\ index out of bounds will be truncated to string boundary.
: right$ ( n -- ) >r pop$ dup r> 2dup clipped - /string push$ ;
\ extracts string subsection.
\ index>=0: start counting from left. index<0: start counting from right.
\ index or len out of bounds will be truncated to string boundary.
: mid$ ( index len -- ) swap ?dup if negate right$ then 0 max left$ ;
: reverse$ ( -- ) detach$ dup 2/ 0 ?do 1- 2dup over + swap i + swapchars loop 2drop ;
\ pass a translation table, starting with ascii 0, of length n.
\ each character in top string is replaced against the corresponding character from table.
: translate$ ( a n -- )
detach$
bounds ?do
dup i c@ u> \ string character in table ?
if
over i c@ + c@ \ read table character
i c! \ store in string
then
loop
2drop ;
\ example tables:
\ create 1to1 128 0 [do] [i] c, [loop] \ tables contains chars 0...127
\ '_ 1to1 bl + c! \ replace space against underscore in translation table
\ 1to1 128 translate$ \ replace spaces in top string against underscores
\ bl 1to1 bl + c! \ fix table 1 to 1 again, as we'll reuse it for example 3
\ create noctrlchars here 32 dup allot bl fill \ creates table with 32 spaces
\ noctrlchars 32 translate$ \ translates control chars against spaces
\ 1to1 'a + 1to1 'A + 26 move \ lowercast capitals in table
\ 1to1 'Z 1+ translate$ \ lowercast string
\ ------------------------------------------------------------
base !
