This article is from German FIG Forth society (Forthgesellschaft)

link http://forth-ev.de/filemgmt/singlefile.php?lid=474

download --> the win32forth source

-------------------------------------

\ string stack geforth 6.3.2013, f83 1986 mka

\ 09.03.2013 geht im Prinzip wieder. debugging needed.

\ 10.03.2013 alles ok

\ works ok on Win32forth PeterForth --2019

: -- bye ;

\ : ok ; \ tested ok

vocabulary stringstackwords stringstackwords definitions

decimal

: ($ postpone ( ; immediate

false [if] Stringstack structure

Stack is growing down in memory space.

---------------------------------------------------

here3 (bot$) <-- bot$ is saved here

here2: sp$ <-- 'SP$ is pointing there

top of stack: s0 top$

s1 sec$

...

sn

bot of stack: her0+cell bot$ <-- end of string stack

here0: (sp$) <-- sp$ location is saved here

header: <name>

---------------------------------------------------

[then]

variable 'SP$ \ holds string stack pointer location.

variable CSP$ \ store a current stackpointer there. Stringstack "marker".

: create-stringstack ( "name n -- )

create

here 0 , ( -- n here0 )

swap allot align ( -- here0 )

here over ! \ save sp$ adr to her0

here 'sp$ ! \ init 'pointer

here , \ init sp$ to itself

cell+ , \ save bottom adr

does> @ 'sp$ ! ;

1000 create-stringstack $S

\ stringstack basics (stringstack unchanged).

: SP$ ( -- adr ) 'sp$ @ ;

: TOS$ ( -- adr ) sp$ @ ;

: BOT$ ( -- adr ) sp$ cell+ @ ;

: !CSP$ ( -- ) tos$ csp$ ! ; \ store current stack pointer

: ?CSP$ ( -- ) tos$ csp$ @ <> abort" $stack changed" ;

: ?OFL ( adr -- ) bot$ u< abort" $overflow" ;

: ?LIM ( len -- ) $FF00 and abort" $toolong" ; ( ???)

: ?MTY ( adr -- ) sp$ >= abort" $underflow" ;

: ?FIT ( len -- ) tos$ c@ u> abort" $does'nt fit in tos$ " ;

: SKIP$ ( adr1 -- adr2 ) count + ;

: PICK$ ( nth -- adr )

tos$ begin dup ?mty swap ?dup while 1- swap skip$ repeat ;

: TOP$ ( -- adr ) 0 pick$ ;

: SEC$ ( -- adr ) 1 pick$ ;

: DEPTH$ ( -- n ) ($ sn..s0 )

0 tos$ begin dup sp$ - while skip$ swap 1+ swap repeat drop ;

: LAST$ ( -- adr ) depth$ 1- pick$ ;

\ ----------------------------------------- adressing top string -----------------------------------

: TOPCOUNT$ ( -- adr+1 len ) ($ -- ) top$ count ;

: TOPLENGTH$ ( -- len ) ($ -- ) top$ c@ ;

: TOPLOC$ ( +n -- adr ) ($ -- ) top$ + ;

: GET$ ( n -- char ) toploc$ c@ ;

: PUT$ ( char n -- ) toploc$ c! ;

\ ------------------------- use to move part of strings around -----------------------------

: EXTRACT$ ( n1 n2 -- from.adr len )

toplength$ umin over - 1+ swap toploc$ swap ;

: PATCH$ ( len n -- to.adr len )

2dup + ?fit toploc$ swap ;

\ ok

\ ----------------- move strings to and from top of stringstack ------------------------

\ (number of items on stringstack changed!)

: "PUSH ( from.adr len -- ) ($ -- s ) \ push string to stringstack.

dup ?lim tos$ over - 1- dup ?ofl dup sp$ ! place ;

: "POP ( -- from.adr len ) ($ s -- )

topcount$ 2dup + sp$ ! ;

: "CHAR ( char -- ) ($ -- s ) here ( dumy adr) 1 "push topcount$ drop c! ;

: "@ ( from.buffer -- ) ($ -- s ) count "push ;

: "! ( to.buffer -- ) ($ s -- ) "pop rot place ;

: "COPY ( to.buffer -- ) ($ s -- s ) \ non destructive

topcount$ rot place ;

\ -------------------------------- stringstack operators -----------------------------------

: "EMPTY ( -- ) ($ sn..s0 -- ) sp$ dup ! ;

: "CLEAR ( -- ) ($ sn..sm..s0 -- sn..sm ) csp$ @ sp$ ! ;

: "DROP ( -- ) ($ s -- ) "pop 2drop ;

: "PICK ( n -- ) ($ sm..sn..s0 -- sm..sn..s0 sn ) pick$ "@ ;

: "DUP ( -- ) ($ s -- s s ) 0 "pick ;

: "OVER ( -- ) ($ a b -- a b a ) 1 "pick ;

: "ROLL ( n -- ) ($ sn..s0 -- sn-1..s0 sn )

pick$ dup "@ tos$ tuck - "pop + swap cmove> ;

: "ROLLDOWN ( n -- ) ($ sn..s1 s0 -- s0 sn .. s1 )

pick$ skip$ dup topcount$ + tuck - tos$ swap

"dup cmove "pop rot over - 1- place ;

: "SWAP ( -- ) ($ a b -- b a ) 1 "roll ;

: "ROT ( -- ) ($ a b c -- b c a ) 2 "roll ;

\ manipulate top strings

: "JOIN ( -- ) ($ a b -- ab )

tos$ dup >r "pop dup toplength$ + r> c! over sp$ ! 1+ cmove> ;

: "SPLIT ( n -- ) ($ ab -- a b )

toplength$ over - over toploc$ >r >r

"pop drop swap over 2 - dup sp$ ! place r> r> c! ;

: "PATCH ( n -- ) ($ abcd xx -- axxd ) "pop rot patch$ cmove ;

: "EXTRACT ( n1 n2 -- ) ($ asb -- s ) extract$ "drop "push ;

: "INSERT ( n -- ) ($ ab s -- asb )

"swap "split "rot "swap "join "join ;

\ change top string

: "FILL ( c -- ) ($ s -- cc ) \ replace characters with c

topcount$ rot fill ;

: "BLANK ( -- ) ($ s -- bl ) \ replace characters with blanks

bl "fill ;

\ 46 "fill ; \ testing

: "APPEND ( char -- ) ($ s1 -- s2 ) "char "swap "join ;

: "INFRONT ( char -- ) ($ s1 -- s2 ) "char "join ;

: "ENROL ( char -- ) ($ s - s' )

topcount$ 1- 2dup >r dup 1+ swap r> cmove + c! ;

: "BLANKS ( len -- ) ($ -- s ) \ make blank string

here swap "push "blank ;

: "SUPP ( len -- ) ($ s -- s bl ) \ make supplement blank string

toplength$ - 0 max "blanks ;

: "L ( len -- ) ($ s -- s_bl ) "supp "swap "join ;

: "R ( len -- ) ($ s -- bl_s ) "supp "join ;

\ special string types

\ : "" ( -- ) ($ -- s ) 0 0 "push ;

\ : "D ( d -- ) ($ -- s ) (d.) "push ;

\ : "0 ( -- ) ($ -- s ) 0 0 "d ;

\ : "NUMBER ( -- d ) ($ s -- )

\ lenght$ toploc$ c@ bl = not IF bl "append THEN

\ "pop drop number ;

\ : (D.PRICE) ( d -- adr len )

\ tuck dabs <# # # ascii . hold #s rot sign #> ;

\ : "PRICE ( -- ) ($ s -- $US ) "number (d.price) "push ;

\ string comparators

: COMPARE$ ( -- n ) ($ s1 s0 -- s1 s0 ) ok

top$ count sec$ count compare ;

: "COMPARE ( --- n ) ($ s1 s2 -- ) compare$ "drop "drop ; ok

: "= ( -- f ) ($ s1 s2 -- ) "compare 0= ;

: "< ( -- f ) ($ s1 s2 -- ) "compare 0< ;

: "<= ( -- f ) ($ s1 s2 -- ) "compare dup 0< swap 0= or ;

ok

\ string compiling layer ( not implemented here)

\ string definig words ( not done here )

\ stringstack I/O

: "TYPE ( -- ) ($ s -- s ) \ non destructive info of tos$.

topcount$ type ; ok

: ". ( -- ) ($ s -- ) "pop type ;

: "AT ( col row -- ) ($ s -- ) at-xy ". ;

: ".R ( len -- ) ($ s -- ) "R ". ;

: ".L ( len -- ) ($ s -- ) "L ". ;

: "EXPECT ( len -- ) ($ -- s )

"blanks topcount$ expect "pop drop span @ "push ;

\ string input special ( no)

\ string debugging toolbox

defer (.s$)

: ".S ( -- ) ($ -- ) \ show strings on stringstack

depth$ 0= IF ." Empty$ " exit then

tos$ BEGIN depth$ while (.s$) REPEAT sp$ ! space ;

: "PRINTLINE ( -- ) cr ". ;

' "printline is (.s$)

: ?$ ( adr -- ) ($ s -- s ) \ check whats there

count type ;

: "DUMP ( -- ) ($ s -- s ) \ dump top of stringstack

top$ toplength$ 1+ dump ;

\ F83 trace not implemented

\ words cr cr

\ ------------------------------------- use --------------------------------------------------------------------------------

true [if] \ examples

s" eins = one " "push

s" zwei = two " "push

s" drei = three " "push

s" vier = four " "push

".s .s

[then]

( finis)