[pforth] / fth / strings.fth

\ @(#) 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
;

\ -----------------------------------------------
Commit	Line	Data
8e9db35f PB	1	\ @(#) strings.fth 98/01/26 1.2
	2	\ String support for PForth
	3	\
	4	\ Copyright Phil Burk 1994
	5
	6	ANEW TASK-STRINGS.FTH
	7
	8	: -TRAILING ( c-addr u1 -- c-addr u2 , strip trailing blanks )
	9	dup 0>
	10	IF
	11	BEGIN
	12	2dup 1- chars + c@ bl =
	13	over 0> and
	14	WHILE
	15	1-
	16	REPEAT
	17	THEN
	18	;
	19
	20	\ Structure of string table
	21	: $ARRAY ( )
	22	CREATE ( #strings #chars_max -- )
	23	dup ,
	24	2+ * even-up allot
	25	DOES> ( index -- $addr )
	26	dup @ ( get #chars )
	27	rot * + cell+
	28	;
	29
	30	\ Compare two strings
	31	: $= ( $1 $2 -- flag , true if equal )
	32	-1 -rot
	33	dup c@ 1+ 0
	34	DO dup c@ tolower
	35	2 pick c@ tolower -
	36	IF rot drop 0 -rot LEAVE
	37	THEN
	38	1+ swap 1+ swap
	39	LOOP 2drop
	40	;
	41
	42	: TEXT= ( addr1 addr2 count -- flag )
	43	>r -1 -rot
	44	r> 0
	45	?DO dup c@ tolower
	46	2 pick c@ tolower -
	47	IF rot drop 0 -rot LEAVE
	48	THEN
	49	1+ swap 1+ swap
	50	LOOP 2drop
	51	;
	52
	53	: TEXT=? ( addr1 count addr2 -- flag , for JForth compatibility )
	54	swap text=
	55	;
	56
	57	: $MATCH? ( $string1 $string2 -- flag , case INsensitive )
	58	dup c@ 1+ text=
	59	;
	60
	61
	62	: INDEX ( $string char -- false \| address_char true , search for char in string )
	63	>r >r 0 r> r>
	64	over c@ 1+ 1
65	DO over i + c@ over =
66	IF rot drop
67	over i + rot rot LEAVE
68	THEN
69	LOOP 2drop
70	?dup 0= 0=
71	;
72
73
74	: $APPEND.CHAR ( $string char -- ) \ ugly stack diagram
75	over count chars + c!
76	dup c@ 1+ swap c!
77	;
78
79	\ ----------------------------------------------
80	: ($ROM) ( index address -- $string )
81	( -- index address )
82	swap 0
83	?DO dup c@ 1+ + aligned
84	LOOP
85	;
86
87	: $ROM ( packed array of strings, unalterable )
88	CREATE ( <name> -- )
89	DOES> ( index -- $string ) ($rom)
90	;
91
92	: TEXTROM ( packed array of strings, unalterable )
93	CREATE ( <name> -- )
94	DOES> ( index -- address count ) ($rom) count
95	;
96
97	\ -----------------------------------------------