1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
\ @(#) 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 * + 4 +
;
\ 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
;
\ -----------------------------------------------
|
