bb6b2dcd |
1 | \ @(#) t_corex.fth 98/03/16 1.2\r |
2 | \ Test ANS Forth Core Extensions\r |
3 | \\r |
4 | \ Copyright 1994 3DO, Phil Burk\r |
5 | \r |
6 | INCLUDE? }T{ t_tools.fth\r |
7 | \r |
8 | ANEW TASK-T_COREX.FTH\r |
9 | \r |
10 | DECIMAL\r |
11 | \r |
12 | \ STUB because missing definition in pForth - FIXME\r |
13 | : SAVE-INPUT ;\r |
14 | : RESTORE-INPUT -1 ;\r |
15 | \r |
16 | TEST{\r |
17 | \r |
18 | \ ==========================================================\r |
19 | T{ 1 2 3 }T{ 1 2 3 }T\r |
20 | \r |
21 | \ ----------------------------------------------------- .(\r |
22 | T{ 27 .( IF YOU SEE THIS THEN .( WORKED!) }T{ 27 }T\r |
23 | \r |
24 | CR .( 1234 - SHOULD LINE UP WITH NEXT LINE.) CR 1234 8 .R CR\r |
25 | \r |
26 | T{ .( ) 987 .( TEST NULL STRING IN .( ) CR }T{ 987 }T\r |
27 | \r |
28 | \ ----------------------------------------------------- 0<>\r |
29 | T{ 5 0<> }T{ TRUE }T\r |
30 | T{ 0 0<> }T{ 0 }T\r |
31 | T{ -1000 0<> }T{ TRUE }T\r |
32 | \r |
33 | \ ----------------------------------------------------- 2>R 2R> 2R@\r |
34 | : T2>R ( -- .... )\r |
35 | 17\r |
36 | 20 5 2>R\r |
37 | 19\r |
38 | 2R@\r |
39 | 37\r |
40 | 2R>\r |
41 | \ 2>R should be the equivalent of SWAP >R >R so this next construct\r |
42 | \ should reduce to a SWAP.\r |
43 | 88 77 2>R R> R>\r |
44 | ;\r |
45 | T{ T2>R }T{ 17 19 20 5 37 20 5 77 88 }T\r |
46 | \r |
47 | \ ----------------------------------------------------- :NONAME\r |
48 | T{ :NONAME 100 50 + ; EXECUTE }T{ 150 }T\r |
49 | \r |
50 | \ ----------------------------------------------------- <>\r |
51 | T{ 12345 12305 <> }T{ TRUE }T\r |
52 | T{ HEX 98765432 98765432 DECIMAL <> }T{ 0 }T\r |
53 | \r |
54 | \ ----------------------------------------------------- ?DO\r |
55 | : T?DO ( n -- sum_n ) 0 SWAP 1+ 0 ?DO i + LOOP ;\r |
56 | T{ 0 T?DO }T{ 0 }T\r |
57 | T{ 4 T?DO }T{ 10 }T\r |
58 | \r |
59 | \ ----------------------------------------------------- AGAIN\r |
60 | : T.AGAIN ( n -- )\r |
61 | BEGIN\r |
62 | DUP .\r |
63 | DUP 6 < IF EXIT THEN\r |
64 | 1-\r |
65 | AGAIN\r |
66 | ;\r |
67 | T{ 10 T.AGAIN CR }T{ 5 }T\r |
68 | \r |
69 | \ ----------------------------------------------------- C"\r |
70 | : T.C" ( -- $STRING )\r |
71 | C" x5&"\r |
72 | ;\r |
73 | T{ T.C" C@ }T{ 3 }T\r |
74 | T{ T.C" COUNT DROP C@ }T{ CHAR x }T\r |
75 | T{ T.C" COUNT DROP CHAR+ C@ }T{ CHAR 5 }T\r |
76 | T{ T.C" COUNT DROP 2 CHARS + C@ }T{ CHAR & }T\r |
77 | \r |
78 | \ ----------------------------------------------------- CASE\r |
79 | : T.CASE ( N -- )\r |
80 | CASE\r |
81 | 1 OF 101 ENDOF\r |
82 | 27 OF 892 ENDOF\r |
83 | 941 SWAP \ default\r |
84 | ENDCASE\r |
85 | ;\r |
86 | T{ 1 T.CASE }T{ 101 }T\r |
87 | T{ 27 T.CASE }T{ 892 }T\r |
88 | T{ 49 T.CASE }T{ 941 }T\r |
89 | \r |
90 | \ ----------------------------------------------------- COMPILE,\r |
91 | : COMPILE.SWAP ['] SWAP COMPILE, ; IMMEDIATE\r |
92 | : T.COMPILE,\r |
93 | 19 20 27 COMPILE.SWAP 39\r |
94 | ;\r |
95 | T{ T.COMPILE, }T{ 19 27 20 39 }T\r |
96 | \r |
97 | \ ----------------------------------------------------- CONVERT\r |
98 | : T.CONVERT\r |
99 | 0 S>D S" 1234xyz" DROP CONVERT\r |
100 | >R\r |
101 | D>S\r |
102 | R> C@\r |
103 | ;\r |
104 | T{ T.CONVERT }T{ 1234 CHAR x }T\r |
105 | \r |
106 | \ ----------------------------------------------------- ERASE\r |
107 | : T.COMMA.SEQ ( n -- , lay down N sequential bytes )\r |
108 | 0 ?DO I C, LOOP\r |
109 | ;\r |
110 | CREATE T-ERASE-DATA 64 T.COMMA.SEQ\r |
111 | T{ T-ERASE-DATA 8 + C@ }T{ 8 }T\r |
112 | T{ T-ERASE-DATA 7 + 3 ERASE\r |
113 | T{ T-ERASE-DATA 6 + C@ }T{ 6 }T\r |
114 | T{ T-ERASE-DATA 7 + C@ }T{ 0 }T\r |
115 | T{ T-ERASE-DATA 8 + C@ }T{ 0 }T\r |
116 | T{ T-ERASE-DATA 9 + C@ }T{ 0 }T\r |
117 | T{ T-ERASE-DATA 10 + C@ }T{ 10 }T\r |
118 | \r |
119 | \ ----------------------------------------------------- FALSE\r |
120 | T{ FALSE }T{ 0 }T\r |
121 | \r |
122 | \ ----------------------------------------------------- HEX\r |
123 | T{ HEX 10 DECIMAL }T{ 16 }T\r |
124 | \r |
125 | \ ----------------------------------------------------- MARKER\r |
126 | : INDIC? ( <name> -- ifInDic , is the following word defined? )\r |
127 | bl word find\r |
128 | swap drop 0= 0=\r |
129 | ;\r |
130 | create FOOBAR\r |
131 | MARKER MYMARK \ create word that forgets itself\r |
132 | create GOOFBALL\r |
133 | MYMARK\r |
134 | T{ indic? foobar indic? mymark indic? goofball }T{ true false false }T\r |
135 | \r |
136 | \ ----------------------------------------------------- NIP\r |
137 | T{ 33 44 55 NIP }T{ 33 55 }T\r |
138 | \r |
139 | \ ----------------------------------------------------- PARSE\r |
140 | : T.PARSE ( char <string>char -- addr num )\r |
141 | PARSE\r |
142 | >R \ save length\r |
143 | PAD R@ CMOVE \ move string to pad\r |
144 | PAD R>\r |
145 | ;\r |
146 | T{ CHAR % T.PARSE wxyz% SWAP C@ }T{ 4 CHAR w }T\r |
147 | \r |
148 | \ ----------------------------------------------------- PICK\r |
149 | T{ 13 12 11 10 2 PICK }T{ 13 12 11 10 12 }T\r |
150 | \r |
151 | \ ----------------------------------------------------- QUERY\r |
152 | T{ ' QUERY 0<> }T{ TRUE }T\r |
153 | \r |
154 | \ ----------------------------------------------------- REFILL\r |
155 | T{ ' REFILL 0<> }T{ TRUE }T\r |
156 | \r |
157 | \ ----------------------------------------------------- RESTORE-INPUT\r |
158 | T{ : T.SAVE-INPUT SAVE-INPUT RESTORE-INPUT ; T.SAVE-INPUT }T{ 0 }T \ EXPECTED FAILURE\r |
159 | \r |
160 | \ ----------------------------------------------------- ROLL\r |
161 | T{ 15 14 13 12 11 10 0 ROLL }T{ 15 14 13 12 11 10 }T\r |
162 | T{ 15 14 13 12 11 10 1 ROLL }T{ 15 14 13 12 10 11 }T\r |
163 | T{ 15 14 13 12 11 10 2 ROLL }T{ 15 14 13 11 10 12 }T\r |
164 | T{ 15 14 13 12 11 10 3 ROLL }T{ 15 14 12 11 10 13 }T\r |
165 | T{ 15 14 13 12 11 10 4 ROLL }T{ 15 13 12 11 10 14 }T\r |
166 | \r |
167 | \ ----------------------------------------------------- SOURCE-ID\r |
168 | T{ SOURCE-ID 0<> }T{ TRUE }T\r |
169 | T{ : T.SOURCE-ID S" SOURCE-ID" EVALUATE ; T.SOURCE-ID }T{ -1 }T\r |
170 | \r |
171 | \ ----------------------------------------------------- SPAN\r |
172 | T{ ' SPAN 0<> }T{ TRUE }T\r |
173 | \r |
174 | \ ----------------------------------------------------- TO VALUE\r |
175 | 333 VALUE MY-VALUE\r |
176 | T{ MY-VALUE }T{ 333 }T\r |
177 | T{ 1000 TO MY-VALUE MY-VALUE }T{ 1000 }T\r |
178 | : TEST.VALUE ( -- 19 100 )\r |
179 | 100 TO MY-VALUE\r |
180 | 19\r |
181 | MY-VALUE\r |
182 | ;\r |
183 | T{ TEST.VALUE }T{ 19 100 }T\r |
184 | \r |
185 | \ ----------------------------------------------------- TRUE\r |
186 | T{ TRUE }T{ 0 0= }T\r |
187 | \r |
188 | \ ----------------------------------------------------- TUCK\r |
189 | T{ 44 55 66 TUCK }T{ 44 66 55 66 }T\r |
190 | \r |
191 | \ ----------------------------------------------------- U.R\r |
192 | HEX CR .( ABCD4321 - SHOULD LINE UP WITH NEXT LINE.) CR\r |
193 | ABCD4321 C U.R CR DECIMAL\r |
194 | \r |
195 | \ ----------------------------------------------------- U>\r |
196 | T{ -5 3 U> }T{ TRUE }T\r |
197 | T{ 10 8 U> }T{ TRUE }T\r |
198 | \r |
199 | \ ----------------------------------------------------- UNUSED\r |
200 | T{ UNUSED 0> }T{ TRUE }T\r |
201 | \r |
202 | \ ----------------------------------------------------- WITHIN\r |
203 | T{ 4 5 10 WITHIN }T{ 0 }T\r |
204 | T{ 5 5 10 WITHIN }T{ TRUE }T\r |
205 | T{ 9 5 10 WITHIN }T{ TRUE }T\r |
206 | T{ 10 5 10 WITHIN }T{ 0 }T\r |
207 | \r |
208 | T{ 4 10 5 WITHIN }T{ TRUE }T\r |
209 | T{ 5 10 5 WITHIN }T{ 0 }T\r |
210 | T{ 9 10 5 WITHIN }T{ 0 }T\r |
211 | T{ 10 10 5 WITHIN }T{ TRUE }T\r |
212 | \r |
213 | T{ -6 -5 10 WITHIN }T{ 0 }T\r |
214 | T{ -5 -5 10 WITHIN }T{ TRUE }T\r |
215 | T{ 9 -5 10 WITHIN }T{ TRUE }T\r |
216 | T{ 10 -5 10 WITHIN }T{ 0 }T\r |
217 | \r |
218 | \r |
219 | \ ----------------------------------------------------- [COMPILE]\r |
220 | : T.[COMPILE].IF [COMPILE] IF ; IMMEDIATE\r |
221 | : T.[COMPILE] 40 0> T.[COMPILE].IF 97 ELSE 53 THEN 97 = ;\r |
222 | T{ T.[COMPILE] }T{ TRUE }T\r |
223 | \r |
224 | \ ----------------------------------------------------- \\r |
225 | }TEST\r |
226 | \r |