Mercurial > hg > Members > kono > os9 > sbc09
comparison examples_forth/extend09.4 @ 57:2088fd998865
sbc09 directry clean up
author | Shinji KONO <kono@ie.u-ryukyu.ac.jp> |
---|---|
date | Mon, 23 Jul 2018 16:07:12 +0900 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
56:4fa2bdb0c457 | 57:2088fd998865 |
---|---|
1 \ Extensions to sod Forth kernel to make a complete Forth system. | |
2 \ created 1994 by L.C. Benschop. | |
3 \ copyleft (c) 1994-2014 by the sbc09 team, see AUTHORS for more details. | |
4 \ license: GNU General Public License version 2, see LICENSE for more details. | |
5 | |
6 : \G POSTPONE \ ; IMMEDIATE | |
7 \G comment till end of line for inclusion in glossary. | |
8 | |
9 \ PART 1: MISCELLANEOUS WORDS. | |
10 | |
11 : COMPARE ( addr1 u1 addr2 u2 --- diff ) | |
12 \G Compare two strings. diff is negative if addr1 u1 is smaller, 0 if it | |
13 \G is equal and positive if it is greater than addr2 u2. | |
14 ROT 2DUP - >R | |
15 MIN DUP IF | |
16 >R | |
17 BEGIN | |
18 OVER C@ OVER C@ - IF | |
19 SWAP C@ SWAP C@ - R> DROP R> DROP EXIT | |
20 THEN | |
21 1+ SWAP 1+ SWAP | |
22 R> 1- DUP >R 0= | |
23 UNTIL R> | |
24 THEN DROP | |
25 DROP DROP R> NEGATE | |
26 ; | |
27 | |
28 : ERASE 0 FILL ; | |
29 | |
30 : <= ( n1 n2 --- f) | |
31 \G f is true if and only if n1 is less than or equal to n2. | |
32 > 0= ; | |
33 | |
34 : 0<= ( n1 --- f) | |
35 \G f is true if and only if n1 is less than zero. | |
36 0 <= ; | |
37 | |
38 : >= | |
39 < 0= ; | |
40 | |
41 : 0<> | |
42 0= 0= ; | |
43 | |
44 : BOUNDS ( addr1 n --- addr2 addr1) | |
45 \G Convert address and length to two bounds addresses for DO LOOP | |
46 OVER + SWAP ; | |
47 | |
48 : WITHIN ( u1 u2 u3 --- f) | |
49 \G f is true if u1 is greater or equal to u2 and less than u3 | |
50 2 PICK U> ROT ROT U< 0= AND ; | |
51 | |
52 : -TRAILING ( c-addr1 u1 --- c-addr2 u2) | |
53 \G Adjust the length of the string such that trailing spaces are excluded. | |
54 BEGIN | |
55 2DUP + 1- C@ BL = | |
56 WHILE | |
57 1- | |
58 REPEAT | |
59 ; | |
60 | |
61 : NIP ( x1 x2 --- x2) | |
62 \G Discard the second item on the stack. | |
63 SWAP DROP ; | |
64 | |
65 \ PART 2: SEARCH ORDER WORDLIST | |
66 | |
67 : GET-ORDER ( --- w1 w2 ... wn n ) | |
68 \G Return all wordlists in the search order, followed by the count. | |
69 #ORDER @ 0 ?DO CONTEXT I CELLS + @ LOOP #ORDER @ ; | |
70 | |
71 : SET-ORDER ( w1 w2 ... wn n --- ) | |
72 \G Set the search order to the n wordlists given on the stack. | |
73 #ORDER ! 0 #ORDER @ 1- DO CONTEXT I CELLS + ! -1 +LOOP ; | |
74 | |
75 : ALSO ( --- ) | |
76 \G Duplicate the last wordlist in the search order. | |
77 CONTEXT #ORDER @ CELLS + DUP CELL- @ SWAP ! 1 #ORDER +! ; | |
78 | |
79 : PREVIOUS ( --- ) | |
80 \G Remove the last wordlist from search order. | |
81 -1 #ORDER +! ; | |
82 | |
83 VARIABLE #THREADS ( --- a-addr) | |
84 \G This variable holds the number of threads a word list will have. | |
85 | |
86 : WORDLIST ( --- wid) | |
87 \G Make a new wordlist and give its address. | |
88 HERE #THREADS @ , #THREADS @ CELLS ALLOT HERE #THREADS @ CELLS - | |
89 #THREADS @ CELLS ERASE ; | |
90 | |
91 : DEFINITIONS ( --- ) | |
92 \G Set the definitions wordlist to the last wordlist in the search order. | |
93 CONTEXT #ORDER @ 1- CELLS + @ CURRENT ! ; | |
94 | |
95 : FORTH ( --- ) | |
96 \G REplace the last wordlist in the search order with FORTH-WORDLIST | |
97 FORTH-WORDLIST CONTEXT #ORDER @ 1- CELLS + ! ; | |
98 | |
99 1 #THREADS ! | |
100 WORDLIST | |
101 CONSTANT ROOT-WORDLIST ( --- wid ) | |
102 \G Minimal wordlist for ONLY | |
103 | |
104 4 #THREADS ! | |
105 | |
106 : ONLY ( --- ) | |
107 \G Set the search order to the minimal wordlist. | |
108 1 #ORDER ! ROOT-WORDLIST CONTEXT ! ; | |
109 | |
110 : VOCABULARY ( --- ) | |
111 \G Make a definition that will replace the last word in the search order | |
112 \G by its wordlist. | |
113 WORDLIST CREATE , \ Make a new wordlist and store it in def. | |
114 DOES> >R \ Replace last item in the search order. | |
115 GET-ORDER SWAP DROP R> @ SWAP SET-ORDER ; | |
116 | |
117 | |
118 \ PART 3: SOME UTILITIES, DUMP .S WORDS | |
119 | |
120 : DL ( addr1 --- addr2 ) | |
121 \G hex/ascii dump in one line of 16 bytes at addr1 addr2 is addr1+16 | |
122 BASE @ >R 16 BASE ! CR | |
123 DUP 0 <# # # # # #> TYPE ." : " | |
124 16 0 DO | |
125 DUP I + C@ 0 <# # # #> TYPE SPACE | |
126 LOOP | |
127 16 0 DO | |
128 DUP I + C@ DUP 127 AND 31 < IF DROP ." ." ELSE EMIT THEN | |
129 LOOP | |
130 16 + R> BASE ! ; | |
131 | |
132 | |
133 : DUMP ( addr len --- ) | |
134 \G Show a hex/ascii dump of the memory block of len bytes at addr | |
135 15 + 4 RSHIFT 0 DO | |
136 DL | |
137 LOOP DROP ; | |
138 | |
139 : .S ( --- ) | |
140 \G Show the contents of the stack. | |
141 DEPTH IF | |
142 0 DEPTH 2 - DO I PICK . -1 +LOOP | |
143 ELSE ." Empty " THEN ; | |
144 | |
145 | |
146 : ID. ( nfa --- ) | |
147 \G Show the name of the word with name field address nfa. | |
148 COUNT 31 AND TYPE SPACE ; | |
149 | |
150 : WORDS ( --- ) | |
151 \G Show all words in the last wordlist of the search order. | |
152 CONTEXT #ORDER @ 1- CELLS + @ | |
153 DUP @ >R \ number of threads to return stack. | |
154 CELL+ R@ 0 DO DUP I CELLS + @ SWAP LOOP DROP \ All thread pointers to stack. | |
155 BEGIN | |
156 0 0 | |
157 R@ 0 DO | |
158 I 2 + PICK OVER U> IF | |
159 DROP DROP I I 1 + PICK | |
160 THEN | |
161 LOOP \ Find the thread pointer with the highest address. | |
162 WHILE | |
163 DUP 1+ PICK DUP ID. \ Print the name. | |
164 CELL- @ \ Link to previous. | |
165 SWAP 2 + CELLS SP@ + ! \ Update the right thread pointer. | |
166 REPEAT | |
167 DROP R> 0 DO DROP LOOP \ Drop the thread pointers. | |
168 ; | |
169 | |
170 | |
171 ROOT-WORDLIST CURRENT ! | |
172 : FORTH FORTH ; | |
173 : ALSO ALSO ; | |
174 : ONLY ONLY ; | |
175 : PREVIOUS PREVIOUS ; | |
176 : DEFINITIONS DEFINITIONS ; | |
177 : WORDS WORDS ; | |
178 DEFINITIONS | |
179 \ Fill the ROOT wordlist. | |
180 | |
181 \ PART 4: ERROR MESSAGES | |
182 | |
183 : MESS" ( n "cccq" --- ) | |
184 \G Create an error message for throw code n. | |
185 ALIGN , ERRORS @ , HERE 2 CELLS - ERRORS ! 34 WORD C@ 1+ ALLOT ; | |
186 | |
187 -3 MESS" Stack overflow" | |
188 -4 MESS" Stack underflow" | |
189 -10 MESS" Divide overflow" | |
190 -13 MESS" Undefined word" | |
191 -22 MESS" Incomplete control structure" | |
192 -28 MESS" BREAK key pressed" | |
193 -37 MESS" File I/O error" | |
194 -38 MESS" File does not exist" | |
195 | |
196 : 2CONSTANT ( d --- ) | |
197 \G Create a new definition that has the following runtime behavior. | |
198 \G Runtime: ( --- d) push the constant double number on the stack. | |
199 CREATE HERE 2! 2 CELLS ALLOT DOES> 2@ ; | |
200 | |
201 : D.R ( d n --- ) | |
202 \G Print double number d right-justified in a field of width n. | |
203 >R SWAP OVER DABS <# #S ROT SIGN #> R> OVER - 0 MAX SPACES TYPE ; | |
204 | |
205 : U.R ( u n --- ) | |
206 \G Print unsigned number u right-justified in a field of width n. | |
207 >R 0 R> D.R ; | |
208 | |
209 : .R ( n1 n2 --- ) | |
210 \G Print number n1 right-justified in a field of width n2. | |
211 >R S>D R> D.R ; | |
212 | |
213 : AT-XY ( x y --- ) | |
214 \G Put screen cursor at location (x,y) (0,0) is upper left corner. | |
215 27 EMIT [CHAR] [ EMIT SWAP 1+ SWAP 0 .R [CHAR] ; EMIT | |
216 1+ 0 .R [CHAR] H EMIT ; | |
217 | |
218 : PAGE | |
219 \G Clear the screen. | |
220 27 EMIT ." [2J" 0 0 AT-XY ; | |
221 | |
222 : VALUE ( n --- ) | |
223 CREATE , DOES> @ ; | |
224 | |
225 : TO | |
226 ' >BODY STATE @ IF | |
227 POSTPONE LITERAL POSTPONE ! | |
228 ELSE | |
229 ! | |
230 THEN | |
231 ; IMMEDIATE | |
232 | |
233 : D- ( d1 d2 --- d3) | |
234 DNEGATE D+ ; | |
235 | |
236 : D0= | |
237 OR 0= ; | |
238 | |
239 : D= | |
240 D- D0= ; | |
241 | |
242 : BLANK | |
243 32 FILL ; | |
244 | |
245 : AGAIN | |
246 POSTPONE 0 POSTPONE UNTIL ; IMMEDIATE | |
247 | |
248 : CASE | |
249 CSP @ SP@ CSP ! ; IMMEDIATE | |
250 : OF | |
251 POSTPONE OVER POSTPONE = POSTPONE IF POSTPONE DROP ; IMMEDIATE | |
252 : ENDOF | |
253 POSTPONE ELSE ; IMMEDIATE | |
254 : ENDCASE | |
255 POSTPONE DROP BEGIN SP@ CSP @ - WHILE POSTPONE THEN REPEAT | |
256 CSP ! ; IMMEDIATE | |
257 | |
258 | |
259 : MS ( n --- ) | |
260 \G Delay for n milliseconds. | |
261 5 + 20 / $2B @ + BEGIN DUP $2B @ = UNTIL DROP ; | |
262 | |
263 CAPS ON | |
264 |