|
57
|
1 \ This is the file kernel.4, included by the cross compiler.
|
|
|
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 \ It is excessively commented as it must serve as an introduction to the
|
|
|
7 \ construction of Forth compilers.
|
|
|
8
|
|
|
9 \ Lines starting with \G are comments that are included in the glossary.
|
|
|
10
|
|
|
11 ALSO TRANSIENT DEFINITIONS
|
|
|
12 FORWARD THROW
|
|
|
13 FORWARD COLD
|
|
|
14 FORWARD WARM
|
|
|
15 PREVIOUS DEFINITIONS
|
|
|
16
|
|
|
17 ALSO ASSEMBLER DEFINITIONS
|
|
|
18
|
|
|
19 : NEXT
|
|
|
20 \ JMP $300 \ For tracing/debugging.
|
|
|
21 PULU PC \ For normal use.
|
|
|
22 ;
|
|
|
23
|
|
|
24 PREVIOUS DEFINITIONS
|
|
|
25
|
|
|
26 ASSEMBLE HEX
|
|
|
27
|
|
|
28 ORIGIN ORG
|
|
|
29 7E C, TRANSIENT COLD ASSEMBLER
|
|
|
30 7E C, TRANSIENT WARM ASSEMBLER \ Jumps to cold and warm entry points.
|
|
|
31
|
|
|
32 ENDASM
|
|
|
33
|
|
|
34 DECIMAL
|
|
|
35 CROSS-COMPILE
|
|
|
36
|
|
|
37 LABEL DOCON
|
|
|
38 LDD 0 ,S [] \ Get constant.
|
|
|
39 STD 0 ,S \ Store it on stack.
|
|
|
40 LABEL DOVAR
|
|
|
41 NEXT
|
|
|
42
|
|
|
43 LABEL DOCOL
|
|
|
44 STU ,--Y \ Save IP on return stack.
|
|
184
|
45 PULS U \ Pop IP from stack where it is left by JSR DOCOL.
|
|
57
|
46 NEXT
|
|
|
47
|
|
|
48 LABEL DODEFER
|
|
|
49 LDX ,S++ [] \ Get jump address.
|
|
|
50 JMP 0 ,X
|
|
|
51 ENDASM
|
|
|
52
|
|
|
53 CODE LIT ( --- n)
|
|
184
|
54 PULU D \ Get literal from instruction stream.
|
|
|
55 PSHS D
|
|
57
|
56 NEXT
|
|
|
57 END-CODE
|
|
|
58
|
|
|
59 CODE BRANCH
|
|
|
60 LABEL BR
|
|
|
61 LDU 0 ,U
|
|
|
62 NEXT
|
|
|
63 END-CODE
|
|
|
64
|
|
|
65 CODE ?BRANCH ( f ---)
|
|
|
66 LDD ,S++
|
|
|
67 BEQ BR \ Bracnh if TOS is zero.
|
|
|
68 LEAU 2 ,U \ Skip branch address.
|
|
|
69 NEXT
|
|
|
70 END-CODE
|
|
|
71
|
|
|
72 CODE EXECUTE ( a ---)
|
|
|
73 RTS
|
|
|
74 END-CODE
|
|
|
75
|
|
|
76 CODE EXIT
|
|
|
77 LDU ,Y++
|
|
|
78 NEXT
|
|
|
79 END-CODE
|
|
|
80
|
|
|
81 CODE UNNEST
|
|
|
82 LDU ,Y++
|
|
|
83 NEXT
|
|
|
84 END-CODE
|
|
|
85
|
|
|
86 CODE (DO) ( l s ---)
|
|
184
|
87 PULS D
|
|
57
|
88 LABEL DO1
|
|
|
89 SUBD 0 ,S
|
|
|
90 EORA # $80 \ Now START-LIMIT-$8000 Initial value for counter.
|
|
184
|
91 PULS X
|
|
57
|
92 STX ,--Y \ Push limit value.
|
|
|
93 STD ,--Y
|
|
|
94 NEXT
|
|
|
95 END-CODE
|
|
|
96
|
|
|
97 CODE (?DO) ( l s ---)
|
|
184
|
98 PULS D
|
|
57
|
99 CMPD 0 ,S
|
|
|
100 0<> IF
|
|
|
101 LEAU 2 ,U \ Skip branch address.
|
|
|
102 BRA DO1
|
|
|
103 THEN
|
|
|
104 LEAS 2 ,S
|
|
|
105 BRA BR
|
|
|
106 END-CODE
|
|
|
107
|
|
|
108 CODE (LOOP)
|
|
|
109 LDD 0 ,Y
|
|
|
110 ADDD # 1
|
|
|
111 LABEL LOOP1
|
|
|
112 VC IF
|
|
|
113 STD 0 ,Y
|
|
|
114 LDU 0 ,U
|
|
|
115 NEXT
|
|
|
116 THEN
|
|
|
117 LEAY 4 ,Y \ Discard parameters from return stack.
|
|
|
118 LEAU 2 ,U \ Skip branch address.
|
|
|
119 NEXT
|
|
|
120 END-CODE
|
|
|
121
|
|
|
122 CODE (+LOOP) ( n ---)
|
|
|
123 LDD 0 ,Y
|
|
|
124 ADDD ,S++
|
|
|
125 BRA LOOP1
|
|
|
126 END-CODE
|
|
|
127
|
|
|
128 CODE (LEAVE)
|
|
|
129 LABEL LEAV1
|
|
|
130 LDU 0 ,U
|
|
|
131 LEAY 4 ,Y
|
|
|
132 NEXT
|
|
|
133 END-CODE
|
|
|
134
|
|
|
135 CODE (?LEAVE) ( f ---)
|
|
|
136 LDD ,S++
|
|
|
137 BEQ LEAV1
|
|
|
138 LEAU 2 ,U
|
|
|
139 NEXT
|
|
|
140 END-CODE
|
|
|
141
|
|
|
142 CODE I ( --- n)
|
|
|
143 LDD 0 ,Y
|
|
|
144 EORA # $80
|
|
|
145 ADDD 2 ,Y
|
|
184
|
146 PSHS D
|
|
57
|
147 NEXT
|
|
|
148 END-CODE
|
|
|
149
|
|
|
150 CODE I' ( ---n)
|
|
|
151 LDD 2 ,Y
|
|
184
|
152 PSHS D
|
|
57
|
153 NEXT
|
|
|
154 END-CODE
|
|
|
155
|
|
|
156 CODE J ( ---n)
|
|
|
157 LDD 4 ,Y
|
|
|
158 EORA # $80
|
|
|
159 ADDD 6 ,Y
|
|
184
|
160 PSHS D
|
|
57
|
161 NEXT
|
|
|
162 END-CODE
|
|
|
163
|
|
|
164 CODE UNLOOP
|
|
|
165 LEAY 4 ,Y
|
|
|
166 NEXT
|
|
|
167 END-CODE
|
|
|
168
|
|
|
169 CODE R@ ( --- n)
|
|
|
170 LDD 0 ,Y
|
|
184
|
171 PSHS D
|
|
57
|
172 NEXT
|
|
|
173 END-CODE
|
|
|
174
|
|
|
175 CODE >R ( n ---)
|
|
184
|
176 PULS D
|
|
57
|
177 STD ,--Y
|
|
|
178 NEXT
|
|
|
179 END-CODE
|
|
|
180
|
|
|
181 CODE R> ( --- n)
|
|
|
182 LDD ,Y++
|
|
184
|
183 PSHS D
|
|
57
|
184 NEXT
|
|
|
185 END-CODE
|
|
|
186
|
|
|
187 CODE RP@ ( --- addr)
|
|
|
188 PSHS Y
|
|
|
189 NEXT
|
|
|
190 END-CODE
|
|
|
191
|
|
|
192 CODE RP! ( addr --- )
|
|
|
193 PULS Y
|
|
|
194 NEXT
|
|
|
195 END-CODE
|
|
|
196
|
|
|
197 CODE SP@ ( --- addr)
|
|
|
198 TFR S, D
|
|
184
|
199 PSHS D
|
|
57
|
200 NEXT
|
|
|
201 END-CODE
|
|
|
202
|
|
|
203 CODE SP! ( addr ---)
|
|
184
|
204 PULS D
|
|
57
|
205 TFR D, S
|
|
|
206 NEXT
|
|
|
207 END-CODE
|
|
|
208
|
|
|
209 CODE UM* ( u1 u2 --- ud)
|
|
|
210 LEAS -4 ,S \ Create room for result.
|
|
|
211 LDA 7 ,S
|
|
|
212 LDB 5 ,S
|
|
|
213 MUL \ Multiply least significant bytes.
|
|
|
214 STD 2 ,S
|
|
|
215 LDA 7 ,S
|
|
|
216 LDB 4 ,S
|
|
|
217 MUL \ Multiply LSB of n1 and MSB of n2.
|
|
|
218 ADDB 2 ,S
|
|
|
219 ADCA # 0
|
|
|
220 STD 1 ,S
|
|
|
221 LDA 6 ,S
|
|
|
222 LDB 5 ,S
|
|
|
223 MUL \ Multiply LSB of n2 and MSB of n1.
|
|
|
224 ADDD 1 ,S
|
|
|
225 STD 1 ,S
|
|
|
226 LDA # 0
|
|
|
227 ADCA # 0
|
|
|
228 STA 0 ,S
|
|
|
229 LDA 6 ,S
|
|
|
230 LDB 4 ,S
|
|
|
231 MUL \ Multiply most significant bytes.
|
|
|
232 ADDD 0 ,S
|
|
|
233 STD 4 ,S
|
|
|
234 LDD 2 ,S
|
|
|
235 STD 6 ,S \ Move result to position of numbers.
|
|
|
236 LEAS 4 ,S \ Reclaim extra space for result.
|
|
|
237 NEXT
|
|
|
238 END-CODE
|
|
|
239
|
|
|
240 CODE UM/MOD ( ud u --- rem quot)
|
|
184
|
241 LDX # 16 \ iteration counter.
|
|
|
242 LDD 2 ,S
|
|
57
|
243 BEGIN
|
|
184
|
244 ASL 5 ,S
|
|
57
|
245 ROL 4 ,S
|
|
184
|
246 ROLB
|
|
|
247 ROLA
|
|
57
|
248 U< IF \ Account for extra bit shifted out, perform subtraction anyway.
|
|
184
|
249 SUBD 0 ,S
|
|
|
250 INC 5 ,S
|
|
57
|
251 ELSE
|
|
184
|
252 CMPD 0 ,S \ Perform trial subtraction.
|
|
57
|
253 U>= IF
|
|
184
|
254 SUBD 0 ,S
|
|
|
255 INC 5 ,S \ Add 1-bit to quotient.
|
|
57
|
256 THEN
|
|
|
257 THEN
|
|
184
|
258 LEAX -1 ,X
|
|
57
|
259 0= UNTIL
|
|
184
|
260 LEAS 2 ,S
|
|
|
261 LDX 2 ,S \ rem and quot on proper positions
|
|
|
262 STX 0 ,S
|
|
|
263 STD 2 ,S \ D contains rem
|
|
57
|
264 NEXT
|
|
|
265 END-CODE
|
|
|
266
|
|
|
267 CODE + ( n1 n2 ---n3)
|
|
184
|
268 PULS D
|
|
57
|
269 ADDD 0 ,S
|
|
|
270 STD 0 ,S
|
|
|
271 NEXT
|
|
|
272 END-CODE
|
|
|
273
|
|
|
274 CODE - ( n1 n2 ---n3)
|
|
|
275 LDD 2 ,S
|
|
|
276 SUBD ,S++
|
|
|
277 STD 0 ,S
|
|
|
278 NEXT
|
|
|
279 END-CODE
|
|
|
280
|
|
|
281 CODE NEGATE ( n1 --- n2)
|
|
|
282 CLRA
|
|
|
283 CLRB
|
|
|
284 SUBD 0 ,S
|
|
|
285 STD 0 ,S
|
|
|
286 NEXT
|
|
|
287 END-CODE
|
|
|
288
|
|
|
289 CODE AND ( n1 n2 ---n3)
|
|
184
|
290 PULS D
|
|
|
291 ANDA ,S
|
|
|
292 ANDB 1 ,S
|
|
57
|
293 STD 0 ,S
|
|
|
294 NEXT
|
|
|
295 END-CODE
|
|
|
296
|
|
|
297 CODE OR ( n1 n2 ---n3)
|
|
184
|
298 PULS D
|
|
|
299 ORA ,S
|
|
|
300 ORB 1 ,S
|
|
57
|
301 STD 0 ,S
|
|
|
302 NEXT
|
|
|
303 END-CODE
|
|
|
304
|
|
|
305 CODE XOR ( n1 n2 ---n3)
|
|
184
|
306 PULS D
|
|
|
307 EORA ,S
|
|
|
308 EORB 1 ,S
|
|
57
|
309 STD 0 ,S
|
|
|
310 NEXT
|
|
|
311 END-CODE
|
|
|
312
|
|
|
313 CODE 1+ ( n1 --- n2)
|
|
|
314 INC 1 ,S
|
|
|
315 0= IF INC 0 ,S THEN
|
|
|
316 NEXT
|
|
|
317 END-CODE
|
|
|
318
|
|
|
319 CODE 1- ( n1 --- n2)
|
|
|
320 LDD 0 ,S
|
|
|
321 SUBD # 1
|
|
|
322 STD 0 ,S
|
|
|
323 NEXT
|
|
|
324 END-CODE
|
|
|
325
|
|
|
326 CODE 2+ ( n1 --- n2)
|
|
|
327 LDD 0 ,S
|
|
|
328 ADDD # 2
|
|
|
329 STD 0 ,S
|
|
|
330 NEXT
|
|
|
331 END-CODE
|
|
|
332
|
|
|
333 CODE 2- ( n1 --- n2)
|
|
|
334 LDD 0 ,S
|
|
|
335 SUBD # 2
|
|
|
336 STD 0 ,S
|
|
|
337 NEXT
|
|
|
338 END-CODE
|
|
|
339
|
|
|
340 CODE 2* ( n1 --- n2)
|
|
|
341 LDD 0 ,S
|
|
|
342 ASLB
|
|
|
343 ROLA
|
|
|
344 STD 0 ,S
|
|
|
345 NEXT
|
|
|
346 END-CODE
|
|
|
347
|
|
|
348 CODE 2/ ( n1 --- n2)
|
|
|
349 LDD 0 ,S
|
|
|
350 ASRA
|
|
|
351 RORB
|
|
|
352 STD 0 ,S
|
|
|
353 NEXT
|
|
|
354 END-CODE
|
|
|
355
|
|
|
356 CODE D+ ( d1 d2 --- d3)
|
|
|
357 LDD 6 ,S
|
|
|
358 ADDD 2 ,S
|
|
|
359 STD 6 ,S
|
|
|
360 LDD 4 ,S
|
|
|
361 ADCB 1 ,S
|
|
|
362 ADCA 0 ,S
|
|
|
363 STD 4 ,S
|
|
|
364 LEAS 4 ,S
|
|
|
365 NEXT
|
|
|
366 END-CODE
|
|
|
367
|
|
|
368 CODE DNEGATE ( d1 --- d2)
|
|
|
369 CLRA
|
|
|
370 CLRB
|
|
|
371 SUBD 2 ,S
|
|
|
372 STD 2 ,S
|
|
|
373 LDD # 0
|
|
|
374 SBCB 1 ,S
|
|
|
375 SBCA 0 ,S
|
|
|
376 STD 0 ,S
|
|
|
377 NEXT
|
|
|
378 END-CODE
|
|
|
379
|
|
|
380 CODE LSHIFT ( u1 n1 --- u2)
|
|
|
381 PULS D
|
|
|
382 TSTB
|
|
|
383 0<> IF
|
|
|
384 BEGIN
|
|
|
385 ASL 1 ,S
|
|
|
386 ROL 0 ,S
|
|
|
387 DECB
|
|
|
388 0= UNTIL
|
|
|
389 THEN
|
|
|
390 NEXT
|
|
|
391 END-CODE
|
|
|
392
|
|
|
393 CODE RSHIFT ( u1 n1 --- u2)
|
|
|
394 PULS D
|
|
|
395 TSTB
|
|
|
396 0<> IF
|
|
|
397 BEGIN
|
|
|
398 LSR 0 ,S
|
|
|
399 ROR 1 ,S
|
|
|
400 DECB
|
|
|
401 0= UNTIL
|
|
|
402 THEN
|
|
|
403 NEXT
|
|
|
404 END-CODE
|
|
|
405
|
|
|
406 CODE DROP ( n --- )
|
|
|
407 LEAS 2 ,S
|
|
|
408 NEXT
|
|
|
409 END-CODE
|
|
|
410
|
|
|
411 CODE DUP ( n --- n n )
|
|
|
412 LDD 0 ,S
|
|
184
|
413 PSHS D
|
|
57
|
414 NEXT
|
|
|
415 END-CODE
|
|
|
416
|
|
|
417 CODE SWAP ( n1 n2 --- n2 n1)
|
|
|
418 LDD 0 ,S
|
|
|
419 LDX 2 ,S
|
|
|
420 STX 0 ,S
|
|
|
421 STD 2 ,S
|
|
|
422 NEXT
|
|
|
423 END-CODE
|
|
|
424
|
|
|
425 CODE OVER ( n1 n2 --- n1 n2 n1)
|
|
|
426 LDD 2 ,S
|
|
184
|
427 PSHS D
|
|
57
|
428 NEXT
|
|
|
429 END-CODE
|
|
|
430
|
|
|
431 CODE ROT ( n1 n2 n3 --- n2 n3 n1)
|
|
|
432 LDD 4 ,S
|
|
|
433 LDX 0 ,S
|
|
|
434 STD 0 ,S
|
|
|
435 LDD 2 ,S
|
|
|
436 STX 2 ,S
|
|
|
437 STD 4 ,S
|
|
|
438 NEXT
|
|
|
439 END-CODE
|
|
|
440
|
|
|
441 CODE -ROT ( n1 n2 n3 --- n3 n1 n2)
|
|
|
442 LDD 4 ,S
|
|
|
443 LDX 2 ,S
|
|
|
444 STD 2 ,S
|
|
|
445 LDD 0 ,S
|
|
|
446 STX 0 ,S
|
|
|
447 STD 4 ,S
|
|
|
448 NEXT
|
|
|
449 END-CODE
|
|
|
450
|
|
|
451 CODE 2DROP ( d ---)
|
|
|
452 LEAS 4 ,S
|
|
|
453 NEXT
|
|
|
454 END-CODE
|
|
|
455
|
|
|
456 CODE 2DUP ( d --- d d )
|
|
|
457 LDX 2 ,S
|
|
|
458 LDD 0 ,S
|
|
|
459 PSHS X, D
|
|
|
460 NEXT
|
|
|
461 END-CODE
|
|
|
462
|
|
|
463 CODE 2SWAP ( d1 d2 --- d2 d1)
|
|
|
464 LDD 6 ,S
|
|
|
465 LDX 2 ,S
|
|
|
466 STD 2 ,S
|
|
|
467 STX 6 ,S
|
|
|
468 LDD 4 ,S
|
|
|
469 LDX 0 ,S
|
|
|
470 STD 0 ,S
|
|
|
471 STX 4 ,S
|
|
|
472 NEXT
|
|
|
473 END-CODE
|
|
|
474
|
|
|
475 CODE 2OVER ( d1 d2 --- d1 d2 d1)
|
|
|
476 LDX 6 ,S
|
|
|
477 LDD 4 ,S
|
|
|
478 PSHS X, D
|
|
|
479 NEXT
|
|
|
480 END-CODE
|
|
|
481
|
|
|
482 CODE PICK ( n1 --- n2)
|
|
|
483 LDD 0 ,S
|
|
184
|
484 ADDD # 1 \ Correct index
|
|
|
485 ASLB \ Cell* (assert: cellL=2!)
|
|
|
486 ROLA
|
|
|
487 LDX D,S \ Pick value
|
|
|
488 STX 0 ,S \ Replace top
|
|
57
|
489 NEXT
|
|
|
490 END-CODE
|
|
|
491
|
|
|
492 CODE ROLL ( n1 ---)
|
|
|
493 LDD 0 ,S
|
|
|
494 LEAS -2 ,S \ Make room to store counter.
|
|
|
495 ADDD # 1
|
|
|
496 STD 0 ,S \ Store 1 plus the counter.
|
|
|
497 ADDD 2 ,S \ Double counter.
|
|
|
498 ADDD # 3
|
|
|
499 LEAX D,S \ Point past last elemtn to roll on stack.
|
|
|
500 LEAX 2 ,X
|
|
|
501 LDD D,S
|
|
|
502 STD 2 ,S \ Store element picked.
|
|
|
503 INC 0 ,S
|
|
|
504 BEGIN
|
|
|
505 BEGIN
|
|
|
506 LDD -4 ,X
|
|
|
507 STD ,--X
|
|
|
508 DEC 1 ,S
|
|
|
509 0= UNTIL
|
|
|
510 DEC 0 ,S
|
|
|
511 0= UNTIL
|
|
|
512 LEAS 4 ,S
|
|
|
513 NEXT
|
|
|
514 END-CODE
|
|
|
515
|
|
|
516 CODE C@ ( addr --- c)
|
|
|
517 LDB 0 ,S []
|
|
|
518 CLRA
|
|
|
519 STD 0 ,S
|
|
|
520 NEXT
|
|
|
521 END-CODE
|
|
|
522
|
|
|
523 CODE @ ( addr --- n)
|
|
|
524 LDD 0 ,S []
|
|
|
525 STD 0 ,S
|
|
|
526 NEXT
|
|
|
527 END-CODE
|
|
|
528
|
|
|
529 CODE C! ( c addr ---)
|
|
|
530 LDB 3 ,S
|
|
|
531 STB 0 ,S []
|
|
|
532 LEAS 4 ,S
|
|
|
533 NEXT
|
|
|
534 END-CODE
|
|
|
535
|
|
|
536 CODE ! ( n addr ---)
|
|
|
537 LDD 2 ,S
|
|
|
538 STD 0 ,S []
|
|
|
539 LEAS 4 ,S
|
|
|
540 NEXT
|
|
|
541 END-CODE
|
|
|
542
|
|
|
543 CODE +! ( n addr ---)
|
|
|
544 PULS X
|
|
|
545 PULS D
|
|
|
546 ADDD 0 ,X
|
|
|
547 STD 0 ,X
|
|
|
548 NEXT
|
|
|
549 END-CODE
|
|
|
550
|
|
|
551 CODE 2@ ( addr --- d)
|
|
|
552 LDX 0 ,S
|
|
|
553 LDD 0 ,X
|
|
|
554 LDX 2 ,X
|
|
|
555 STX 0 ,S
|
|
184
|
556 PSHS D
|
|
57
|
557 NEXT
|
|
|
558 END-CODE
|
|
|
559
|
|
|
560 CODE 2! ( d addr ---)
|
|
|
561 LDX 0 ,S
|
|
|
562 LDD 2 ,S
|
|
|
563 STD 0 ,X
|
|
|
564 LDD 4 ,S
|
|
|
565 STD 2 ,X
|
|
|
566 LEAS 6 ,S
|
|
|
567 NEXT
|
|
|
568 END-CODE
|
|
|
569
|
|
|
570 LABEL YES \ Store a true flag on stack.
|
|
|
571 LEAX -1 ,X
|
|
|
572 STX 0 ,S
|
|
|
573 NEXT
|
|
|
574 ENDASM
|
|
|
575
|
|
|
576 CODE 0= ( n --- f)
|
|
|
577 LDX # 0
|
|
|
578 LDD 0 ,S
|
|
|
579 BEQ YES
|
|
|
580 STX 0 ,S
|
|
|
581 NEXT
|
|
|
582 END-CODE
|
|
|
583
|
|
|
584 CODE 0< ( n --- f)
|
|
|
585 LDX # 0
|
|
|
586 LDD 0 ,S
|
|
|
587 BMI YES
|
|
|
588 STX 0 ,S
|
|
|
589 NEXT
|
|
|
590 END-CODE
|
|
|
591
|
|
|
592 CODE < ( n1 n2 --- f)
|
|
|
593 LDX # 0
|
|
|
594 LDD 2 ,S
|
|
|
595 SUBD ,S++
|
|
|
596 BLT YES
|
|
|
597 STX 0 ,S
|
|
|
598 NEXT
|
|
|
599 END-CODE
|
|
|
600
|
|
|
601 CODE U< ( n1 n2 --- f)
|
|
|
602 LDX # 0
|
|
|
603 LDD 2 ,S
|
|
|
604 SUBD ,S++
|
|
|
605 BLO YES
|
|
|
606 STX 0 ,S
|
|
|
607 NEXT
|
|
|
608 END-CODE
|
|
|
609
|
|
|
610 CODE CMOVE ( addr1 addr2 n ---)
|
|
|
611 LDX 4 ,S
|
|
|
612 STY 4 ,S
|
|
|
613 LDY 2 ,S
|
|
|
614 LDD 0 ,S
|
|
|
615 0<> IF
|
|
|
616 INC 0 ,S
|
|
|
617 BEGIN
|
|
|
618 BEGIN
|
|
|
619 LDA ,X+
|
|
|
620 STA ,Y+
|
|
|
621 DECB
|
|
|
622 0= UNTIL
|
|
|
623 DEC 0 ,S
|
|
|
624 0= UNTIL
|
|
|
625 THEN
|
|
|
626 LDY 4 ,S
|
|
|
627 LEAS 6 ,S
|
|
|
628 NEXT
|
|
|
629 END-CODE
|
|
|
630
|
|
|
631 CODE CMOVE> ( addr1 addr2 n ---)
|
|
|
632 LDX 4 ,S
|
|
|
633 STY 4 ,S
|
|
|
634 LDY 2 ,S
|
|
|
635 LDD 0 ,S
|
|
|
636 LEAX D,X
|
|
|
637 LEAY D,Y
|
|
|
638 LDD 0 ,S
|
|
|
639 0<> IF
|
|
|
640 INC 0 ,S
|
|
|
641 BEGIN
|
|
|
642 BEGIN
|
|
|
643 LDA ,-X
|
|
|
644 STA ,-Y
|
|
|
645 DECB
|
|
|
646 0= UNTIL
|
|
|
647 DEC 0 ,S
|
|
|
648 0= UNTIL
|
|
|
649 THEN
|
|
|
650 LDY 4 ,S
|
|
|
651 LEAS 6 ,S
|
|
|
652 NEXT
|
|
|
653 END-CODE
|
|
|
654
|
|
|
655 CODE FILL ( addr n c ---)
|
|
|
656 LDX 4 ,S
|
|
|
657 LDD 2 ,S
|
|
|
658 0<> IF
|
|
|
659 INC 2 ,S
|
|
|
660 LDA 1 ,S
|
|
|
661 BEGIN
|
|
|
662 BEGIN
|
|
|
663 STA ,X+
|
|
|
664 DECB
|
|
|
665 0= UNTIL
|
|
|
666 DEC 2 ,S
|
|
|
667 0= UNTIL
|
|
|
668 THEN
|
|
|
669 LEAS 6 ,S
|
|
|
670 NEXT
|
|
|
671 END-CODE
|
|
|
672
|
|
|
673 CODE (FIND) ( word firstnfa --- cfa/word f )
|
|
|
674 LDX 0 ,S
|
|
|
675 0<> IF
|
|
|
676 STU 0 ,S
|
|
|
677 LDU 2 ,S
|
|
|
678 STY 2 ,S
|
|
|
679 PSHS U
|
|
|
680 BEGIN
|
|
|
681 TFR X, Y
|
|
|
682 LDA ,X+
|
|
|
683 ANDA # $1F
|
|
|
684 CMPA ,U+ \ Compare count bytes.
|
|
|
685 0= IF \ Do count bytes match?
|
|
|
686 BEGIN
|
|
|
687 DECA
|
|
|
688 LDB ,X+
|
|
|
689 CMPB ,U+
|
|
|
690 0<> UNTIL \ Compare strings until difference encountered.
|
|
|
691 INCA
|
|
|
692 0= IF
|
|
|
693 LEAS 2 ,S \ Yes, then word is found.
|
|
|
694 TFR Y, X
|
|
|
695 LDY 2 ,S
|
|
|
696 LDU 0 ,S
|
|
|
697 LDA 0 ,X
|
|
|
698 ANDA # $40
|
|
|
699 0= IF
|
|
|
700 LDD # -1
|
|
|
701 ELSE
|
|
|
702 LDD # 1 \ Make flag that indicates immediate bit.
|
|
|
703 THEN
|
|
|
704 STD 0 ,S
|
|
|
705 LDB ,X+
|
|
|
706 ANDB # $1F
|
|
|
707 ABX \ Compute CFA
|
|
|
708 STX 2 ,S
|
|
|
709 NEXT
|
|
|
710 THEN
|
|
|
711 THEN
|
|
|
712 LDU 0 ,S
|
|
|
713 LDX -2 ,Y \ Point to next word in linked list.
|
|
|
714 0= UNTIL
|
|
|
715 LEAS 2 ,S
|
|
|
716 LDY 2 ,S
|
|
|
717 STU 2 ,S
|
|
|
718 LDU 0 ,S
|
|
|
719 STX 0 ,S
|
|
|
720 THEN
|
|
|
721 NEXT
|
|
|
722 END-CODE
|
|
|
723
|
|
|
724 CODE SKIP ( addr1 len1 c --- addr2 len2 )
|
|
|
725 STU ,--Y
|
|
|
726 PULS D
|
|
|
727 PULS X
|
|
|
728 PULS U
|
|
|
729 LEAX 0 ,X
|
|
|
730 0<> IF
|
|
|
731 BEGIN
|
|
|
732 CMPB ,U+
|
|
|
733 0<> IF
|
|
|
734 LEAU -1 ,U
|
|
|
735 PSHS U
|
|
|
736 PSHS X
|
|
|
737 LDU ,Y++
|
|
|
738 NEXT
|
|
|
739 THEN
|
|
|
740 LEAX -1 ,X
|
|
|
741 0= UNTIL
|
|
|
742 THEN
|
|
|
743 PSHS U
|
|
|
744 PSHS X
|
|
|
745 LDU ,Y++
|
|
|
746 NEXT
|
|
|
747 END-CODE
|
|
|
748
|
|
|
749 CODE SCAN ( addr1 len1 c --- addr2 len2 )
|
|
|
750 STU ,--Y
|
|
|
751 PULS D
|
|
|
752 PULS X
|
|
|
753 PULS U
|
|
|
754 LEAX 0 ,X
|
|
|
755 0<> IF
|
|
|
756 BEGIN
|
|
|
757 CMPB ,U+
|
|
|
758 0= IF
|
|
|
759 LEAU -1 ,U
|
|
|
760 PSHS U
|
|
|
761 PSHS X
|
|
|
762 LDU ,Y++
|
|
|
763 NEXT
|
|
|
764 THEN
|
|
|
765 LEAX -1 ,X
|
|
|
766 0= UNTIL
|
|
|
767 THEN
|
|
|
768 PSHS U
|
|
|
769 PSHS X
|
|
|
770 LDU ,Y++
|
|
|
771 NEXT
|
|
|
772 END-CODE
|
|
|
773
|
|
|
774 CODE KEY ( --- c)
|
|
|
775 JSR 0
|
|
|
776 CLRA
|
|
184
|
777 PSHS D
|
|
57
|
778 NEXT
|
|
|
779 END-CODE
|
|
|
780
|
|
|
781 CODE EMIT ( c ---)
|
|
184
|
782 PULS D
|
|
57
|
783 JSR 3
|
|
|
784 NEXT
|
|
|
785 END-CODE
|
|
|
786
|
|
|
787 CODE KEY? ( --- f)
|
|
|
788 JSR 15
|
|
|
789 SEX
|
|
|
790 PSHS D
|
|
|
791 NEXT
|
|
|
792 END-CODE
|
|
|
793
|
|
|
794 CODE BYE
|
|
|
795 JMP $E400
|
|
|
796 NEXT
|
|
|
797 END-CODE
|
|
|
798
|
|
|
799 CODE CR
|
|
|
800 JSR 12
|
|
|
801 NEXT
|
|
|
802 END-CODE
|
|
|
803
|
|
|
804 CODE XOPENIN
|
|
|
805 JSR 18
|
|
|
806 NEXT
|
|
|
807 END-CODE
|
|
|
808
|
|
|
809 CODE XABORTIN
|
|
|
810 PSHS Y, U
|
|
|
811 JSR 24
|
|
|
812 PULS Y, U
|
|
|
813 NEXT
|
|
|
814 END-CODE
|
|
|
815
|
|
|
816 : NOOP ;
|
|
|
817
|
|
|
818 00 CONSTANT 0
|
|
|
819 01 CONSTANT 1
|
|
|
820 02 CONSTANT 2
|
|
|
821 -1 CONSTANT -1
|
|
|
822
|
|
|
823 \ PART 3: SIMPLE DEFINITIONS
|
|
|
824
|
|
|
825 \ This is a large class of words, which would be written in machine code
|
|
|
826 \ on most non-native code systems. Many contain just a few words, so they
|
|
|
827 \ are implemented as macros.
|
|
|
828
|
|
|
829 \ This category contains simple arithmetic and compare words, the runtime
|
|
|
830 \ parts of DO LOOP and string related words etc, many on which are
|
|
|
831 \ dependent on each other, so they are in a less than logical order to
|
|
|
832 \ avoid large numbers of forward references.
|
|
|
833
|
|
|
834 : = ( x1 x2 --- f)
|
|
|
835 \G f is true if and only if x1 is equal to x2.
|
|
|
836 - 0= ;
|
|
|
837
|
|
|
838 : <> ( x1 x2 --- f)
|
|
|
839 \G f is true if and only if x1 is not equal to x2.
|
|
|
840 = 0= ;
|
|
|
841
|
|
|
842 : > ( n1 n2 --- f)
|
|
|
843 \G f is true if and only if the signed number n1 is less than n2.
|
|
|
844 SWAP < ;
|
|
|
845
|
|
|
846 : 0> ( n --- f)
|
|
|
847 \G f is true if and only if n is greater than 0.
|
|
|
848 0 > ;
|
|
|
849
|
|
|
850 : U> ( u1 u2 --- f)
|
|
|
851 \G f is true if and only if the unsigned number u1 is greater than u2.
|
|
|
852 SWAP U< ;
|
|
|
853
|
|
|
854 VARIABLE S0 ( --- a-addr)
|
|
|
855 \G Variable that holds the bottom address of the stack.
|
|
|
856 -2 ALLOT-T
|
|
|
857 LABEL S0ADDR ENDASM
|
|
|
858 02 ALLOT-T
|
|
|
859
|
|
|
860 VARIABLE R0 ( --- a-addr)
|
|
|
861 \G Variable that holds the bottom address of the return stack.
|
|
|
862 -2 ALLOT-T
|
|
|
863 LABEL R0ADDR ENDASM
|
|
|
864 02 ALLOT-T
|
|
|
865
|
|
|
866 : DEPTH ( --- n )
|
|
|
867 \G n is the number of cells on the stack (before DEPTH was executed).
|
|
|
868 SP@ S0 @ SWAP - 2/ ;
|
|
|
869
|
|
|
870 : COUNT ( c-addr1 --- c-addr2 c)
|
|
|
871 \G c-addr2 is the next address after c-addr1 and c is the character
|
|
|
872 \G stored at c-addr1.
|
|
|
873 \G This word is intended to be used with 'counted strings' where the
|
|
|
874 \G first character indicates the length of the string.
|
|
|
875 DUP 1 + SWAP C@ ;
|
|
|
876
|
|
|
877 : TYPE ( c-addr1 u --- )
|
|
|
878 \G Output the string starting at c-addr and length u to the terminal.
|
|
|
879 DUP IF 0 DO DUP I + C@ EMIT LOOP DROP ELSE DROP DROP THEN ;
|
|
|
880
|
|
|
881 : ALIGNED ( c-addr --- a-addr )
|
|
|
882 \G a-addr is the first aligned address after c-addr.
|
|
|
883 ;
|
|
|
884
|
|
|
885 : (.") ( --- )
|
|
|
886 \G Runtime part of ."
|
|
|
887 \ This expects an in-line counted string.
|
|
|
888 R> COUNT OVER OVER TYPE + ALIGNED >R ;
|
|
|
889 : (S") ( --- c-addr u )
|
|
|
890 \G Runtime part of S"
|
|
|
891 \ It returns address and length of an in-line counted string.
|
|
|
892 R> COUNT OVER OVER + ALIGNED >R ;
|
|
|
893
|
|
|
894
|
|
|
895 00
|
|
|
896 CONSTANT FALSE ( --- 0)
|
|
|
897 \G Constant 0, indicates FALSE
|
|
|
898
|
|
|
899 -01
|
|
|
900 CONSTANT TRUE ( --- -1)
|
|
|
901 \G Constant -1, indicates TRUE
|
|
|
902
|
|
|
903 32
|
|
|
904 CONSTANT BL ( --- 32 )
|
|
|
905 \G Constant 32, the blank character
|
|
|
906
|
|
|
907 : OFF ( a-addr ---)
|
|
|
908 \G Store FALSE at a-addr.
|
|
|
909 0 SWAP ! ;
|
|
|
910
|
|
|
911 : ON ( a-addr ---)
|
|
|
912 \G Store TRUE at a-addr.
|
|
|
913 -1 SWAP ! ;
|
|
|
914
|
|
|
915 : INVERT ( x1 --- x2)
|
|
|
916 \G Invert all the bits of x1 (one's complement)
|
|
|
917 -1 XOR ;
|
|
|
918
|
|
|
919
|
|
|
920 \ The next few words manipulate addresses in a system-independent way.
|
|
|
921 \ Use CHAR+ instead of 1+ and it will be portable to systems where you
|
|
|
922 \ have to add something different from 1.
|
|
|
923
|
|
|
924 : CHAR+ ( c-addr1 --- c-addr2)
|
|
|
925 \G c-addr2 is the next character address after c-addr1.
|
|
|
926 1+ ;
|
|
|
927
|
|
|
928 : CHARS ( n1 --- n2)
|
|
|
929 \G n2 is the number of address units occupied by n1 characters.
|
|
|
930 ; \ A no-op.
|
|
|
931
|
|
|
932 : CHAR- ( c-addr1 --- c-addr2)
|
|
|
933 \G c-addr2 is the previous character address before c-addr1.
|
|
|
934 1- ;
|
|
|
935
|
|
|
936 : CELL+ ( a-addr1 --- a-addr2)
|
|
|
937 \G a-addr2 is the address of the next cell after a-addr2.
|
|
|
938 2+ ;
|
|
|
939
|
|
|
940 : CELLS ( n2 --- n1)
|
|
|
941 \G n2 is the number of address units occupied by n1 cells.
|
|
|
942 1 LSHIFT ;
|
|
|
943
|
|
|
944 : CELL- ( a-addr1 --- a-addr2)
|
|
|
945 \G a-addr2 is the address of the previous cell before a-addr1.
|
|
|
946 2- ;
|
|
|
947
|
|
|
948 : ?DUP ( n --- 0 | n n)
|
|
|
949 \G Duplicate the top cell on the stack, but only if it is nonzero.
|
|
|
950 DUP IF DUP THEN ;
|
|
|
951
|
|
|
952 : MIN ( n1 n2 --- n3)
|
|
|
953 \G n3 is the minimum of n1 and n2.
|
|
|
954 OVER OVER > IF SWAP THEN DROP ;
|
|
|
955
|
|
|
956 : MAX ( n1 n2 --- n3)
|
|
|
957 \G n3 is the maximum of n1 and n2.
|
|
|
958 OVER OVER < IF SWAP THEN DROP ;
|
|
|
959
|
|
|
960 : ABS ( n --- u)
|
|
|
961 \G u is the absolute value of n.
|
|
|
962 DUP 0< IF NEGATE THEN ;
|
|
|
963
|
|
|
964 : DABS ( d --- ud)
|
|
|
965 \G ud is the absolute value of d.
|
|
|
966 DUP 0< IF DNEGATE THEN ;
|
|
|
967
|
|
|
968 : SM/REM ( d n1 --- nrem nquot )
|
|
|
969 \G Divide signed double number d by single number n1, giving quotient and
|
|
|
970 \G remainder. Round towards zero, remainder has same sign as dividend.
|
|
|
971 2DUP XOR >R OVER >R \ Push signs of quot and rem.
|
|
|
972 ABS >R DABS R>
|
|
|
973 UM/MOD
|
|
|
974 SWAP R> 0< IF NEGATE THEN SWAP
|
|
|
975 R> 0< IF NEGATE THEN ;
|
|
|
976
|
|
|
977 : FM/MOD ( d n1 --- nrem nquot )
|
|
|
978 \G Divide signed double number d by single number n1, giving quotient and
|
|
|
979 \G remainder. Round always down (floored division),
|
|
|
980 \G remainder has same sign as divisor.
|
|
|
981 DUP >R OVER OVER XOR >R
|
|
|
982 SM/REM
|
|
|
983 OVER R> 0< AND IF SWAP R@ + SWAP 1 - THEN R> DROP ;
|
|
|
984
|
|
|
985 : M* ( n1 n2 --- d )
|
|
|
986 \G Multiply the signed numbers n1 and n2, giving the signed double number d.
|
|
|
987 2DUP XOR >R ABS SWAP ABS UM* R> 0< IF DNEGATE THEN ;
|
|
|
988
|
|
|
989 : * ( w1 w2 --- w3)
|
|
|
990 \G Multiply single numbers, signed or unsigned give the same result.
|
|
|
991 UM* DROP ;
|
|
|
992
|
|
|
993 : */MOD ( n1 n2 n3 --- nrem nquot)
|
|
|
994 \G Multiply signed numbers n1 by n2 and divide by n3, giving quotient and
|
|
|
995 \G remainder. Intermediate result is double.
|
|
|
996 >R M* R> FM/MOD ;
|
|
|
997
|
|
|
998 : */ ( n1 n2 n3 --- n4 )
|
|
|
999 \G Multiply signed numbers n1 by n2 and divide by n3, giving quotient n4.
|
|
|
1000 \G Intermediate result is double.
|
|
|
1001 */MOD SWAP DROP ;
|
|
|
1002
|
|
|
1003 : S>D ( n --- d)
|
|
|
1004 \G Convert single number to double number.
|
|
|
1005 DUP 0< ;
|
|
|
1006
|
|
|
1007 : /MOD ( n1 n2 --- nrem nquot)
|
|
|
1008 \G Divide signed number n1 by n2, giving quotient and remainder.
|
|
|
1009 SWAP S>D ROT FM/MOD ;
|
|
|
1010
|
|
|
1011 : / ( n1 n2 --- n3)
|
|
|
1012 \G n3 is n1 divided by n2.
|
|
|
1013 /MOD SWAP DROP ;
|
|
|
1014
|
|
|
1015 : MOD ( n1 n2 --- n3)
|
|
|
1016 \G n3 is the remainder of n1 and n2.
|
|
|
1017 /MOD DROP ;
|
|
|
1018
|
|
|
1019 : ?THROW ( f n --- )
|
|
|
1020 \G Perform n THROW if f is nonzero.
|
|
|
1021 SWAP IF THROW ELSE DROP THEN ;
|
|
|
1022
|
|
|
1023 \ PART 4: NUMERIC OUTPUT WORDS.
|
|
|
1024
|
|
|
1025 VARIABLE BASE ( --- a-addr)
|
|
|
1026 \G Variable that contains the numerical conversion base.
|
|
|
1027
|
|
|
1028 VARIABLE DP ( --- a-addr)
|
|
|
1029 \G Variable that contains the dictionary pointer. New space is allocated
|
|
|
1030 \G from the address in DP
|
|
|
1031
|
|
|
1032 VARIABLE HLD ( --- a-addr)
|
|
|
1033 \G Variable that holds the address of the numerical output conversion
|
|
|
1034 \G character.
|
|
|
1035
|
|
|
1036 VARIABLE DPL ( --- a-addr)
|
|
|
1037 \G Variable that holds the decimal point location for numerical conversion.
|
|
|
1038
|
|
|
1039 : DECIMAL ( --- )
|
|
|
1040 \G Set numerical conversion to decimal.
|
|
|
1041 10 BASE ! ;
|
|
|
1042
|
|
|
1043 : HEX ( --- )
|
|
|
1044 \G Set numerical conversion to hexadecimal.
|
|
|
1045 16 BASE ! ;
|
|
|
1046
|
|
|
1047 : SPACE ( ---)
|
|
|
1048 \G Output a space to the terminal.
|
|
|
1049 32 EMIT ;
|
|
|
1050
|
|
|
1051 : SPACES ( u --- )
|
|
|
1052 \G Output u spaces to the terminal.
|
|
|
1053 ?DUP IF 0 DO SPACE LOOP THEN ;
|
|
|
1054
|
|
|
1055 : HERE ( --- c-addr )
|
|
|
1056 \G The address of the dictionary pointer. New space is allocated here.
|
|
|
1057 DP @ ;
|
|
|
1058
|
|
|
1059 : PAD ( --- c-addr )
|
|
|
1060 \G The address of a scratch pad area. Right below this address there is
|
|
|
1061 \G the numerical conversion buffer.
|
|
|
1062 DP @ 84 + ;
|
|
|
1063
|
|
|
1064 : MU/MOD ( ud u --- urem udquot )
|
|
|
1065 \G Divide unsigned double number ud by u and return a double quotient and
|
|
|
1066 \G a single remainder.
|
|
|
1067 >R 0 R@ UM/MOD R> SWAP >R UM/MOD R> ;
|
|
|
1068
|
|
|
1069 \ The numerical conversion buffer starts right below PAD and grows down.
|
|
|
1070 \ Characters are added to it from right to left, as as the div/mod algorithm
|
|
|
1071 \ to convert numbers to an arbitrary base produces the digits from right to
|
|
|
1072 \ left.
|
|
|
1073
|
|
|
1074 : HOLD ( c ---)
|
|
|
1075 \G Insert character c into the numerical conversion buffer.
|
|
|
1076 1 NEGATE HLD +! HLD @ C! ;
|
|
|
1077
|
|
|
1078 : # ( ud1 --- ud2)
|
|
|
1079 \G Extract the rightmost digit of ud1 and put it into the numerical
|
|
|
1080 \G conversion buffer.
|
|
|
1081 BASE @ MU/MOD ROT DUP 9 > IF 7 + THEN 48 + HOLD ;
|
|
|
1082
|
|
|
1083 : #S ( ud --- 0 0 )
|
|
|
1084 \G Convert ud by repeated use of # until ud is zero.
|
|
|
1085 BEGIN # OVER OVER OR 0= UNTIL ;
|
|
|
1086
|
|
|
1087 : SIGN ( n ---)
|
|
|
1088 \G Insert a - sign in the numerical conversion buffer if n is negative.
|
|
|
1089 0< IF 45 HOLD THEN ;
|
|
|
1090
|
|
|
1091 : <# ( --- )
|
|
|
1092 \G Reset the numerical conversion buffer.
|
|
|
1093 PAD HLD ! ;
|
|
|
1094
|
|
|
1095 : #> ( ud --- addr u )
|
|
|
1096 \G Discard ud and give the address and length of the numerical conversion
|
|
|
1097 \G buffer.
|
|
|
1098 DROP DROP HLD @ PAD OVER - ;
|
|
|
1099
|
|
|
1100 : D. ( d --- )
|
|
|
1101 \G Type the double number d to the terminal.
|
|
|
1102 SWAP OVER DABS <# #S ROT SIGN #> TYPE SPACE ;
|
|
|
1103
|
|
|
1104 : U. ( u ---)
|
|
|
1105 \G Type the unsigned number u to the terminal.
|
|
|
1106 0 D. ;
|
|
|
1107
|
|
|
1108 : . ( n ---)
|
|
|
1109 \G Type the signed number n to the terminal.
|
|
|
1110 S>D D. ;
|
|
|
1111
|
|
|
1112 : MOVE ( c-addr1 c-addr2 u --- )
|
|
|
1113 \G Copy a block of u bytes starting at c-addr1 to c-addr2. Order is such
|
|
|
1114 \G that partially overlapping blocks are copied intact.
|
|
|
1115 >R OVER OVER U< IF R> CMOVE> ELSE R> CMOVE THEN ;
|
|
|
1116
|
|
|
1117
|
|
|
1118 CODE ACCEPT ( c-addr n1 --- n2 )
|
|
|
1119 \G Read a line from the terminal to a buffer starting at c-addr with
|
|
|
1120 \G length n1. n2 is the number of characters read,
|
|
|
1121 PULS X, D
|
|
|
1122 JSR 6
|
|
|
1123 CLRA
|
|
|
1124 PSHS D
|
|
|
1125 NEXT
|
|
|
1126 END-CODE
|
|
|
1127
|
|
|
1128
|
|
|
1129 $200 CONSTANT TIB ( --- addr)
|
|
|
1130 \G is the standard terminal input buffer.
|
|
|
1131
|
|
|
1132 VARIABLE SPAN ( --- addr)
|
|
|
1133 \G This variable holds the number of characters read by EXPECT.
|
|
|
1134
|
|
|
1135 VARIABLE #TIB ( --- addr)
|
|
|
1136 \G This variable holds the number of characters in the terminal input buffer.
|
|
|
1137
|
|
|
1138 VARIABLE >IN ( --- addr)
|
|
|
1139 \G This variable holds an index in the current input source where the next word
|
|
|
1140 \G will be parsed.
|
|
|
1141
|
|
|
1142 VARIABLE SID ( --- addr)
|
|
|
1143 \G This variable holds the source i.d. returned by SOURCE-ID.
|
|
|
1144
|
|
|
1145 VARIABLE SRC ( --- addr)
|
|
|
1146 \G This variable holds the address of the current input source.
|
|
|
1147
|
|
|
1148 VARIABLE #SRC ( --- addr)
|
|
|
1149 \G This variable holds the length of the current input source.
|
|
|
1150
|
|
|
1151 VARIABLE LOADLINE ( --- addr)
|
|
|
1152 \G This variable holds the line number in the file being included.
|
|
|
1153
|
|
|
1154
|
|
|
1155 : EXPECT ( c-addr u --- )
|
|
|
1156 \G Read a line from the terminal to a buffer at c-addr with length u.
|
|
|
1157 \G Store the length of the line in SPAN.
|
|
|
1158 ACCEPT SPAN ! ;
|
|
|
1159
|
|
|
1160 : QUERY ( --- )
|
|
|
1161 \G Read a line from the terminal into the terminal input buffer.
|
|
|
1162 TIB 128 ACCEPT #TIB ! ;
|
|
|
1163
|
|
|
1164 : SOURCE ( --- addr len)
|
|
|
1165 \G Return the address and length of the current input source.
|
|
|
1166 SRC @ #SRC @ ;
|
|
|
1167
|
|
|
1168 : SOURCE-ID ( --- sid)
|
|
|
1169 \G Return the i.d. of the current source i.d., 0 for terminal, -1
|
|
|
1170 \G for EVALUATE and positive number for INCLUDE file.
|
|
|
1171 SID @ ;
|
|
|
1172
|
|
|
1173 : REFILL ( --- f)
|
|
|
1174 \G Refill the current input source when it is exhausted. f is
|
|
|
1175 \G true if it was successfully refilled.
|
|
|
1176 SOURCE-ID -1 = IF
|
|
|
1177 0 \ Not refillable for EVALUATE
|
|
|
1178 ELSE
|
|
|
1179 QUERY #TIB @ #SRC ! 0 >IN ! -1 \ Always successful from terminal.
|
|
|
1180 1 LOADLINE +!
|
|
|
1181 THEN
|
|
|
1182 ;
|
|
|
1183
|
|
|
1184 : PARSE ( c --- addr len )
|
|
|
1185 \G Find a character sequence in the current source that is delimited by
|
|
|
1186 \G character c. Adjust >IN to 1 past the end delimiter character.
|
|
|
1187 >R SOURCE >IN @ - SWAP >IN @ + R> OVER >R >R SWAP
|
|
|
1188 R@ SKIP OVER R> SWAP >R SCAN IF 1 >IN +! THEN
|
|
|
1189 DUP R@ - R> SWAP
|
|
|
1190 ROT R> - >IN +! ;
|
|
|
1191
|
|
|
1192 : PLACE ( addr len c-addr --- )
|
|
|
1193 \G Place the string starting at addr with length len at c-addr as
|
|
|
1194 \G a counted string.
|
|
|
1195 OVER OVER C!
|
|
|
1196 1+ SWAP CMOVE ;
|
|
|
1197
|
|
|
1198 : WORD ( c --- addr )
|
|
|
1199 \G Parse a character sequence delimited by character c and return the
|
|
|
1200 \G address of a counted string that is a copy of it. The counted
|
|
|
1201 \G string is actually placed at HERE. The character after the counted
|
|
|
1202 \G string is set to a space.
|
|
|
1203 PARSE HERE PLACE HERE BL HERE COUNT + C! ;
|
|
|
1204
|
|
|
1205 VARIABLE CAPS ( --- a-addr)
|
|
|
1206 \G This variable contains a nonzero number if input is case insensitive.
|
|
|
1207
|
|
|
1208 : UPPERCASE? ( --- )
|
|
|
1209 \G Convert the parsed word to uppercase is CAPS is true.
|
|
|
1210 CAPS @ HERE C@ AND IF
|
|
|
1211 HERE COUNT 0 DO
|
|
|
1212 DUP I + C@ DUP 96 > SWAP 123 < AND IF DUP I + DUP C@ 32 - SWAP C! THEN
|
|
|
1213 LOOP DROP
|
|
|
1214 THEN
|
|
|
1215 ;
|
|
|
1216
|
|
|
1217
|
|
|
1218 \ PART 8: INTERPRETER HELPER WORDS
|
|
|
1219
|
|
|
1220 \ First we need FIND and related words.
|
|
|
1221
|
|
|
1222 \ Each word list consists of a number of linked list of definitions (number
|
|
|
1223 \ is a power of 2). Hashing
|
|
|
1224 \ is used to speed up dictionary search. All names in the dictionary
|
|
|
1225 \ are at aligned addresses and FIND is optimized to compare one 4-byte
|
|
|
1226 \ cell at a time.
|
|
|
1227
|
|
|
1228 \ Dictionary definitions are built as follows:
|
|
|
1229 \
|
|
|
1230 \ LINK field: 1 cell, aligned, contains name field of previous word in thread.
|
|
|
1231 \ NAME field: counted string of at most 31 characters.
|
|
|
1232 \ bits 5-7 of length byte have special meaning.
|
|
|
1233 \ 7 is always set to mark start of name ( for >NAME)
|
|
|
1234 \ 6 is set if the word is immediate.
|
|
|
1235 \ CODE field: first aligned address after name, is execution token for word.
|
|
|
1236 \ here the executable code for the word starts. (is 3 bytes for
|
|
|
1237 \ variables etc.)
|
|
|
1238 \ PARAMETER field: (body) Contains the data of constants and variables etc.
|
|
|
1239
|
|
|
1240 VARIABLE NAMEBUF ( --- a-addr)
|
|
|
1241 \G An aligned buffer that holds a copy of the name that is searched.
|
|
|
1242 30 ALLOT-T
|
|
|
1243
|
|
|
1244 VARIABLE FORTH-WORDLIST ( --- addr)
|
|
|
1245 4 CELLS-T ALLOT-T
|
|
|
1246 \G This array holds pointers to the last definition of each thread in the Forth
|
|
|
1247 \G word list.
|
|
|
1248
|
|
|
1249 VARIABLE LAST ( --- addr)
|
|
|
1250 \G This variable holds a pointer to the last definition created.
|
|
|
1251
|
|
|
1252 VARIABLE CONTEXT 28 ALLOT-T ( --- a-addr)
|
|
|
1253 \G This variable holds the addresses of up to 8 word lists that are
|
|
|
1254 \G in the search order.
|
|
|
1255
|
|
|
1256 VARIABLE #ORDER ( --- addr)
|
|
|
1257 \G This variable holds the number of word list that are in the search order.
|
|
|
1258
|
|
|
1259 VARIABLE CURRENT ( --- addr)
|
|
|
1260 \G This variable holds the address of the word list to which new definitions
|
|
|
1261 \G are added.
|
|
|
1262
|
|
|
1263 : HASH ( c-addr u #threads --- n)
|
|
|
1264 \G Compute the hash function for the name c-addr u with the indicated number
|
|
|
1265 \G of threads.
|
|
|
1266 >R OVER C@ 1 LSHIFT OVER 1 > IF ROT CHAR+ C@ 2 LSHIFT XOR ELSE ROT DROP
|
|
|
1267 THEN XOR
|
|
|
1268 R> 1- AND
|
|
|
1269 ;
|
|
|
1270
|
|
|
1271 : NAME>BUF ( c-addr u ---)
|
|
|
1272 \G Move the name c-addr u to the aligned buffer NAMEBUF.
|
|
|
1273 NAMEBUF 32 0 FILL 32 MIN NAMEBUF PLACE ;
|
|
|
1274
|
|
|
1275
|
|
|
1276 : SEARCH-WORDLIST ( c-addr u wid --- 0 | xt 1 xt -1)
|
|
|
1277 \G Search the wordlist with address wid for the name c-addr u.
|
|
|
1278 \G Return 0 if not found, the execution token xt and -1 for non-immediate
|
|
|
1279 \G words and xt and 1 for immediate words.
|
|
|
1280 ROT ROT
|
|
|
1281 NAME>BUF
|
|
|
1282 NAMEBUF COUNT 2 PICK @ HASH 1+ CELLS SWAP + @ \ Get the right thread.
|
|
|
1283 DUP IF
|
|
|
1284 NAMEBUF SWAP (FIND) DUP 0= IF DROP DROP 0 THEN EXIT
|
|
|
1285 THEN
|
|
|
1286 DROP 0 \ Not found.
|
|
|
1287 ;
|
|
|
1288
|
|
|
1289 : FIND ( c-addr --- c-addr 0| xt 1|xt -1 )
|
|
|
1290 \G Search all word lists in the search order for the name in the
|
|
|
1291 \G counted string at c-addr. If not found return the name address and 0.
|
|
|
1292 \G If found return the execution token xt and -1 if the word is non-immediate
|
|
|
1293 \G and 1 if the word is immediate.
|
|
|
1294 #ORDER @ DUP 1 > IF
|
|
|
1295 CONTEXT #ORDER @ 1- CELLS + DUP @ SWAP CELL- @ =
|
|
|
1296 ELSE 0 THEN
|
|
|
1297 IF 1- THEN \ If last wordlist is double, don't search it twice.
|
|
|
1298 BEGIN
|
|
|
1299 DUP
|
|
|
1300 WHILE
|
|
|
1301 1- >R
|
|
|
1302 DUP COUNT
|
|
|
1303 R@ CELLS CONTEXT + @ SEARCH-WORDLIST
|
|
|
1304 DUP
|
|
|
1305 IF
|
|
|
1306 R> DROP ROT DROP EXIT \ Exit if found.
|
|
|
1307 THEN
|
|
|
1308 DROP R>
|
|
|
1309 REPEAT
|
|
|
1310 ;
|
|
|
1311
|
|
|
1312 \ The following words are related to numeric input.
|
|
|
1313
|
|
|
1314 : DIGIT? ( c -- 0| c--- n -1)
|
|
|
1315 \G Convert character c to its digit value n and return true if c is a
|
|
|
1316 \G digit in the current base. Otherwise return false.
|
|
|
1317 48 - DUP 0< IF DROP 0 EXIT THEN
|
|
|
1318 DUP 9 > OVER 17 < AND IF DROP 0 EXIT THEN
|
|
|
1319 DUP 9 > IF 7 - THEN
|
|
|
1320 DUP BASE @ < 0= IF DROP 0 EXIT THEN
|
|
|
1321 -1
|
|
|
1322 ;
|
|
|
1323
|
|
|
1324 : >NUMBER ( ud1 c-addr1 u1 --- ud2 c-addr2 u2 )
|
|
|
1325 \G Convert the string at c-addr with length u1 to binary, multiplying ud1
|
|
|
1326 \G by the number in BASE and adding the digit value to it for each digit.
|
|
|
1327 \G c-addr2 u2 is the remainder of the string starting at the first character
|
|
|
1328 \G that is no digit.
|
|
|
1329 BEGIN
|
|
|
1330 DUP
|
|
|
1331 WHILE
|
|
|
1332 1 - >R
|
|
|
1333 COUNT DIGIT? 0=
|
|
|
1334 IF
|
|
|
1335 R> 1+ SWAP 1 - SWAP EXIT
|
|
|
1336 THEN
|
|
|
1337 SWAP >R
|
|
|
1338 >R
|
|
|
1339 SWAP BASE @ UM* ROT BASE @ * 0 SWAP D+ \ Multiply ud by base.
|
|
|
1340 R> 0 D+ \ Add new digit.
|
|
|
1341 R> R>
|
|
|
1342 REPEAT
|
|
|
1343 ;
|
|
|
1344
|
|
|
1345 : CONVERT ( ud1 c-addr1 --- ud2 c-addr2)
|
|
|
1346 \G Convert the string starting at c-addr1 + 1 to binary. c-addr2 is the
|
|
|
1347 \G address of the first non-digit. Digits are added into ud1 as in >NUMBER
|
|
|
1348 1 - -1 >NUMBER DROP ;
|
|
|
1349
|
|
|
1350 : NUMBER? ( c-addr ---- d f)
|
|
|
1351 \G Convert the counted string at c-addr to a double binary number.
|
|
|
1352 \G f is true if and only if the conversion was successful. DPL contains
|
|
|
1353 \G -1 if there was no point in the number, else the position of the point
|
|
|
1354 \G from the right. Special prefixes: # means decimal, $ means hex.
|
|
|
1355 -1 DPL !
|
|
|
1356 BASE @ >R
|
|
|
1357 COUNT
|
|
|
1358 OVER C@ 45 = DUP >R IF 1 - SWAP 1 + SWAP THEN \ Get any - sign
|
|
|
1359 OVER C@ 36 = IF 16 BASE ! 1 - SWAP 1 + SWAP THEN \ $ sign for hex.
|
|
|
1360 OVER C@ 35 = IF 10 BASE ! 1 - SWAP 1 + SWAP THEN \ # sign for decimal
|
|
|
1361 DUP 0 > 0= IF R> DROP R> BASE ! 0 EXIT THEN \ Length 0 or less?
|
|
|
1362 >R >R 0 0 R> R>
|
|
|
1363 BEGIN
|
|
|
1364 >NUMBER
|
|
|
1365 DUP IF OVER C@ 46 = IF 1 - DUP DPL ! SWAP 1 + SWAP ELSE \ handle point.
|
|
|
1366 R> DROP R> BASE ! 0 EXIT THEN \ Error if anything but point
|
|
|
1367 THEN
|
|
|
1368 DUP 0= UNTIL DROP DROP R> IF DNEGATE THEN
|
|
|
1369 R> BASE ! -1
|
|
|
1370 ;
|
|
|
1371
|
|
|
1372 \ PART 9: THE COMPILER
|
|
|
1373
|
|
|
1374 VARIABLE ERROR$ ( --- a-addr )
|
|
|
1375 \G Variable containing string address of ABORT" message.
|
|
|
1376
|
|
|
1377 VARIABLE HANDLER ( --- a-addr )
|
|
|
1378 \G Variable containing return stack address where THROW should return.
|
|
|
1379
|
|
|
1380 : (ABORT") ( f -- - )
|
|
|
1381 \G Runtime part of ABORT"
|
|
|
1382 IF R> ERROR$ ! -2 THROW
|
|
|
1383 ELSE R> COUNT + ALIGNED >R THEN ;
|
|
|
1384
|
|
|
1385 : THROW ( n --- )
|
|
|
1386 \G If n is nonzero, cause the corresponding CATCH to return with n.
|
|
|
1387 DUP IF
|
|
|
1388 HANDLER @ IF
|
|
|
1389 HANDLER @ RP!
|
|
|
1390 RP@ 4 + @ HANDLER ! \ point to previous exception frame.
|
|
|
1391 R> \ get old stack pointer.
|
|
|
1392 SWAP >R SP! DROP R> \ save throw code temp. on ret. stack set old sp.
|
|
|
1393 R> DROP \ remove address of handler.
|
|
|
1394 \ return stack points to return address of CATCH.
|
|
|
1395 ELSE
|
|
|
1396 WARM \ Warm start if no exception frame on stack.
|
|
|
1397 THEN
|
|
|
1398 ELSE
|
|
|
1399 DROP \ continue if zero.
|
|
|
1400 THEN
|
|
|
1401 ;
|
|
|
1402
|
|
|
1403 : CATCH ( xt --- n )
|
|
|
1404 \G Execute the word with execution token xt. If it returns normally, return
|
|
|
1405 \G 0. If it executes a THROW, return the throw parameter.
|
|
|
1406 HANDLER @ >R \ push handler on ret stack.
|
|
|
1407 SP@ >R \ push stack pointer on ret stack,
|
|
|
1408 RP@ HANDLER !
|
|
|
1409 EXECUTE
|
|
|
1410 RP@ 4 + @ HANDLER ! \ set handler to previous exception frame.
|
|
|
1411 R> DROP R> DROP \ remove exception frame.
|
|
|
1412 0 \ return 0
|
|
|
1413 ;
|
|
|
1414
|
|
|
1415 : ALLOT ( n --- )
|
|
|
1416 \G Allot n extra bytes of memory, starting at HERE to the dictionary.
|
|
|
1417 DP +! ;
|
|
|
1418
|
|
|
1419 : , ( x --- )
|
|
|
1420 \G Append cell x to the dictionary at HERE.
|
|
|
1421 HERE ! 1 CELLS ALLOT ;
|
|
|
1422
|
|
|
1423 : C, ( n --- )
|
|
|
1424 \G Append character c to the dictionary at HERE.
|
|
|
1425 HERE C! 1 ALLOT ;
|
|
|
1426
|
|
|
1427 : ALIGN ( --- )
|
|
|
1428 \G Add as many bytes to the dictionary as needed to align dictionary pointer.
|
|
|
1429 ;
|
|
|
1430
|
|
|
1431 : >NAME ( addr1 --- addr2 )
|
|
|
1432 \G Convert execution token addr1 (address of code) to address of name.
|
|
|
1433 BEGIN 1- DUP C@ 128 AND UNTIL ;
|
|
|
1434
|
|
|
1435 : NAME> ( addr1 --- addr2 )
|
|
|
1436 \G Convert address of name to address of code.
|
|
|
1437 COUNT 31 AND + ALIGNED ;
|
|
|
1438
|
|
|
1439 : HEADER ( --- )
|
|
|
1440 \G Create a header for a new definition without a code field.
|
|
|
1441 ALIGN 0 , \ Create link field.
|
|
|
1442 HERE LAST ! \ Set LAST so definition can be linked by REVEAL
|
|
|
1443 32 WORD UPPERCASE?
|
|
|
1444 DUP FIND IF ." Redefining: " HERE COUNT TYPE CR THEN DROP
|
|
|
1445 \ Give warning if existing word redefined.
|
|
|
1446 DUP COUNT CURRENT @ @ HASH 1+ CELLS CURRENT @ + @ HERE CELL- !
|
|
|
1447 \ Set link field to point to the right thread
|
|
|
1448 C@ 1+ HERE C@ 128 + HERE C! ALLOT ALIGN
|
|
|
1449 \ Allot the name and set bit 7 in length byte.
|
|
|
1450 ;
|
|
|
1451
|
|
|
1452 : JSR, $BD C, ;
|
|
|
1453
|
|
|
1454 : REVEAL ( --- )
|
|
|
1455 \G Add the last created definition to the CURRENT wordlist.
|
|
|
1456 LAST @ DUP COUNT 31 AND \ Get address and length of name
|
|
|
1457 CURRENT @ @ HASH \ compute hash code.
|
|
|
1458 1+ CELLS CURRENT @ + ! ;
|
|
|
1459
|
|
|
1460 : CREATE ( "ccc" --- )
|
|
|
1461 \G Create a definition that returns its parameter field address when
|
|
|
1462 \G executed. Storage can be added to it with ALLOT.
|
|
|
1463 HEADER REVEAL JSR, LIT DOVAR , ;
|
|
|
1464
|
|
|
1465 : VARIABLE ( "ccc" --- )
|
|
|
1466 \G Create a variable where 1 cell can be stored. When executed it
|
|
|
1467 \G returns the address.
|
|
|
1468 CREATE 0 , ;
|
|
|
1469
|
|
|
1470 : CONSTANT ( x "ccc" ---)
|
|
|
1471 \G Create a definition that returns x when executed.
|
|
|
1472 \ Definition contains lit & return in its code field.
|
|
|
1473 HEADER REVEAL JSR, LIT DOCON , , ;
|
|
|
1474
|
|
|
1475
|
|
|
1476 VARIABLE STATE ( --- a-addr)
|
|
|
1477 \G Variable that holds the compiler state, 0 is interpreting 1 is compiling.
|
|
|
1478
|
|
|
1479 : ] ( --- )
|
|
|
1480 \G Start compilation mode.
|
|
|
1481 1 STATE ! ;
|
|
|
1482
|
|
|
1483 : [ ( --- )
|
|
|
1484 \G Leave compilation mode.
|
|
|
1485 0 STATE ! ; IMMEDIATE
|
|
|
1486
|
|
|
1487 : LITERAL ( n --- )
|
|
|
1488 \G Add a literal to the current definition.
|
|
|
1489 POSTPONE LIT , ; IMMEDIATE
|
|
|
1490
|
|
|
1491 : COMPILE, ( xt --- )
|
|
|
1492 \G Add the execution semantics of the definition xt to the current definition.
|
|
|
1493 ,
|
|
|
1494 ;
|
|
|
1495
|
|
|
1496 VARIABLE CSP ( --- a-addr )
|
|
|
1497 \G This variable is used for stack checking between : and ;
|
|
|
1498
|
|
|
1499 VARIABLE 'LEAVE ( --- a-addr)
|
|
|
1500 \ This variable is used for LEAVE address resolution.
|
|
|
1501
|
|
|
1502 : !CSP ( --- )
|
|
|
1503 \G Store current stack pointer in CSP.
|
|
|
1504 SP@ CSP ! ;
|
|
|
1505
|
|
|
1506 : ?CSP ( --- )
|
|
|
1507 \G Check that stack pointer is equal to value contained in CSP.
|
|
|
1508 SP@ CSP @ - -22 ?THROW ;
|
|
|
1509
|
|
|
1510 : ; ( --- )
|
|
|
1511 \G Finish the current definition by adding a return to it, make it
|
|
|
1512 \G visible and leave compilation mode.
|
|
|
1513 POSTPONE UNNEST [
|
|
|
1514 ?CSP REVEAL
|
|
|
1515 ; IMMEDIATE
|
|
|
1516
|
|
|
1517 : (POSTPONE) ( --- )
|
|
|
1518 \G Runtime for POSTPONE.
|
|
|
1519 \ has inline argument.
|
|
|
1520 R> DUP @ SWAP CELL+ >R
|
|
|
1521 DUP >NAME C@ 64 AND IF EXECUTE ELSE COMPILE, THEN
|
|
|
1522 ;
|
|
|
1523
|
|
|
1524 : : ( "ccc" --- )
|
|
|
1525 \G Start a new definition, enter compilation mode.
|
|
|
1526 !CSP HEADER JSR, LIT DOCOL , ] ;
|
|
|
1527
|
|
|
1528 : BEGIN ( --- x )
|
|
|
1529 \G Start a BEGIN UNTIL or BEGIN WHILE REPEAT loop.
|
|
|
1530 HERE ; IMMEDIATE
|
|
|
1531
|
|
|
1532 : UNTIL ( x --- )
|
|
|
1533 \G Form a loop with matching BEGIN.
|
|
|
1534 \G Runtime: A flag is take from the stack
|
|
|
1535 \G each time UNTIL is encountered and the loop iterates until it is nonzero.
|
|
|
1536 POSTPONE ?BRANCH , ; IMMEDIATE
|
|
|
1537
|
|
|
1538 : IF ( --- x)
|
|
|
1539 \G Start an IF THEN or IF ELSE THEN construction.
|
|
|
1540 \G Runtime: At IF a flag is taken from
|
|
|
1541 \G the stack and if it is true the part between IF and ELSE is executed,
|
|
|
1542 \G otherwise the part between ELSE and THEN. If there is no ELSE, the part
|
|
|
1543 \G between IF and THEN is executed only if flag is true.
|
|
|
1544 POSTPONE ?BRANCH HERE 1 CELLS ALLOT ; IMMEDIATE
|
|
|
1545
|
|
|
1546 : THEN ( x ---)
|
|
|
1547 \G End an IF THEN or IF ELSE THEN construction.
|
|
|
1548 HERE SWAP ! ; IMMEDIATE
|
|
|
1549
|
|
|
1550 : ELSE ( x1 --- x2)
|
|
|
1551 \G part of IF ELSE THEN construction.
|
|
|
1552 POSTPONE BRANCH HERE 1 CELLS ALLOT SWAP POSTPONE THEN ; IMMEDIATE
|
|
|
1553
|
|
|
1554 : WHILE ( x1 --- x2 x1 )
|
|
|
1555 \G part of BEGIN WHILE REPEAT construction.
|
|
|
1556 \G Runtime: At WHILE a flag is taken from the stack. If it is false,
|
|
|
1557 \G the program jumps out of the loop, otherwise the part between WHILE
|
|
|
1558 \G and REPEAT is executed and the loop iterates to BEGIN.
|
|
|
1559 POSTPONE IF SWAP ; IMMEDIATE
|
|
|
1560
|
|
|
1561 : REPEAT ( x1 x2 --- )
|
|
|
1562 \G part of BEGIN WHILE REPEAT construction.
|
|
|
1563 POSTPONE BRANCH , POSTPONE THEN ; IMMEDIATE
|
|
|
1564
|
|
|
1565 VARIABLE POCKET ( --- a-addr )
|
|
|
1566 \G Buffer for S" strings that are interpreted.
|
|
|
1567 252 ALLOT-T
|
|
|
1568
|
|
|
1569 : ' ( "ccc" --- xt)
|
|
|
1570 \G Find the word with name ccc and return its execution token.
|
|
|
1571 32 WORD UPPERCASE? FIND 0= -13 ?THROW ;
|
|
|
1572
|
|
|
1573 : ['] ( "ccc" ---)
|
|
|
1574 \G Copile the execution token of the word with name ccc as a literal.
|
|
|
1575 ' LITERAL ; IMMEDIATE
|
|
|
1576
|
|
|
1577 : CHAR ( "ccc" --- c)
|
|
|
1578 \G Return the first character of "ccc".
|
|
|
1579 BL WORD 1 + C@ ;
|
|
|
1580
|
|
|
1581 : [CHAR] ( "ccc" --- )
|
|
|
1582 \G Compile the first character of "ccc" as a literal.
|
|
|
1583 CHAR LITERAL ; IMMEDIATE
|
|
|
1584
|
|
|
1585 : DO ( --- x)
|
|
|
1586 \G Start a DO LOOP.
|
|
|
1587 \G Runtime: ( n1 n2 --- ) start a loop with initial count n2 and
|
|
|
1588 \G limit n1.
|
|
|
1589 POSTPONE (DO) 'LEAVE @ HERE 0 'LEAVE ! ; IMMEDIATE
|
|
|
1590
|
|
|
1591 : ?DO ( --- x )
|
|
|
1592 \G Start a ?DO LOOP.
|
|
|
1593 \G Runtime: ( n1 n2 --- ) start a loop with initial count n2 and
|
|
|
1594 \G limit n1. Exit immediately if n1 = n2.
|
|
|
1595 POSTPONE (?DO) 'LEAVE @ HERE 'LEAVE ! 0 , HERE ; IMMEDIATE
|
|
|
1596
|
|
|
1597 : LEAVE ( --- )
|
|
|
1598 \G Runtime: leave the matching DO LOOP immediately.
|
|
|
1599 \ All places where a leave address for the loop is needed are in a linked
|
|
|
1600 \ list, starting with 'LEAVE variable, the other links in the cells where
|
|
|
1601 \ the leave addresses will come.
|
|
|
1602 POSTPONE (LEAVE) HERE 'LEAVE @ , 'LEAVE ! ; IMMEDIATE
|
|
|
1603
|
|
|
1604 : RESOLVE-LEAVE
|
|
|
1605 \G Resolve the references to the leave addresses of the loop.
|
|
|
1606 'LEAVE @
|
|
|
1607 BEGIN DUP WHILE DUP @ HERE ROT ! REPEAT DROP ;
|
|
|
1608
|
|
|
1609 : LOOP ( x --- )
|
|
|
1610 \G End a DO LOOP.
|
|
|
1611 \G Runtime: Add 1 to the count and if it is equal to the limit leave the loop.
|
|
|
1612 POSTPONE (LOOP) , RESOLVE-LEAVE 'LEAVE ! ; IMMEDIATE
|
|
|
1613
|
|
|
1614 : +LOOP ( x --- )
|
|
|
1615 \G End a DO +LOOP
|
|
|
1616 \G Runtime: ( n ---) Add n to the count and exit if this crosses the
|
|
|
1617 \G boundary between limit-1 and limit.
|
|
|
1618 POSTPONE (+LOOP) , RESOLVE-LEAVE 'LEAVE ! ; IMMEDIATE
|
|
|
1619
|
|
|
1620 : RECURSE ( --- )
|
|
|
1621 \G Compile a call to the current (not yet finished) definition.
|
|
|
1622 LAST @ NAME> COMPILE, ; IMMEDIATE
|
|
|
1623
|
|
|
1624 : ." ( "ccc<quote>" --- )
|
|
|
1625 \G Parse a string delimited by " and compile the following runtime semantics.
|
|
|
1626 \G Runtime: type that string.
|
|
|
1627 POSTPONE (.") 34 WORD C@ 1+ ALLOT ALIGN ; IMMEDIATE
|
|
|
1628
|
|
|
1629
|
|
|
1630 : S" ( "ccc<quote>" --- )
|
|
|
1631 \G Parse a string delimited by " and compile the following runtime semantics.
|
|
|
1632 \G Runtime: ( --- c-addr u) Return start address and length of that string.
|
|
|
1633 STATE @ IF POSTPONE (S") 34 WORD C@ 1+ ALLOT ALIGN
|
|
|
1634 ELSE 34 WORD COUNT POCKET PLACE POCKET COUNT THEN ; IMMEDIATE
|
|
|
1635
|
|
|
1636 : ABORT" ( "ccc<quote>" --- )
|
|
|
1637 \G Parse a string delimited by " and compile the following runtime semantics.
|
|
|
1638 \G Runtime: ( f --- ) if f is nonzero, print the string and abort program.
|
|
|
1639 POSTPONE (ABORT") 34 WORD C@ 1+ ALLOT ALIGN ; IMMEDIATE
|
|
|
1640
|
|
|
1641 : ABORT ( --- )
|
|
|
1642 \G Abort unconditionally without a message.
|
|
|
1643 -1 THROW ;
|
|
|
1644
|
|
|
1645 : POSTPONE ( "ccc" --- )
|
|
|
1646 \G Parse the next word delimited by spaces and compile the following runtime.
|
|
|
1647 \G Runtime: depending on immediateness EXECUTE or compile the execution
|
|
|
1648 \G semantics of the parsed word.
|
|
|
1649 POSTPONE (POSTPONE) ' , ; IMMEDIATE
|
|
|
1650
|
|
|
1651 : IMMEDIATE ( --- )
|
|
|
1652 \G Make last definition immediate, so that it will be executed even in
|
|
|
1653 \G compilation mode.
|
|
|
1654 LAST @ DUP C@ 64 OR SWAP C! ;
|
|
|
1655
|
|
|
1656 : ( ( "ccc<rparen>" --- )
|
|
|
1657 \G Comment till next ).
|
|
|
1658 41 PARSE DROP DROP ; IMMEDIATE
|
|
|
1659
|
|
|
1660 : \
|
|
|
1661 \G Comment till end of line.
|
|
|
1662 SOURCE >IN ! DROP ; IMMEDIATE
|
|
|
1663
|
|
|
1664 : >BODY ( xt --- a-addr)
|
|
|
1665 \G Convert execution token to parameter field address.
|
|
|
1666 3 + ;
|
|
|
1667
|
|
|
1668 : (;CODE) ( --- )
|
|
|
1669 \G Runtime for DOES>, exit calling definition and make last defined word
|
|
|
1670 \G execute the calling definition after (;CODE)
|
|
|
1671 R> LAST @ NAME> 1+ ! ;
|
|
|
1672
|
|
|
1673 : DOES> ( --- )
|
|
|
1674 \G Word that contains DOES> will change the behavior of the last created
|
|
|
1675 \G word such that it pushes its parameter field address onto the stack
|
|
|
1676 \G and then executes whatever comes after DOES>
|
|
|
1677 POSTPONE (;CODE)
|
|
|
1678 JSR, LIT DOCOL ,
|
|
|
1679 ; IMMEDIATE
|
|
|
1680
|
|
|
1681 \ PART 10: TOP LEVEL OF INTERPRETER
|
|
|
1682
|
|
|
1683 : ?STACK ( ---)
|
|
|
1684 \G Check for stack over/underflow and abort with an error if needed.
|
|
|
1685 DEPTH DUP 0< -4 ?THROW 10000 > -3 ?THROW ;
|
|
|
1686
|
|
|
1687 : INTERPRET ( ---)
|
|
|
1688 \G Interpret words from the current source until the input source is exhausted.
|
|
|
1689 BEGIN
|
|
|
1690 32 WORD UPPERCASE? DUP C@
|
|
|
1691 WHILE
|
|
|
1692 FIND DUP
|
|
|
1693 IF
|
|
|
1694 -1 = STATE @ AND
|
|
|
1695 IF
|
|
|
1696 COMPILE,
|
|
|
1697 ELSE
|
|
|
1698 EXECUTE
|
|
|
1699 THEN
|
|
|
1700 ELSE DROP
|
|
|
1701 NUMBER? 0= -13 ?THROW
|
|
|
1702 DPL @ 1+ IF
|
|
|
1703 STATE @ IF SWAP LITERAL LITERAL THEN
|
|
|
1704 ELSE
|
|
|
1705 DROP STATE @ IF LITERAL THEN
|
|
|
1706 THEN
|
|
|
1707 THEN ?STACK
|
|
|
1708 REPEAT DROP
|
|
|
1709 ;
|
|
|
1710
|
|
|
1711 : EVALUATE ( c-addr u --- )
|
|
|
1712 \G Evaluate the string c-addr u as if it were typed on the terminal.
|
|
|
1713 SID @ >R SRC @ >R #SRC @ >R >IN @ >R
|
|
|
1714 #SRC ! SRC ! 0 >IN ! -1 SID ! INTERPRET
|
|
|
1715 R> >IN ! R> #SRC ! R> SRC ! R> SID ! ;
|
|
|
1716
|
|
|
1717 VARIABLE ERRORS ( --- a-addr)
|
|
|
1718 \G This variable contains the head of a linked list of error messages.
|
|
|
1719
|
|
|
1720 : ERROR-SOURCE ( --- )
|
|
|
1721 \G Print location of error source.
|
|
|
1722 SID @ 0 > IF
|
|
|
1723 ." in line " LOADLINE @ .
|
|
|
1724 THEN
|
|
|
1725 HERE COUNT TYPE CR WARM
|
|
|
1726 ;
|
|
|
1727
|
|
|
1728 : QUIT ( --- )
|
|
|
1729 \G This word resets the return stack, resets the compiler state, the include
|
|
|
1730 \G buffer and then it reads and interprets terminal input.
|
|
|
1731 R0 @ RP! [
|
|
|
1732 TIB SRC ! 0 SID !
|
|
|
1733 BEGIN
|
|
|
1734 REFILL DROP ['] INTERPRET CATCH DUP 0= IF
|
|
|
1735 DROP STATE @ 0= IF ." OK" THEN CR
|
|
|
1736 ELSE \ throw occured.
|
|
|
1737 XABORTIN
|
|
|
1738 DUP -2 = IF
|
|
|
1739 ERROR$ @ COUNT TYPE SPACE
|
|
|
1740 ELSE
|
|
|
1741 ERRORS @
|
|
|
1742 BEGIN DUP WHILE
|
|
|
1743 OVER OVER @ = IF 4 + COUNT TYPE SPACE ERROR-SOURCE THEN CELL+ @
|
|
|
1744 REPEAT DROP
|
|
|
1745 ." Error " .
|
|
|
1746 THEN ERROR-SOURCE
|
|
|
1747 THEN
|
|
|
1748 0 UNTIL
|
|
|
1749 ;
|
|
|
1750
|
|
|
1751 : XLOAD
|
|
|
1752 XOPENIN 1 SID ! 0 LOADLINE ! ;
|
|
|
1753
|
|
|
1754 : WARM ( ---)
|
|
|
1755 \G This word is called when an error occurs. Clears the stacks, sets
|
|
|
1756 \G BASE to decimal, closes the files and resets the search order.
|
|
|
1757 R0 @ RP! S0 @ SP! DECIMAL
|
|
|
1758 2 #ORDER !
|
|
|
1759 FORTH-WORDLIST CONTEXT !
|
|
|
1760 FORTH-WORDLIST CONTEXT CELL+ !
|
|
|
1761 FORTH-WORDLIST CURRENT !
|
|
|
1762 0 HANDLER !
|
|
|
1763 ." Welcome to Forth" CR
|
|
|
1764 QUIT ;
|
|
|
1765
|
|
|
1766 CODE COLD ( --- )
|
|
|
1767 \G The first word that is called at the start of Forth.
|
|
|
1768 LDY # $8000
|
|
|
1769 STY R0ADDR
|
|
|
1770 LDS # $7C00
|
|
|
1771 STS S0ADDR A;
|
|
|
1772 $7E C, WARM
|
|
|
1773 END-CODE
|
|
|
1774
|
|
|
1775
|
|
|
1776 END-CROSS
|
|
|
1777
|
|
|
1778 \ PART 10: FINISHING AND SAVING THE TARGET IMAGE.
|
|
|
1779
|
|
|
1780 \ Resolve the forward references created by the cross compiler.
|
|
|
1781 RESOLVE DOCOL RESOLVE DOCON RESOLVE LIT RESOLVE BRANCH RESOLVE ?BRANCH
|
|
|
1782 RESOLVE (DO) RESOLVE DOVAR RESOLVE UNNEST
|
|
|
1783 RESOLVE (LOOP) RESOLVE (.")
|
|
|
1784 RESOLVE COLD RESOLVE WARM
|
|
|
1785 RESOLVE THROW
|
|
|
1786 RESOLVE (POSTPONE)
|
|
|
1787
|
|
|
1788 \ Store appropriate values into some of the new Forth's variables.
|
|
|
1789 : CELLS>TARGET
|
|
|
1790 0 DO OVER I CELLS + @ OVER I CELLS-T + !-T LOOP 2DROP ;
|
|
|
1791
|
|
|
1792 #THREADS T' FORTH-WORDLIST >BODY-T !-T
|
|
|
1793 TLINKS T' FORTH-WORDLIST >BODY-T 2 + #THREADS CELLS>TARGET
|
|
|
1794 THERE T' DP >BODY-T !-T
|
|
|
1795
|
|
|
1796 : TELLMEHOW BASE @ HEX
|
|
|
1797 ." Type SO" ORIGIN . ." ,then SS" IMAGE . ." ," THERE ORIGIN - .
|
|
|
1798 BYE ;
|
