97 lines · 1.9 KB · Forth
RawDownload
\ @(#) strings.fth 98/01/26 1.2\ String support for PForth\\ Copyright Phil Burk 1994 ANEW TASK-STRINGS.FTH : -TRAILING  ( c-addr u1 -- c-addr u2 , strip trailing blanks )    dup 0>    IF        BEGIN            2dup 1- chars + c@ bl =            over 0> and        WHILE            1-        REPEAT    THEN; \ Structure of string table: $ARRAY  (  )    CREATE  ( #strings #chars_max --  )        dup ,        2+ * even-up allot    DOES>    ( index -- $addr )        dup @  ( get #chars )        rot * + cell+; \ Compare two strings: $= ( $1 $2 -- flag , true if equal )    -1 -rot    dup c@ 1+ 0    DO  dup c@ tolower        2 pick c@ tolower -        IF rot drop 0 -rot LEAVE        THEN        1+ swap 1+ swap    LOOP 2drop; : TEXT=  ( addr1 addr2 count -- flag )    >r -1 -rot    r> 0    ?DO  dup c@ tolower        2 pick c@ tolower -        IF rot drop 0 -rot LEAVE        THEN        1+ swap 1+ swap    LOOP 2drop; : TEXT=?  ( addr1 count addr2 -- flag , for JForth compatibility )    swap text=; : $MATCH?  ( $string1 $string2 -- flag , case INsensitive )    dup c@ 1+ text=;  : INDEX ( $string char -- false | address_char true , search for char in string )    >r >r 0 r> r>    over c@ 1+ 1    DO  over i + c@ over =        IF  rot drop            over i + rot rot LEAVE        THEN    LOOP 2drop    ?dup 0= 0=;  : $APPEND.CHAR  ( $string char -- ) \ ugly stack diagram    over count chars + c!    dup c@ 1+ swap c!; \ ----------------------------------------------: ($ROM)  ( index address -- $string )    ( -- index address )    swap 0    ?DO dup c@ 1+ + aligned    LOOP; : $ROM ( packed array of strings, unalterable )    CREATE ( <name> -- )    DOES> ( index -- $string )  ($rom); : TEXTROM ( packed array of strings, unalterable )    CREATE ( <name> -- )    DOES> ( index -- address count )  ($rom) count; \ -----------------------------------------------