Mercurial > hg > Members > kono > os9 > sbc09
comparison examples/ef09.asm @ 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 | ef64e3f4e229 |
comparison
equal
deleted
inserted
replaced
56:4fa2bdb0c457 | 57:2088fd998865 |
---|---|
1 ;TITLE 6809 eForth | |
2 | |
3 ; $Id: ef09.asm,v 1.1 1997/11/24 02:56:01 root Exp $ | |
4 ; | |
5 ;=============================================================== | |
6 ; | |
7 ; eForth 1.0 by Bill Muench and C. H. Ting, 1990 | |
8 ; Much of the code is derived from the following sources: | |
9 ; 8086 figForth by Thomas Newman, 1981 and Joe smith, 1983 | |
10 ; aFORTH by John Rible | |
11 ; bFORTH by Bill Muench | |
12 ; | |
13 ; The goal of this implementation is to provide a simple eForth Model | |
14 ; which can be ported easily to many 8, 16, 24 and 32 bit CPU's. | |
15 ; The following attributes make it suitable for CPU's of the '90: | |
16 ; | |
17 ; small machine dependent kernel and portable high level code | |
18 ; source code in the MASM format | |
19 ; direct threaded code | |
20 ; separated code and name dictionaries | |
21 ; simple vectored terminal and file interface to host computer | |
22 ; aligned with the proposed ANS Forth Standard | |
23 ; easy upgrade path to optimize for specific CPU | |
24 ; | |
25 ; You are invited to implement this Model on your favorite CPU and | |
26 ; contribute it to the eForth Library for public use. You may use | |
27 ; a portable implementation to advertise more sophisticated and | |
28 ; optimized version for commercial purposes. However, you are | |
29 ; expected to implement the Model faithfully. The eForth Working | |
30 ; Group reserves the right to reject implementation which deviates | |
31 ; significantly from this Model. | |
32 ; | |
33 ; As the ANS Forth Standard is still evolving, this Model will | |
34 ; change accordingly. Implementations must state clearly the | |
35 ; version number of the Model being tracked. | |
36 ; | |
37 ; Representing the eForth Working Group in the Silicon Valley FIG Chapter. | |
38 ; Send contributions to: | |
39 ; | |
40 ; Dr. C. H. Ting | |
41 ; 156 14th Avenue | |
42 ; San Mateo, CA 94402 | |
43 ; (415) 571-7639 | |
44 ; | |
45 ;=============================================================== | |
46 ; $Log: ef09.asm,v $ | |
47 ; Revision 1.1 1997/11/24 02:56:01 root | |
48 ; Initial revision | |
49 ; | |
50 ;=============================================================== | |
51 ;; Version control | |
52 | |
53 VER EQU 1 ;major release version | |
54 EXT EQU 0 ;minor extension | |
55 | |
56 ;; Constants | |
57 | |
58 TRUEE EQU -1 ;true flag | |
59 | |
60 COMPO EQU $40 ;lexicon compile only bit | |
61 IMEDD EQU $80 ;lexicon immediate bit | |
62 MASKK EQU $1F7F ;lexicon bit mask | |
63 | |
64 CFAOFF EQU 3 ;offset from word entry to code field area | |
65 ; (length of JSR) | |
66 CELLL EQU 2 ;size of a cell | |
67 BASEE EQU 10 ;default radix | |
68 VOCSS EQU 8 ;depth of vocabulary stack | |
69 | |
70 BKSPP EQU 8 ;back space | |
71 BKSPP2 EQU 127 ;back space | |
72 LF EQU 10 ;line feed | |
73 CRR EQU 13 ;carriage return | |
74 ERR EQU 27 ;error escape | |
75 TIC EQU 39 ;tick | |
76 | |
77 CALLL EQU $12BD ;NOP CALL opcodes | |
78 | |
79 ;; Memory allocation | |
80 | |
81 EM EQU $4000 ;top of memory | |
82 US EQU 64*CELLL ;user area size in cells | |
83 RTS EQU 128*CELLL ;return stack/TIB size | |
84 | |
85 UPP EQU EM-US ;start of user area (UP0) | |
86 RPP EQU UPP-8*CELLL ;start of return stack (RP0) | |
87 TIBB EQU RPP-RTS ;terminal input buffer (TIB) | |
88 SPP EQU TIBB-8*CELLL ;start of data stack (SP0) | |
89 | |
90 COLDD EQU $100 ;cold start vector | |
91 CODEE EQU COLDD+US ;code dictionary | |
92 NAMEE EQU EM-$0400 ;name dictionary | |
93 | |
94 ;; Initialize assembly variables | |
95 | |
96 | |
97 ;; Main entry points and COLD start data | |
98 | |
99 | |
100 ORG COLDD ;beginning of cold boot area | |
101 SETDP 0 | |
102 | |
103 ORIG lds #SPP ;Init stack pointer. | |
104 ldy #RPP ;Init return stack pointer | |
105 ldu #COLD1 ;Init Instr pointer. | |
106 pulu pc ;next. | |
107 | |
108 ; COLD start moves the following to USER variables. | |
109 ; MUST BE IN SAME ORDER AS USER VARIABLES. | |
110 | |
111 | |
112 UZERO RMB 8 ;reserved space in user area | |
113 FDB SPP ;SP0 | |
114 FDB RPP ;RP0 | |
115 FDB QRX ;'?KEY | |
116 FDB TXSTO ;'EMIT | |
117 FDB ACCEP ;'EXPECT | |
118 FDB KTAP ;'TAP | |
119 FDB TXSTO ;'ECHO | |
120 FDB DOTOK ;'PROMPT | |
121 FDB BASEE ;BASE | |
122 FDB 0 ;tmp | |
123 FDB 0 ;SPAN | |
124 FDB 0 ;>IN | |
125 FDB 0 ;#TIB | |
126 FDB TIBB ;TIB | |
127 FDB 0 ;CSP | |
128 FDB INTER ;'EVAL | |
129 FDB NUMBQ ;'NUMBER | |
130 FDB 0 ;HLD | |
131 FDB 0 ;HANDLER | |
132 FDB 0 ;CONTEXT pointer | |
133 RMB VOCSS*2 ;vocabulary stack | |
134 FDB 0 ;CURRENT pointer | |
135 FDB 0 ;vocabulary link pointer | |
136 FDB CTOP ;CP | |
137 FDB NTOP ;NP | |
138 FDB LASTN ;LAST | |
139 ULAST | |
140 | |
141 ORG CODEE ;beginning of the code dictionary | |
142 | |
143 ;; Device dependent I/O | |
144 | |
145 ; BYE ( -- ) | |
146 ; Exit eForth. | |
147 | |
148 FDB BYE,0 | |
149 L100 FCB 3,"BYE" | |
150 BYE sync | |
151 | |
152 ; ?RX ( -- c T | F ) | |
153 ; Return input character and true, or a false if no input. | |
154 | |
155 FDB QRX,L100 | |
156 L110 FCB 3,"?RX" | |
157 QRX ldx #0 | |
158 swi3 | |
159 bcc qrx1 | |
160 stx ,--s | |
161 pulu pc | |
162 qrx1 clra | |
163 std ,--s | |
164 leax -1,x | |
165 stx ,--s | |
166 pulu pc | |
167 | |
168 ; TX! ( c -- ) | |
169 ; Send character c to the output device. | |
170 FDB TXSTO,L110 | |
171 L120 FCB 3,"TX!" | |
172 TXSTO ldd ,s++ | |
173 cmpb #$ff | |
174 bne tx1 | |
175 ldb #32 | |
176 tx1 swi2 | |
177 pulu pc | |
178 | |
179 | |
180 ; !IO ( -- ) | |
181 ; Initialize the serial I/O devices. | |
182 | |
183 FDB STOIO,L120 | |
184 L130 FCB 3,"!IO" | |
185 STOIO pulu pc | |
186 | |
187 ;; The kernel | |
188 | |
189 ; doLIT ( -- w ) | |
190 ; Push an inline literal. | |
191 | |
192 FDB DOLIT,L130 | |
193 L140 FCB COMPO+5,"doLIT" | |
194 DOLIT | |
195 ;;;; ldd ,u++ | |
196 pulu d | |
197 ; 7 cycles | |
198 pshs d | |
199 ;;;; 8 cycles | |
200 ;;;; std ,--s | |
201 pulu pc | |
202 | |
203 ; doCLIT ( -- w ) | |
204 ; Push an inline 8-bit literal. | |
205 | |
206 FDB DOCLIT,L140 | |
207 L141 FCB COMPO+6,"doCLIT" | |
208 DOCLIT | |
209 pulu b | |
210 sex ; sign extended | |
211 pshs d | |
212 pulu pc | |
213 | |
214 ; doLIST ( a -- ) | |
215 ; Process colon list. | |
216 | |
217 FDB DOLST,L141 | |
218 L150 FCB COMPO+6,"doLIST" | |
219 DOLST stu ,--y ; IP on return stack | |
220 puls u ; JSR left new IP on parameter stack | |
221 ;;;; ldu ,s++ | |
222 pulu pc ; FORTH NEXT IP | |
223 | |
224 ; next ( -- ) | |
225 ; Run time code for the single index loop. | |
226 ; : next ( -- ) \ hilevel model | |
227 ; r> r> dup if 1 - >r @ >r exit then drop cell+ >r ; | |
228 | |
229 FDB DONXT,L150 | |
230 L160 FCB COMPO+4,"next" | |
231 DONXT ldd ,y ; counter on return stack | |
232 subd #1 ; decrement | |
233 bcs next1 ; < -> exit loop | |
234 std ,y ; decremented value back on stack | |
235 ldu ,u ; branch to begin of loop | |
236 pulu pc | |
237 next1 leay 2,y ; remove counter from stack | |
238 leau 2,u ; skip branch destination | |
239 pulu pc | |
240 | |
241 | |
242 ; ?branch ( f -- ) | |
243 ; Branch if flag is zero. | |
244 | |
245 FDB QBRAN,L160 | |
246 L170 FCB COMPO+7,"?branch" | |
247 QBRAN ;$CODE COMPO+7,'?branch',QBRAN | |
248 ldd ,s++ | |
249 beq bran1 | |
250 leau 2,u ; skip new IP, no branch | |
251 pulu pc | |
252 bran1 ldu ,u ; go to new IP | |
253 pulu pc | |
254 | |
255 ; branch ( -- ) | |
256 ; Branch to an inline address. | |
257 | |
258 FDB BRAN,L170 | |
259 L180 FCB COMPO+6,"branch" | |
260 BRAN ldu ,u ; destination immediate after BRANCH | |
261 pulu pc | |
262 | |
263 ; EXECUTE ( ca -- ) | |
264 ; Execute the word at ca. | |
265 | |
266 FDB EXECU,L180 | |
267 L190 FCB 7,"EXECUTE" | |
268 EXECU rts ; code pointer on parameter stack | |
269 | |
270 ; EXIT ( -- ) | |
271 ; SEMIS | |
272 ; Terminate a colon definition. | |
273 | |
274 FDB EXIT,L190 | |
275 L200 FCB 4,"EXIT" | |
276 EXIT ldu ,y++ ; get calling IP from return stack | |
277 pulu pc | |
278 | |
279 ; ! ( w a -- ) | |
280 ; Pop the data stack to memory. | |
281 | |
282 FDB STORE,L200 | |
283 L210 FCB 1,"!" | |
284 STORE | |
285 ;;;; ldx ,s++ | |
286 ;;;; ldd ,s++ | |
287 ;;;; faster ... | |
288 puls x | |
289 puls d | |
290 ; we cannot use puls x,d because the order fetched would be wrong :( | |
291 std ,x | |
292 pulu pc | |
293 | |
294 ; @ ( a -- w ) | |
295 ; Push memory location to the data stack. | |
296 | |
297 FDB AT,L210 | |
298 L220 FCB 1,"@" | |
299 AT ldd [,s] | |
300 std ,s | |
301 pulu pc | |
302 | |
303 ; C! ( c b -- ) | |
304 ; Pop the data stack to byte memory. | |
305 | |
306 FDB CSTOR,L220 | |
307 L230 FCB 2,"C!" | |
308 CSTOR | |
309 ;;;; ldx ,s++ | |
310 ;;;; ldd ,s++ | |
311 ;;;; faster ... | |
312 puls x | |
313 puls d | |
314 ; we cannot use puls x,d because the order fetched would be wrong :( | |
315 stb ,x | |
316 pulu pc | |
317 | |
318 | |
319 ; C@ ( b -- c ) | |
320 ; Push byte memory location to the data stack. | |
321 | |
322 FDB CAT,L230 | |
323 L240 FCB 2,"C@" | |
324 CAT ldb [,s] | |
325 clra | |
326 std ,s | |
327 pulu pc | |
328 | |
329 ; RP@ ( -- a ) | |
330 ; Push the current RP to the data stack. | |
331 | |
332 FDB RPAT,L240 | |
333 L250 FCB 3,"RP@" | |
334 RPAT pshs y | |
335 pulu pc | |
336 | |
337 ; RP! ( a -- ) | |
338 ; Set the return stack pointer. | |
339 | |
340 FDB RPSTO,L250 | |
341 L260 FCB 3,"RP!" | |
342 RPSTO puls y | |
343 pulu pc | |
344 | |
345 ; R> ( -- w ) | |
346 ; Pop the return stack to the data stack. | |
347 | |
348 FDB RFROM,L260 | |
349 L270 FCB 2,"R>" | |
350 RFROM ldd ,y++ | |
351 ;;;; std ,--s | |
352 pshs d | |
353 pulu pc | |
354 | |
355 ; I ( -- w ) | |
356 ; Copy top of return stack (current index from DO/LOOP) to the data stack. | |
357 | |
358 FDB RAT,L270 | |
359 L279 FCB 1,"I" | |
360 | |
361 ; R@ ( -- w ) | |
362 ; Copy top of return stack to the data stack. | |
363 | |
364 FDB RAT,L279 | |
365 L280 FCB 2,"R@" | |
366 RAT | |
367 I | |
368 ldd ,y | |
369 ;;;; std ,--s | |
370 pshs d | |
371 pulu pc | |
372 | |
373 ; >R ( w -- ) | |
374 ; Push the data stack to the return stack. | |
375 | |
376 FDB TOR,L280 | |
377 L290 FCB 2,">R" | |
378 TOR | |
379 ;;;; ldd ,s++ | |
380 puls d | |
381 std ,--y | |
382 pulu pc | |
383 | |
384 ; SP@ ( -- a ) | |
385 ; Push the current data stack pointer. | |
386 | |
387 FDB SPAT,L290 | |
388 L300 FCB 3,"SP@" | |
389 SPAT | |
390 tfr s,d | |
391 std ,--s | |
392 ;;;; alternatively | |
393 ;;;; sts ,--s ; does this work? | |
394 pulu pc | |
395 | |
396 ; SP! ( a -- ) | |
397 ; Set the data stack pointer. | |
398 | |
399 FDB SPSTO,L300 | |
400 L310 FCB 3,"SP!" | |
401 SPSTO lds ,s | |
402 pulu pc | |
403 | |
404 ; DROP ( w -- ) | |
405 ; Discard top stack item. | |
406 | |
407 FDB DROP,L310 | |
408 L320 FCB 4,"DROP" | |
409 DROP leas 2,s | |
410 pulu pc | |
411 | |
412 ; DUP ( w -- w w ) | |
413 ; Duplicate the top stack item. | |
414 | |
415 FDB DUPP,L320 | |
416 L330 FCB 3,"DUP" | |
417 DUPP ldd ,s | |
418 ;;;; std ,--s | |
419 pshs d | |
420 pulu pc | |
421 | |
422 ; SWAP ( w1 w2 -- w2 w1 ) | |
423 ; Exchange top two stack items. | |
424 | |
425 FDB SWAP,L330 | |
426 L340 FCB 4,"SWAP" | |
427 SWAP | |
428 ;;;;OLD 1: slow | |
429 ;;;; ldx ,s++ | |
430 ;;;; ldd ,s++ | |
431 ;;;;OLD 2: faster | |
432 ;;;; puls x | |
433 ;;;; puls d | |
434 ;;;; pshs d,x | |
435 ;more efficient, without unnecessary stack pointer manipulations | |
436 ldd ,s | |
437 ldx 2,s | |
438 std 2,s | |
439 stx ,s | |
440 pulu pc | |
441 | |
442 ; OVER ( w1 w2 -- w1 w2 w1 ) | |
443 ; Copy second stack item to top. | |
444 | |
445 FDB OVER,L340 | |
446 L350 FCB 4,"OVER" | |
447 OVER ldd 2,s | |
448 ;;;; std ,--s | |
449 pshs d | |
450 pulu pc | |
451 | |
452 ; 0< ( n -- t ) | |
453 ; Return true if n is negative. | |
454 | |
455 FDB ZLESS,L350 | |
456 L360 FCB 2,"0<" | |
457 ZLESS ldb ,s ; input high byte, as D low | |
458 sex ; sign extend to b to a/b | |
459 tfr a,b ; high byte: 0 or FF copy to D low | |
460 std ,s ; D: 0000 or FFFF (= -1) | |
461 pulu pc | |
462 | |
463 ; 0= ( n -- t ) | |
464 ; Return true if n is zero | |
465 | |
466 FDB ZEQUAL,L360 | |
467 L365 FCB 2,"0=" | |
468 ZEQUAL | |
469 ldx #TRUEE ; true | |
470 ldd ,s ; TOS | |
471 beq ZEQUAL1 ; -> true | |
472 ldx #0 ; false | |
473 ZEQUAL1 stx ,s ; D: 0000 or FFFF (= -1) | |
474 pulu pc | |
475 | |
476 ; AND ( w w -- w ) | |
477 ; Bitwise AND. | |
478 | |
479 FDB ANDD,L365 | |
480 L370 FCB 3,"AND" | |
481 ANDD ldd ,s++ | |
482 anda ,s | |
483 andb 1,s | |
484 std ,s | |
485 pulu pc | |
486 | |
487 ; OR ( w w -- w ) | |
488 ; Bitwise inclusive OR. | |
489 | |
490 FDB ORR,L370 | |
491 L380 FCB 2,"OR" | |
492 ORR ldd ,s++ | |
493 ora ,s | |
494 orb 1,s | |
495 std ,s | |
496 pulu pc | |
497 | |
498 ; XOR ( w w -- w ) | |
499 ; Bitwise exclusive OR. | |
500 | |
501 FDB XORR,L380 | |
502 L390 FCB 3,"XOR" | |
503 XORR ldd ,s++ | |
504 eora ,s | |
505 eorb 1,s | |
506 std ,s | |
507 pulu pc | |
508 | |
509 ; D+ ( ud ud -- udsum ) | |
510 ; Add two unsigned double numbers and return a double sum. | |
511 | |
512 FDB DPLUS,L390 | |
513 L391 FCB 2,"D+" | |
514 DPLUS ldd 2,s ; add low words | |
515 addd 6,s | |
516 std 6,s | |
517 ldd ,s ; add hig words | |
518 adcb 5,s | |
519 adca 4,s | |
520 std 4,s | |
521 leas 4,s ; drop one double | |
522 pulu pc | |
523 | |
524 ; D- ( ud ud -- uddiff ) | |
525 ; Subtract two unsigned double numbers and return a double sum. | |
526 | |
527 FDB DSUB,L391 | |
528 L392 FCB 2,"D-" | |
529 DSUB jsr DOLST | |
530 FDB DNEGA,DPLUS,EXIT | |
531 | |
532 | |
533 ; UM+ ( u u -- udsum ) | |
534 ; Add two unsigned single numbers and return a double sum. | |
535 | |
536 FDB UPLUS,L392 | |
537 L400 FCB 3,"UM+" | |
538 UPLUS ldd ,s | |
539 addd 2,s | |
540 std 2,s | |
541 ldd #0 | |
542 adcb #0 | |
543 std ,s | |
544 pulu pc | |
545 | |
546 ;; Constants | |
547 | |
548 ; doCONST ( -- w ) | |
549 ; Run time routine for CONSTANT | |
550 | |
551 FDB DOCONST,L400 | |
552 L401 FCB COMPO+7,"doCONST" | |
553 DOCONST | |
554 FDOCONST | |
555 ldd [,s] ; contents of W (on TOS because of JSR) | |
556 std ,s ; to TOS (replacing W) | |
557 pulu pc | |
558 | |
559 ; 0 ( -- 0 ) | |
560 ; Constant 0 | |
561 | |
562 FDB ZERO,L401 | |
563 L402 FCB 1,"0" | |
564 ZERO jsr FDOCONST | |
565 FDB 0 | |
566 | |
567 ; 1 ( -- 1 ) | |
568 ; Constant 1 | |
569 | |
570 FDB ONE,L402 | |
571 L403 FCB 1,"1" | |
572 ONE jsr FDOCONST | |
573 FDB 1 | |
574 | |
575 ; 2 ( -- 2 ) | |
576 ; Constant 2 | |
577 | |
578 FDB TWO,L403 | |
579 L404 FCB 1,"2" | |
580 TWO jsr FDOCONST | |
581 FDB 2 | |
582 | |
583 | |
584 ; -1 ( -- -1 ) | |
585 ; Constant -1 | |
586 | |
587 FDB MONE,L404 | |
588 L405 FCB 2,"-1" | |
589 MONE jsr FDOCONST | |
590 FDB -1 | |
591 | |
592 ;; System and user variables | |
593 | |
594 ; doVAR ( -- a ) | |
595 ; Run time routine for VARIABLE and CREATE. | |
596 | |
597 FDB DOVAR,L405 | |
598 L410 FCB COMPO+5,"doVAR" | |
599 DOVAR | |
600 jsr DOLST | |
601 FDB RFROM,EXIT | |
602 | |
603 ;; fast native DOVAR implementation | |
604 FDOVAR pulu pc | |
605 | |
606 | |
607 ; UP ( -- a ) | |
608 ; Pointer to the user area. | |
609 | |
610 FDB UP,L410 | |
611 L420 FCB 2,"UP" | |
612 UP | |
613 ;; jsr DOLST | |
614 ;; FDB DOVAR | |
615 ;; fast (native) DOVAR | |
616 jsr FDOVAR | |
617 FDB UPP | |
618 | |
619 ; doUSER ( -- a ) | |
620 ; Run time routine for user variables. | |
621 | |
622 FDB DOUSE,L420 | |
623 L430 FCB COMPO+5,"doUSER" | |
624 DOUSE | |
625 jsr DOLST | |
626 FDB RFROM,AT,UP,AT,PLUS,EXIT | |
627 | |
628 ;; fast (native) DOUSE implementation (*NOT COMPLETE*) | |
629 FDOUSE | |
630 ldd [,s] ; pointer to value (from JSR) | |
631 addd UP+CFAOFF ; dirty access to start of USER area: | |
632 ; var. UP value direct access (not | |
633 ; as a high level word) | |
634 std ,s ; resulting address returned on p-stack | |
635 pulu pc | |
636 | |
637 ; SP0 ( -- a ) | |
638 ; Pointer to bottom of the data stack. | |
639 | |
640 FDB SZERO,L430 | |
641 L440 FCB 3,"SP0" | |
642 SZERO | |
643 jsr FDOUSE | |
644 FDB 8 | |
645 ;;;; jsr DOLST | |
646 ;;;; FDB DOUSE,8 | |
647 | |
648 ; RP0 ( -- a ) | |
649 ; Pointer to bottom of the return stack. | |
650 | |
651 FDB RZERO,L440 | |
652 L450 FCB 3,"RP0" | |
653 RZERO | |
654 jsr FDOUSE | |
655 FDB 10 | |
656 ;;;; jsr DOLST | |
657 ;;;; FDB DOUSE,10 | |
658 | |
659 ; '?KEY ( -- a ) | |
660 ; Execution vector of ?KEY. | |
661 | |
662 FDB TQKEY,L450 | |
663 L460 FCB 5,"'?KEY" | |
664 TQKEY | |
665 jsr FDOUSE | |
666 FDB 12 | |
667 ;;;; jsr DOLST | |
668 ;;;; FDB DOUSE,12 | |
669 | |
670 ; 'EMIT ( -- a ) | |
671 ; Execution vector of EMIT. | |
672 | |
673 FDB TEMIT,L460 | |
674 L470 FCB 5,"'EMIT" | |
675 TEMIT | |
676 jsr FDOUSE | |
677 FDB 14 | |
678 ;; jsr DOLST | |
679 ;; FDB DOUSE,14 | |
680 | |
681 ; 'EXPECT ( -- a ) | |
682 ; Execution vector of EXPECT. | |
683 | |
684 FDB TEXPE,L470 | |
685 L480 FCB 7,"'EXPECT" | |
686 TEXPE | |
687 jsr FDOUSE | |
688 FDB 16 | |
689 ;;;; jsr DOLST | |
690 ;;;; FDB DOUSE,16 | |
691 | |
692 ; 'TAP ( -- a ) | |
693 ; Execution vector of TAP. | |
694 | |
695 FDB TTAP,L480 | |
696 L490 FCB 4,"'TAP" | |
697 TTAP | |
698 jsr FDOUSE | |
699 FDB 18 | |
700 ;;;; jsr DOLST | |
701 ;;;; FDB DOUSE,18 | |
702 | |
703 ; 'ECHO ( -- a ) | |
704 ; Execution vector of ECHO. | |
705 | |
706 FDB TECHO,L490 | |
707 L500 FCB 5,"'ECHO" | |
708 TECHO | |
709 jsr FDOUSE | |
710 FDB 20 | |
711 ;;;; jsr DOLST | |
712 ;;;; FDB DOUSE,20 | |
713 | |
714 ; 'PROMPT ( -- a ) | |
715 ; Execution vector of PROMPT. | |
716 | |
717 FDB TPROM,L500 | |
718 L510 FCB 7,"'PROMPT" | |
719 TPROM | |
720 jsr FDOUSE | |
721 FDB 22 | |
722 ;;;; jsr DOLST | |
723 ;;;; FDB DOUSE,22 | |
724 | |
725 | |
726 ; BASE ( -- a ) | |
727 ; Storage of the radix base for numeric I/O. | |
728 | |
729 FDB BASE,L510 | |
730 L520 FCB 4,"BASE" | |
731 BASE | |
732 jsr FDOUSE | |
733 FDB 24 | |
734 ;;;; jsr DOLST | |
735 ;;;; FDB DOUSE,24 | |
736 | |
737 ; tmp ( -- a ) | |
738 ; A temporary storage location used in parse and find. | |
739 | |
740 FDB TEMP,L520 | |
741 L530 FCB COMPO+3,"tmp" | |
742 TEMP | |
743 jsr FDOUSE | |
744 FDB 26 | |
745 ;;;; jsr DOLST | |
746 ;;;; FDB DOUSE,26 | |
747 | |
748 ; SPAN ( -- a ) | |
749 ; Hold character count received by EXPECT. | |
750 | |
751 FDB SPAN,L530 | |
752 L540 FCB 4,"SPAN" | |
753 SPAN | |
754 jsr FDOUSE | |
755 FDB 28 | |
756 ;;;; jsr DOLST | |
757 ;;;; FDB DOUSE,28 | |
758 | |
759 ; >IN ( -- a ) | |
760 ; Hold the character pointer while parsing input stream. | |
761 | |
762 FDB INN,L540 | |
763 L550 FCB 3,">IN" | |
764 INN | |
765 jsr FDOUSE | |
766 FDB 30 | |
767 ;;;; jsr DOLST | |
768 ;;;; FDB DOUSE,30 | |
769 | |
770 ; #TIB ( -- a ) | |
771 ; Hold the current count in and address of the terminal input buffer. | |
772 | |
773 FDB NTIB,L550 | |
774 L560 FCB 4,"#TIB" | |
775 NTIB | |
776 jsr FDOUSE | |
777 FDB 32 | |
778 ;;;; jsr DOLST | |
779 ;;;; FDB DOUSE,32 ;It contains TWO cells!!!! | |
780 | |
781 ; CSP ( -- a ) | |
782 ; Hold the stack pointer for error checking. | |
783 | |
784 FDB CSP,L560 | |
785 L570 FCB 3,"CSP" | |
786 CSP | |
787 jsr FDOUSE | |
788 FDB 36 | |
789 ;;;; jsr DOLST | |
790 ;;;; FDB DOUSE 36 | |
791 | |
792 ; 'EVAL ( -- a ) | |
793 ; Execution vector of EVAL. | |
794 | |
795 FDB TEVAL,L570 | |
796 L580 FCB 5,"'EVAL" | |
797 TEVAL | |
798 jsr FDOUSE | |
799 FDB 38 | |
800 ;;;; jsr DOLST | |
801 ;;;; FDB DOUSE,38 | |
802 | |
803 ; 'NUMBER ( -- a ) | |
804 ; Execution vector of NUMBER?. | |
805 | |
806 FDB TNUMB,L580 | |
807 L590 FCB 7,"'NUMBER" | |
808 TNUMB | |
809 jsr FDOUSE | |
810 FDB 40 | |
811 ;;;; jsr DOLST | |
812 ;;;; FDB DOUSE,40 | |
813 | |
814 ; HLD ( -- a ) | |
815 ; Hold a pointer in building a numeric output string. | |
816 | |
817 FDB HLD,L590 | |
818 L600 FCB 3,"HLD" | |
819 HLD | |
820 jsr FDOUSE | |
821 FDB 42 | |
822 ;;;; jsr DOLST | |
823 ;;;; FDB DOUSE,42 | |
824 | |
825 ; HANDLER ( -- a ) | |
826 ; Hold the return stack pointer for error handling. | |
827 | |
828 FDB HANDL,L600 | |
829 L610 FCB 7,"HANDLER" | |
830 HANDL | |
831 jsr FDOUSE | |
832 FDB 44 | |
833 ;;;; jsr DOLST | |
834 ;;;; FDB DOUSE,44 | |
835 | |
836 ; CONTEXT ( -- a ) | |
837 ; A area to specify vocabulary search order. | |
838 | |
839 FDB CNTXT,L610 | |
840 L620 FCB 7,"CONTEXT" | |
841 CNTXT | |
842 jsr FDOUSE | |
843 FDB 46 | |
844 ;;;; jsr DOLST | |
845 ;;;; FDB DOUSE,46 ;plus space for voc stack. | |
846 | |
847 ; CURRENT ( -- a ) | |
848 ; Point to the vocabulary to be extended. | |
849 | |
850 FDB CRRNT,L620 | |
851 L630 FCB 7,"CURRENT" | |
852 CRRNT | |
853 jsr FDOUSE | |
854 FDB 48+VOCSS*2 ;Extra cell | |
855 ;;;; jsr DOLST | |
856 ;;;; FDB DOUSE,48+VOCSS*2 ;Extra cell | |
857 | |
858 ; CP ( -- a ) | |
859 ; Point to the top of the code dictionary. | |
860 | |
861 FDB CP,L630 | |
862 L640 FCB 2,"CP" | |
863 CP | |
864 jsr FDOUSE | |
865 FDB 52+VOCSS*2 | |
866 ;;;; jsr DOLST | |
867 ;;;; FDB DOUSE,52+VOCSS*2 | |
868 | |
869 ; NP ( -- a ) | |
870 ; Point to the bottom of the name dictionary. | |
871 | |
872 FDB NP,L640 | |
873 L650 FCB 2,"NP" | |
874 NP | |
875 jsr FDOUSE | |
876 FDB 54+VOCSS*2 | |
877 ;;;; jsr DOLST | |
878 ;;;; FDB DOUSE,54+VOCSS*2 | |
879 | |
880 ; LAST ( -- a ) | |
881 ; Point to the last name in the name dictionary. | |
882 | |
883 FDB LAST,L650 | |
884 L660 FCB 4,"LAST" | |
885 LAST | |
886 jsr FDOUSE | |
887 FDB 56+VOCSS*2 | |
888 ;;;; jsr DOLST | |
889 ;;;; FDB DOUSE,56+VOCSS*2 | |
890 | |
891 ;; Common functions | |
892 | |
893 ; doVOC ( -- ) | |
894 ; Run time action of VOCABULARY's. | |
895 | |
896 FDB DOVOC,L660 | |
897 L670 FCB COMPO+5,"doVOC" | |
898 DOVOC | |
899 jsr DOLST | |
900 FDB RFROM,CNTXT,STORE,EXIT | |
901 | |
902 ; FORTH ( -- ) | |
903 ; Make FORTH the context vocabulary. | |
904 | |
905 FDB FORTH,L670 | |
906 L680 FCB 5,"FORTH" | |
907 FORTH | |
908 jsr DOLST | |
909 FDB DOVOC | |
910 FDB 0 ;vocabulary head pointer | |
911 FDB 0 ;vocabulary link pointer | |
912 | |
913 ; ?DUP ( w -- w w | 0 ) | |
914 ; Dup tos if its is not zero. | |
915 | |
916 FDB QDUP,L680 | |
917 L690 FCB 4,"?DUP" | |
918 QDUP | |
919 jsr DOLST | |
920 FDB DUPP | |
921 FDB QBRAN,QDUP1 | |
922 FDB DUPP | |
923 QDUP1 FDB EXIT | |
924 | |
925 ; ROT ( w1 w2 w3 -- w2 w3 w1 ) | |
926 ; Rot 3rd item to top. | |
927 | |
928 FDB ROT,L690 | |
929 L700 FCB 3,"ROT" | |
930 ROT | |
931 jsr DOLST | |
932 FDB TOR,SWAP,RFROM,SWAP,EXIT | |
933 | |
934 ; 2DROP ( w w -- ) | |
935 ; Discard two items on stack. | |
936 | |
937 FDB DDROP,L700 | |
938 L710 FCB 5,"2DROP" | |
939 DDROP | |
940 jsr DOLST | |
941 FDB DROP,DROP,EXIT | |
942 | |
943 ; 2DUP ( w1 w2 -- w1 w2 w1 w2 ) | |
944 ; Duplicate top two items. | |
945 | |
946 FDB DDUP,L710 | |
947 L720 FCB 4,"2DUP" | |
948 DDUP | |
949 jsr DOLST | |
950 FDB OVER,OVER,EXIT | |
951 | |
952 ; LSHIFT ( w n -- w ) | |
953 ; Shift word left n times. | |
954 FDB LSHIFT,L720 | |
955 L721 FCB 6,"LSHIFT" | |
956 LSHIFT ldx ,s++ ;shift count | |
957 beq LSHIFT2 | |
958 ldd ,s ;value to shift | |
959 LSHIFT1 aslb ;low | |
960 rola ;high | |
961 leax -1,x ;count down | |
962 bne LSHIFT1 | |
963 std ,s | |
964 LSHIFT2 | |
965 pulu pc | |
966 | |
967 ; RSHIFT ( w n -- w ) | |
968 ; Shift word right n times. | |
969 FDB RSHIFT,L721 | |
970 L721A FCB 6,"RSHIFT" | |
971 RSHIFT ldx ,s++ ;shift count | |
972 beq RSHIFT2 | |
973 ldd ,s ;value to shift | |
974 RSHIFT1 lsra ;high | |
975 rorb ;low | |
976 leax -1,x ;count down | |
977 bne RSHIFT1 | |
978 std ,s | |
979 RSHIFT2 | |
980 pulu pc | |
981 | |
982 ; >< ( w -- w ) | |
983 ; swap high and low byte | |
984 FDB SWAPHL,L721A | |
985 L722 FCB 2,"><" | |
986 SWAPHL ldb ,s ;high -> D low | |
987 lda 1,s ;low -> D high | |
988 std ,s | |
989 pulu pc | |
990 | |
991 ; 256/ ( w -- w ) | |
992 ; multiply with 256 (shift left 8 times) | |
993 FDB SLASH256,L722 | |
994 L723 FCB 4,"256/" | |
995 SLASH256 ldb ,s ;high -> D low | |
996 clra ;D high = 0 | |
997 std ,s | |
998 pulu pc | |
999 | |
1000 ; 256* ( w -- w ) | |
1001 ; multiply with 256 (shift left 8 times) | |
1002 FDB STAR256,L723 | |
1003 L724 FCB 4,"256*" | |
1004 STAR256 lda 1,s ;low -> D high | |
1005 clrb ;D low = 0 | |
1006 std ,s | |
1007 pulu pc | |
1008 | |
1009 ; 1+ ( w -- w ) | |
1010 ; Shortcut, quick add 1 | |
1011 FDB PLUS1,L724 | |
1012 L725 FCB 2,"1+" | |
1013 PLUS1 ldd ,s | |
1014 addd #1 | |
1015 std ,s | |
1016 pulu pc | |
1017 | |
1018 ; -+ ( w -- w ) | |
1019 ; Shortcut, quick subtract 1 | |
1020 FDB MINUS1,L725 | |
1021 L726 FCB 2,"1-" | |
1022 MINUS1 ldd ,s | |
1023 subd #1 | |
1024 std ,s | |
1025 pulu pc | |
1026 | |
1027 ; 2* ( w -- w ) | |
1028 ; multiply by 2 using shift operation | |
1029 FDB TWOSTAR,L726 | |
1030 L727 FCB 2,"2*" | |
1031 TWOSTAR asl 1,s ;low | |
1032 rol 0,s ;high | |
1033 pulu pc | |
1034 | |
1035 ; 2/ ( w -- w ) | |
1036 ; divide by 2 using shift operation | |
1037 FDB TWOSLASH,L727 | |
1038 L728 FCB 2,"2/" | |
1039 TWOSLASH asr 0,s ;high | |
1040 ror 1,s ;low | |
1041 pulu pc | |
1042 | |
1043 ; + ( w w -- sum ) | |
1044 ; Add top two items. | |
1045 | |
1046 FDB PLUS,L728 | |
1047 L730 FCB 1,"+" | |
1048 PLUS | |
1049 ldd ,s++ | |
1050 addd ,s | |
1051 std ,s | |
1052 pulu pc | |
1053 ;;; HL with UPLUS!? Too inefficient ... | |
1054 ;;; jsr DOLST | |
1055 ;;; FDB UPLUS,DROP,EXIT | |
1056 | |
1057 ; NOT ( w -- w ) | |
1058 ; One's complement of tos. | |
1059 | |
1060 FDB INVER,L730 | |
1061 L740 FCB 3,"NOT" | |
1062 INVER | |
1063 ;;;; fastest ... (13T) | |
1064 com ,s ; 6T | |
1065 com 1,s ; 7T | |
1066 pulu pc | |
1067 ;;;; alternative ... (14T) | |
1068 ldd ,s ;TOS 5T | |
1069 coma ; 2T | |
1070 comb ; 2T | |
1071 std ,s ; 5T | |
1072 pulu pc | |
1073 ;;; slow HL ... | |
1074 ;;; jsr DOLST | |
1075 ;;; FDB DOLIT,-1,XORR,EXIT | |
1076 | |
1077 ; NEGATE ( n -- -n ) | |
1078 ; Two's complement of tos. | |
1079 | |
1080 FDB NEGAT,L740 | |
1081 L750 FCB 6,"NEGATE" | |
1082 NEGAT | |
1083 ;;;; fastest? .... (3+6+5 = 14T) | |
1084 ldd #0 ; 3T | |
1085 subd ,s ; 6T | |
1086 std ,s ; 5T | |
1087 pulu pc | |
1088 ;;;; alternate ... (7+3+6 = 16T) | |
1089 neg 1,s ; high 7T | |
1090 bne NEGAT1 ; 3T | |
1091 neg ,s ; low with 1+ carry 6T | |
1092 pulu pc | |
1093 NEGAT1 com ,s ; low, no 1+ carry 6T | |
1094 pulu pc | |
1095 ;;;; slow HL ... | |
1096 ;;;; jsr DOLST | |
1097 ;;;; FDB INVER,PLUS1,EXIT | |
1098 | |
1099 ; DNEGATE ( d -- -d ) | |
1100 ; Two's complement of top double. | |
1101 | |
1102 FDB DNEGA,L750 | |
1103 L760 FCB 7,"DNEGATE" | |
1104 DNEGA | |
1105 ldd #0 | |
1106 subd 2,s ; low word | |
1107 std 2,s | |
1108 ldd #0 | |
1109 sbcb 1,s ; high word low byte | |
1110 sbca ,s ; high word high byte | |
1111 std ,s | |
1112 pulu pc | |
1113 ;;;; slow HL ... | |
1114 ;;;; jsr DOLST | |
1115 ;;;; FDB INVER,TOR,INVER | |
1116 ;;;; FDB DOLIT,1,UPLUS | |
1117 ;;;; FDB RFROM,PLUS,EXIT | |
1118 | |
1119 ; - ( n1 n2 -- n1-n2 ) | |
1120 ; Subtraction. | |
1121 | |
1122 FDB SUBB,L760 | |
1123 L770 FCB 1,"-" | |
1124 SUBB ldd 2,s | |
1125 subd ,s++ | |
1126 std ,s | |
1127 pulu pc | |
1128 ;;; slow HL ... | |
1129 ;;; jsr DOLST | |
1130 ;;; FDB NEGAT,PLUS,EXIT | |
1131 | |
1132 ; ABS ( n -- n ) | |
1133 ; Return the absolute value of n. | |
1134 | |
1135 FDB ABSS,L770 | |
1136 L780 FCB 3,"ABS" | |
1137 ABSS jsr DOLST | |
1138 FDB DUPP,ZLESS | |
1139 FDB QBRAN,ABS1 | |
1140 FDB NEGAT | |
1141 ABS1 FDB EXIT | |
1142 | |
1143 ; = ( w w -- t ) | |
1144 ; Return true if top two are equal. | |
1145 | |
1146 FDB EQUAL,L780 | |
1147 L790 FCB 1,"=" | |
1148 EQUAL | |
1149 ldx #TRUEE | |
1150 puls d ; first value | |
1151 cmpd ,s ; compare to 2nd value | |
1152 beq EQUAL1 ; equal -> true | |
1153 ldx #0 ; false (leax 1,x save 1 byte, but is slower) | |
1154 EQUAL1 stx ,s | |
1155 pulu pc | |
1156 ;;;; slow HL ... | |
1157 ;;;; jsr DOLST | |
1158 ;;;; FDB XORR | |
1159 ;;;; FDB QBRAN,EQU1 | |
1160 ;;;; FDB DOLIT,0,EXIT | |
1161 ;;;;EQU1: FDB DOLIT,TRUEE,EXIT | |
1162 | |
1163 ; U< ( u1 u2 -- t ) | |
1164 ; Unsigned compare of top two items. | |
1165 | |
1166 FDB ULESS,L790 | |
1167 L800 FCB 2,"U<" | |
1168 ULESS | |
1169 ldx #TRUEE ; true | |
1170 puls d ; u2 | |
1171 cmpd ,s ; u2 - u1 | |
1172 bhi ULES1 ; unsigned: u2 higher u1 | |
1173 ldx #0 ; false | |
1174 ULES1 stx ,s ; replace TOS with result | |
1175 pulu pc | |
1176 ;;;; slow HL ... | |
1177 ;;;; jsr DOLST | |
1178 ;;;; FDB DDUP,XORR,ZLESS | |
1179 ;;;; FDB QBRAN,ULES1 | |
1180 ;;;; FDB SWAP,DROP,ZLESS,EXIT | |
1181 ;;;;ULES1: FDB SUBB,ZLESS,EXIT | |
1182 | |
1183 ; < ( n1 n2 -- t ) | |
1184 ; Signed compare of top two items. | |
1185 | |
1186 FDB LESS,L800 | |
1187 L810 FCB 1,"<" | |
1188 LESS | |
1189 ldx #TRUEE ; true | |
1190 puls d ; n2 | |
1191 cmpd ,s ; n2 - n1 | |
1192 bgt LESS1 ; signed: n2 greater than n1 | |
1193 ldx #0 ; false | |
1194 LESS1 stx ,s ; replace TOS with result | |
1195 pulu pc | |
1196 | |
1197 ;;;; slow HL ... | |
1198 ;;;; jsr DOLST | |
1199 ;;;; FDB DDUP,XORR,ZLESS | |
1200 ;;;; FDB QBRAN,LESS1 | |
1201 ;;;; FDB DROP,ZLESS,EXIT | |
1202 ;;;;LESS1: FDB SUBB,ZLESS,EXIT | |
1203 | |
1204 ; MAX ( n n -- n ) | |
1205 ; Return the greater of two top stack items. | |
1206 | |
1207 FDB MAX,L810 | |
1208 L820 FCB 3,"MAX" | |
1209 MAX jsr DOLST | |
1210 FDB DDUP,LESS | |
1211 FDB QBRAN,MAX1 | |
1212 FDB SWAP | |
1213 MAX1 FDB DROP,EXIT | |
1214 | |
1215 ; MIN ( n n -- n ) | |
1216 ; Return the smaller of top two stack items. | |
1217 | |
1218 FDB MIN,L820 | |
1219 L830 FCB 3,"MIN" | |
1220 MIN jsr DOLST | |
1221 FDB DDUP,SWAP,LESS | |
1222 FDB QBRAN,MIN1 | |
1223 FDB SWAP | |
1224 MIN1 FDB DROP,EXIT | |
1225 | |
1226 ; WITHIN ( u ul uh -- t ) | |
1227 ; Return true if u is within the range of ul and uh. ( ul <= u < uh ) | |
1228 | |
1229 FDB WITHI,L830 | |
1230 L840 FCB 6,"WITHIN" | |
1231 WITHI jsr DOLST | |
1232 FDB OVER,SUBB,TOR | |
1233 FDB SUBB,RFROM,ULESS,EXIT | |
1234 | |
1235 ;; Divide | |
1236 | |
1237 ; U/ ( udl udh un -- ur uq ) | |
1238 ; Unsigned divide of a double by a single. Return mod and quotient. | |
1239 ; | |
1240 ; Special cases: | |
1241 ; 1. overflow: quotient overflow if dividend is to great (remainder = divisor), | |
1242 ; remainder is set to $FFFF -> special handling. | |
1243 ; This is checked also right before the main loop. | |
1244 ; 2. underflow: divisor does not fit into dividend -> remainder | |
1245 ; get the value of the dividend -> automatically covered. | |
1246 ; | |
1247 ; overflow: quotient = $FFFF, remainder = divisor | |
1248 ; underflow: quotient = $0000, remainder = dividend low | |
1249 ; division by zero: quotient = $FFFF, remainder = $0000 | |
1250 ; | |
1251 ; Testvalues: | |
1252 ; | |
1253 ; DIVH DIVL DVSR QUOT REM comment | |
1254 ; | |
1255 ; 0100 0000 FFFF 0100 0100 maximum divisor | |
1256 ; 0000 0001 8000 0000 0001 underflow (REM = DIVL) | |
1257 ; 0000 5800 3000 0001 1800 normal divsion | |
1258 ; 5800 0000 3000 FFFF 3000 overflow | |
1259 ; 0000 0001 0000 FFFF 0000 overflow (division by zero) | |
1260 | |
1261 FDB USLASH,L840 | |
1262 L845 FCB 2,"U/" | |
1263 | |
1264 USLASH | |
1265 ldx #16 | |
1266 ldd 2,s ; udh | |
1267 cmpd ,s ; dividend to great? | |
1268 bhs UMMODOV ; quotient overflow! | |
1269 asl 5,s ; udl low | |
1270 rol 4,s ; udl high | |
1271 | |
1272 UMMOD1 rolb ; got one bit from udl | |
1273 rola | |
1274 bcs UMMOD2 ; bit 16 means always greater as divisor | |
1275 cmpd ,s ; divide by un | |
1276 bhs UMMOD2 ; higher or same as divisor? | |
1277 andcc #$fe ; clc - clear carry flag | |
1278 bra UMMOD3 | |
1279 UMMOD2 subd ,s | |
1280 orcc #$01 ; sec - set carry flag | |
1281 UMMOD3 rol 5,s ; udl, quotient shifted in | |
1282 rol 4,s | |
1283 leax -1,x | |
1284 bne UMMOD1 | |
1285 | |
1286 ldx 4,s ; quotient | |
1287 cmpd ,s ; remainder >= divisor -> overflow | |
1288 blo UMMOD4 | |
1289 UMMODOV | |
1290 ldd ,s ; remainder set to divisor | |
1291 ldx #$FFFF ; quotient = FFFF (-1) marks overflow | |
1292 ; (case 1) | |
1293 UMMOD4 | |
1294 leas 2,s ; un (divisor thrown away) | |
1295 stx ,s ; quotient to TOS | |
1296 std 2,s ; remainder 2nd | |
1297 | |
1298 pulu pc ; NEXT | |
1299 | |
1300 | |
1301 ; UM/MOD ( udl udh un -- ur uq ) | |
1302 ; Unsigned divide of a double by a single. Return mod and quotient. | |
1303 | |
1304 FDB UMMOD,L845 | |
1305 L850 FCB 6,"UM/MOD" | |
1306 UMMOD | |
1307 jmp USLASH | |
1308 ;;;; slow HL ... | |
1309 jsr DOLST | |
1310 FDB DDUP,ULESS | |
1311 FDB QBRAN,UMM4 | |
1312 FDB NEGAT,DOLIT,15,TOR | |
1313 UMM1 FDB TOR,DUPP,UPLUS | |
1314 FDB TOR,TOR,DUPP,UPLUS | |
1315 FDB RFROM,PLUS,DUPP | |
1316 FDB RFROM,RAT,SWAP,TOR | |
1317 FDB UPLUS,RFROM,ORR | |
1318 FDB QBRAN,UMM2 | |
1319 FDB TOR,DROP,PLUS1,RFROM | |
1320 FDB BRAN,UMM3 | |
1321 UMM2 FDB DROP | |
1322 UMM3 FDB RFROM | |
1323 FDB DONXT,UMM1 | |
1324 FDB DROP,SWAP,EXIT | |
1325 UMM4 FDB DROP,DDROP | |
1326 FDB DOLIT,-1,DUPP,EXIT | |
1327 | |
1328 ; M/MOD ( d n -- r q ) | |
1329 ; Signed floored divide of double by single. Return mod and quotient. | |
1330 | |
1331 FDB MSMOD,L850 | |
1332 L860 FCB 5,"M/MOD" | |
1333 MSMOD | |
1334 jsr DOLST | |
1335 FDB DUPP,ZLESS,DUPP,TOR | |
1336 FDB QBRAN,MMOD1 | |
1337 FDB NEGAT,TOR,DNEGA,RFROM | |
1338 MMOD1 FDB TOR,DUPP,ZLESS | |
1339 FDB QBRAN,MMOD2 | |
1340 FDB RAT,PLUS | |
1341 MMOD2 FDB RFROM,UMMOD,RFROM | |
1342 FDB QBRAN,MMOD3 | |
1343 FDB SWAP,NEGAT,SWAP | |
1344 MMOD3 FDB EXIT | |
1345 | |
1346 ; /MOD ( n n -- r q ) | |
1347 ; Signed divide. Return mod and quotient. | |
1348 | |
1349 FDB SLMOD,L860 | |
1350 L870 FCB 4,"/MOD" | |
1351 SLMOD jsr DOLST | |
1352 FDB OVER,ZLESS,SWAP,MSMOD,EXIT | |
1353 | |
1354 ; MOD ( n n -- r ) | |
1355 ; Signed divide. Return mod only. | |
1356 | |
1357 FDB MODD,L870 | |
1358 L880 FCB 3,"MOD" | |
1359 MODD jsr DOLST | |
1360 FDB SLMOD,DROP,EXIT | |
1361 | |
1362 ; / ( n n -- q ) | |
1363 ; Signed divide. Return quotient only. | |
1364 | |
1365 FDB SLASH,L880 | |
1366 L890 FCB 1,"/" | |
1367 SLASH | |
1368 jsr DOLST | |
1369 FDB SLMOD,SWAP,DROP,EXIT | |
1370 | |
1371 ;; Multiply | |
1372 | |
1373 ; UM* ( u u -- ud ) | |
1374 ; Unsigned multiply. Return double product. | |
1375 | |
1376 FDB UMSTA,L890 | |
1377 L900 FCB 3,"UM*" | |
1378 UMSTA | |
1379 ldx #17 ; 16 adds and 17 shifts ... | |
1380 clra ; result high word | |
1381 clrb | |
1382 bra UUMSTA3 | |
1383 UUMSTA1 bcc UUMSTA2 | |
1384 addd ,s | |
1385 UUMSTA2 rora ; high, result high word | |
1386 rorb ; low, result high word | |
1387 UUMSTA3 ror 2,s ; shift multiplier high, result low word | |
1388 ror 3,s ; shift multiplier low, result low word | |
1389 leax -1,x | |
1390 bne UUMSTA1 | |
1391 std ,s | |
1392 pulu pc | |
1393 ;;;; slow HL ... | |
1394 ;;;; jsr DOLST | |
1395 ;;;; FDB DOLIT,0,SWAP,DOLIT,15,TOR | |
1396 ;;;;UMST1: FDB DUPP,UPLUS,TOR,TOR | |
1397 ;;;; FDB DUPP,UPLUS,RFROM,PLUS,RFROM | |
1398 ;;;; FDB QBRAN,UMST2 | |
1399 ;;;; FDB TOR,OVER,UPLUS,RFROM,PLUS | |
1400 ;;;;UMST2: FDB DONXT,UMST1 | |
1401 ;;;; FDB ROT,DROP,EXIT | |
1402 | |
1403 ; _UM* ( u u -- ud ) | |
1404 ; Unsigned multiply. Return double product. | |
1405 | |
1406 FDB UUMSTA,L900 | |
1407 L900A FCB 4,"_UM*" | |
1408 UUMSTA | |
1409 jsr DOLST | |
1410 FDB DOLIT,0,SWAP,DOLIT,15,TOR | |
1411 UMST1 FDB DUPP,UPLUS,TOR,TOR | |
1412 FDB DUPP,UPLUS,RFROM,PLUS,RFROM | |
1413 FDB QBRAN,UMST2 | |
1414 FDB TOR,OVER,UPLUS,RFROM,PLUS | |
1415 UMST2 FDB DONXT,UMST1 | |
1416 FDB ROT,DROP,EXIT | |
1417 | |
1418 ; * ( n n -- n ) | |
1419 ; Signed multiply. Return single product. | |
1420 ; XXX Not really signed, -200 -200 * -> -25536 | |
1421 | |
1422 FDB STAR,L900A | |
1423 L910 FCB 1,"*" | |
1424 STAR | |
1425 jsr DOLST | |
1426 FDB MSTAR,DROP,EXIT | |
1427 | |
1428 ; M* ( n n -- d ) | |
1429 ; Signed multiply. Return double product. | |
1430 | |
1431 FDB MSTAR,L910 | |
1432 L920 FCB 2,"M*" | |
1433 MSTAR | |
1434 jsr DOLST | |
1435 FDB DDUP,XORR,ZLESS,TOR | |
1436 FDB ABSS,SWAP,ABSS,UMSTA | |
1437 FDB RFROM | |
1438 FDB QBRAN,MSTA1 | |
1439 FDB DNEGA | |
1440 MSTA1 FDB EXIT | |
1441 | |
1442 ; */MOD ( n1 n2 n3 -- r q ) | |
1443 ; Multiply n1 and n2, then divide by n3. Return mod and quotient. | |
1444 | |
1445 FDB SSMOD,L920 | |
1446 L930 FCB 5,"*/MOD" | |
1447 SSMOD jsr DOLST | |
1448 FDB TOR,MSTAR,RFROM,MSMOD,EXIT | |
1449 | |
1450 ; */ ( n1 n2 n3 -- q ) | |
1451 ; Multiply n1 by n2, then divide by n3. Return quotient only. | |
1452 | |
1453 FDB STASL,L930 | |
1454 L940 FCB 2,"*/" | |
1455 STASL jsr DOLST | |
1456 FDB SSMOD,SWAP,DROP,EXIT | |
1457 | |
1458 ;; Miscellaneous | |
1459 | |
1460 ; CELL+ ( a -- a ) | |
1461 ; Add cell size in byte to address. | |
1462 | |
1463 FDB CELLP,L940 | |
1464 L950 FCB 5,"CELL+" | |
1465 CELLP jsr DOLST | |
1466 FDB DOCLIT | |
1467 FCB CELLL | |
1468 FDB PLUS,EXIT | |
1469 | |
1470 ; CELL- ( a -- a ) | |
1471 ; Subtract cell size in byte from address. | |
1472 | |
1473 FDB CELLM,L950 | |
1474 L960 FCB 5,"CELL-" | |
1475 CELLM jsr DOLST | |
1476 FDB DOCLIT | |
1477 FCB 0-CELLL | |
1478 FDB PLUS,EXIT | |
1479 | |
1480 ; CELLS ( n -- n ) | |
1481 ; Multiply tos by cell size in bytes. | |
1482 | |
1483 FDB CELLS,L960 | |
1484 L970 FCB 5,"CELLS" | |
1485 CELLS jsr DOLST | |
1486 FDB DOCLIT | |
1487 FCB CELLL | |
1488 FDB STAR,EXIT | |
1489 | |
1490 ; ALIGNED ( b -- a ) | |
1491 ; Align address to the cell boundary. | |
1492 | |
1493 FDB ALGND,L970 | |
1494 L975 FCB 7,"ALIGNED" | |
1495 ALGND jsr DOLST | |
1496 FDB EXIT | |
1497 | |
1498 ; BL ( -- 32 ) | |
1499 ; Return 32, the blank character. | |
1500 | |
1501 FDB BLANK,L975 | |
1502 L980 FCB 2,"BL" | |
1503 BLANK | |
1504 jsr DOCONST | |
1505 FDB ' ' | |
1506 ;;; jsr DOLST | |
1507 ;;; FDB DOLIT,' ',EXIT | |
1508 | |
1509 ; >CHAR ( c -- c ) | |
1510 ; Filter non-printing characters. | |
1511 | |
1512 FDB TCHAR,L980 | |
1513 L990 FCB 5,">CHAR" | |
1514 TCHAR jsr DOLST | |
1515 FDB DOLIT,$7F,ANDD,DUPP ;mask msb | |
1516 FDB DOCLIT | |
1517 FCB 127 | |
1518 FDB BLANK,WITHI ;check for printable | |
1519 FDB QBRAN,TCHA1 | |
1520 FDB DROP,DOLIT,'_' ;replace non-printables | |
1521 TCHA1 FDB EXIT | |
1522 | |
1523 ; DEPTH ( -- n ) | |
1524 ; Return the depth of the data stack. | |
1525 | |
1526 FDB DEPTH,L990 | |
1527 L1000 FCB 5,"DEPTH" | |
1528 DEPTH jsr DOLST | |
1529 FDB SPAT,SZERO,AT,SWAP,SUBB | |
1530 FDB DOCLIT | |
1531 FCB CELLL | |
1532 FDB SLASH,EXIT | |
1533 | |
1534 ; PICK ( ... +n -- ... w ) | |
1535 ; Copy the nth stack item to tos. | |
1536 | |
1537 FDB PICK,L1000 | |
1538 L1010 FCB 4,"PICK" | |
1539 PICK | |
1540 ldd ,s | |
1541 addd #1 ; correct index | |
1542 aslb ; CELLL* (ASSERT: CELLL=2!!!) | |
1543 rola | |
1544 ldx d,s ; pick value | |
1545 stx ,s ; replace TOP | |
1546 pulu pc | |
1547 ;;;; slow HL ... | |
1548 ;;;; jsr DOLST | |
1549 ;;;; FDB PLUS1,CELLS | |
1550 ;;;; FDB SPAT,PLUS,AT,EXIT | |
1551 | |
1552 | |
1553 ; ROLL ( ... +n -- ... w ) | |
1554 ; Copy the nth stack item to tos. | |
1555 | |
1556 FDB ROLL,L1010 | |
1557 L1015 FCB 4,"ROLL" | |
1558 ROLL | |
1559 ;;;; XXX als Primitive! | |
1560 ;;;; slow HL ... | |
1561 jsr DOLST | |
1562 FDB DUPP,TWO | |
1563 FDB LESS,QBRAN,ROL1 | |
1564 FDB DROP,BRAN,ROL2 | |
1565 ROL1 FDB SWAP,TOR,ONE | |
1566 FDB SUBB | |
1567 FDB ROLL,RFROM,SWAP | |
1568 ROL2 FDB EXIT | |
1569 | |
1570 ;; Memory access | |
1571 | |
1572 ; +! ( n a -- ) | |
1573 ; Add n to the contents at address a. | |
1574 | |
1575 FDB PSTOR,L1015 | |
1576 L1020 FCB 2,"+!" | |
1577 PSTOR | |
1578 puls x ; address | |
1579 puls d ; value | |
1580 addd ,x ; add to value from address | |
1581 std ,x ; store back | |
1582 pulu pc | |
1583 | |
1584 ;;;; XXX als Primitive! | |
1585 ;;;; slow HL ... | |
1586 ;;;; jsr DOLST | |
1587 ;;;; FDB SWAP,OVER,AT,PLUS | |
1588 ;;;; FDB SWAP,STORE,EXIT | |
1589 | |
1590 ; 2! ( d a -- ) | |
1591 ; Store the double integer to address a. | |
1592 | |
1593 FDB DSTOR,L1020 | |
1594 L1030 FCB 2,"2!" | |
1595 DSTOR | |
1596 ;;;; XXX als Primitive! | |
1597 ;;;; slow HL ... | |
1598 jsr DOLST | |
1599 FDB SWAP,OVER,STORE | |
1600 FDB CELLP,STORE,EXIT | |
1601 | |
1602 ; 2@ ( a -- d ) | |
1603 ; Fetch double integer from address a. | |
1604 | |
1605 FDB DAT,L1030 | |
1606 L1040 FCB 2,"2@" | |
1607 DAT | |
1608 ;;;; XXX als Primitive! | |
1609 ;;;; slow HL ... | |
1610 jsr DOLST | |
1611 FDB DUPP,CELLP,AT | |
1612 FDB SWAP,AT,EXIT | |
1613 | |
1614 ; COUNT ( b -- b +n ) | |
1615 ; Return count byte of a string and add 1 to byte address. | |
1616 | |
1617 FDB COUNT,L1040 | |
1618 L1050 FCB 5,"COUNT" | |
1619 COUNT jsr DOLST | |
1620 FDB DUPP,PLUS1 | |
1621 FDB SWAP,CAT,EXIT | |
1622 | |
1623 ; HERE ( -- a ) | |
1624 ; Return the top of the code dictionary. | |
1625 | |
1626 FDB HERE,L1050 | |
1627 L1060 FCB 4,"HERE" | |
1628 HERE jsr DOLST | |
1629 FDB CP,AT,EXIT | |
1630 | |
1631 ; PAD ( -- a ) | |
1632 ; Return the address of the text buffer above the code dictionary. | |
1633 | |
1634 FDB PAD,L1060 | |
1635 L1070 FCB 3,"PAD" | |
1636 PAD jsr DOLST | |
1637 FDB HERE,DOLIT,80,PLUS,EXIT | |
1638 | |
1639 ; TIB ( -- a ) | |
1640 ; Return the address of the terminal input buffer. | |
1641 | |
1642 FDB TIB,L1070 | |
1643 L1080 FCB 3,"TIB" | |
1644 TIB jsr DOLST | |
1645 FDB NTIB,CELLP,AT,EXIT | |
1646 | |
1647 ; @EXECUTE ( a -- ) | |
1648 ; Execute vector stored in address a. | |
1649 | |
1650 FDB ATEXE,L1080 | |
1651 L1090 FCB 8,"@EXECUTE" | |
1652 ATEXE jsr DOLST | |
1653 FDB AT,QDUP ;?address or zero | |
1654 FDB QBRAN,EXE1 | |
1655 FDB EXECU ;execute if non-zero | |
1656 EXE1 FDB EXIT ;do nothing if zero | |
1657 | |
1658 ; CMOVE ( b1 b2 u -- ) | |
1659 ; Copy u bytes from b1 to b2. | |
1660 | |
1661 FDB CMOVE,L1090 | |
1662 L1100 FCB 5,"CMOVE" | |
1663 CMOVE | |
1664 jmp CMOVEW | |
1665 ldd ,s ;count | |
1666 beq CMOVE3 ;zero -> leave | |
1667 tstb ;count low | |
1668 beq CMOVE1 | |
1669 inc ,s ;ajust high for to-0 decrementation | |
1670 CMOVE1 | |
1671 ldx 2,s ;to addr | |
1672 stu 2,s ;save reg on stack | |
1673 ldu 4,s ;from addr | |
1674 CMOVE2 lda ,u+ ;from -> | |
1675 sta ,x+ ;to | |
1676 decb ;low count | |
1677 bne CMOVE2 | |
1678 dec ,s ;high count | |
1679 bne CMOVE2 | |
1680 ldu 2,s | |
1681 CMOVE3 leas 6,s ;drop 3 parameters from stack | |
1682 pulu pc | |
1683 ;;;; | |
1684 ;;;; alternative, wordwise copy ... | |
1685 CMOVEW ldd ,s ; count | |
1686 ldx 2,s ; destination | |
1687 sty ,s ; save RP | |
1688 stu 2,s ; save IP | |
1689 ldy 4,s ; source | |
1690 lsra ; divide by 2, count words | |
1691 rorb ; | |
1692 pshs cc | |
1693 beq CMOVEW1 ; byte decrement correction | |
1694 inca ; byte decrement high byte correction | |
1695 CMOVEW1 subd #0 ; word count zero (=65536)? | |
1696 beq CMOVEW3 | |
1697 CMOVEW2 ldu ,y++ ; source | |
1698 stu ,x++ ; destination | |
1699 decb ; count low | |
1700 bne CMOVEW2 | |
1701 deca ; count high (count to 0 corrected) | |
1702 bne CMOVEW2 | |
1703 CMOVEW3 puls CC ; check if odd count? | |
1704 bcc CMOVEW4 | |
1705 lda ,y | |
1706 sta ,x | |
1707 CMOVEW4 puls y,u ; y first | |
1708 leas 2,s ; drop 3rd parameter | |
1709 pulu pc ; next | |
1710 ;;;; | |
1711 ;;;; slow HL ... | |
1712 ;;;; jsr DOLST | |
1713 ;;;; FDB TOR | |
1714 ;;;; FDB BRAN,CMOV2 | |
1715 ;;;;CMOV1: FDB TOR,DUPP,CAT | |
1716 ;;;; FDB RAT,CSTOR | |
1717 ;;;; FDB PLUS1 | |
1718 ;;;; FDB RFROM,PLUS1 | |
1719 ;;;;CMOV2: FDB DONXT,CMOV1 | |
1720 ;;;; FDB DDROP,EXIT | |
1721 ;;;; | |
1722 | |
1723 ; FILL ( b u c -- ) | |
1724 ; Fill u bytes of character c to area beginning at b. | |
1725 | |
1726 FDB FILL,L1100 | |
1727 L1110 FCB 4,"FILL" | |
1728 FILL | |
1729 ldd 2,s ;count | |
1730 beq NFILL3 ;zero -> leave | |
1731 tstb ;count low | |
1732 beq NFILL1 | |
1733 inc 2,s ;ajust high for to-0 decrementation | |
1734 NFILL1 | |
1735 ldx 4,s ;to addr | |
1736 lda 1,s ;fill byte, low byte from TOS | |
1737 NFILL2 | |
1738 sta ,x+ ;to | |
1739 decb ;low count | |
1740 bne NFILL2 | |
1741 dec 2,s ;high count | |
1742 bne NFILL2 | |
1743 NFILL3 leas 6,s ;drop 3 parameters from stack | |
1744 pulu pc | |
1745 ;;;; slow HL ... | |
1746 ;;;; jsr DOLST | |
1747 ;;;; FDB SWAP,TOR,SWAP | |
1748 ;;;; FDB BRAN,FILL2 | |
1749 ;;;;FILL1: FDB DDUP,CSTOR,PLUS1 | |
1750 ;;;;FILL2: FDB DONXT,FILL1 | |
1751 ;;;; FDB DDROP,EXIT | |
1752 | |
1753 ; -TRAILING ( b u -- b u ) | |
1754 ; Adjust the count to eliminate trailing white space. | |
1755 | |
1756 FDB DTRAI,L1110 | |
1757 L1120 FCB 9,"-TRAILING" | |
1758 DTRAI jsr DOLST | |
1759 FDB TOR | |
1760 FDB BRAN,DTRA2 | |
1761 DTRA1 FDB BLANK,OVER,RAT,PLUS,CAT,LESS | |
1762 FDB QBRAN,DTRA2 | |
1763 FDB RFROM,PLUS1,EXIT | |
1764 DTRA2 FDB DONXT,DTRA1 | |
1765 FDB ZERO,EXIT | |
1766 | |
1767 ; PACK$ ( b u a -- a ) | |
1768 ; Build a counted string with u characters from b. Null fill. | |
1769 | |
1770 FDB PACKS,L1120 | |
1771 L1130 FCB 5,"PACK$" | |
1772 PACKS jsr DOLST | |
1773 FDB DUPP,TOR ;strings only on cell boundary | |
1774 FDB DDUP,CSTOR | |
1775 FDB PLUS1 ;count mod cell | |
1776 FDB DDUP,PLUS | |
1777 FDB ZERO,SWAP,CSTOR ;null fill cell | |
1778 FDB SWAP,CMOVE,RFROM,EXIT ;move string | |
1779 | |
1780 ;; Numeric output, single precision | |
1781 | |
1782 ; DIGIT ( u -- c ) | |
1783 ; Convert digit u to a character. | |
1784 | |
1785 FDB DIGIT,L1130 | |
1786 L1140 FCB 5,"DIGIT" | |
1787 DIGIT jsr DOLST | |
1788 FDB DOCLIT | |
1789 FCB 9 | |
1790 FDB OVER,LESS | |
1791 FDB DOCLIT | |
1792 FCB 7 | |
1793 FDB ANDD,PLUS | |
1794 FDB DOLIT,'0',PLUS,EXIT | |
1795 | |
1796 ; EXTRACT ( n base -- n c ) | |
1797 ; Extract the least significant digit from n. | |
1798 | |
1799 FDB EXTRC,L1140 | |
1800 L1150 FCB 7,"EXTRACT" | |
1801 EXTRC jsr DOLST | |
1802 FDB ZERO,SWAP,UMMOD | |
1803 FDB SWAP,DIGIT,EXIT | |
1804 | |
1805 ; <# ( -- ) | |
1806 ; Initiate the numeric output process. | |
1807 | |
1808 FDB BDIGS,L1150 | |
1809 L1160 FCB 2,"<#" | |
1810 BDIGS jsr DOLST | |
1811 FDB PAD,HLD,STORE,EXIT | |
1812 | |
1813 ; HOLD ( c -- ) | |
1814 ; Insert a character into the numeric output string. | |
1815 | |
1816 | |
1817 FDB HOLD,L1160 | |
1818 L1170 FCB 4,"HOLD" | |
1819 HOLD jsr DOLST | |
1820 FDB HLD,AT,MINUS1 | |
1821 FDB DUPP,HLD,STORE,CSTOR,EXIT | |
1822 | |
1823 ; # ( u -- u ) | |
1824 ; Extract one digit from u and append the digit to output string. | |
1825 | |
1826 FDB DIG,L1170 | |
1827 L1180 FCB 1,"#" | |
1828 DIG jsr DOLST | |
1829 FDB BASE,AT,EXTRC,HOLD,EXIT | |
1830 | |
1831 ; #S ( u -- 0 ) | |
1832 ; Convert u until all digits are added to the output string. | |
1833 | |
1834 FDB DIGS,L1180 | |
1835 L1190 FCB 2,"#S" | |
1836 DIGS jsr DOLST | |
1837 DIGS1 FDB DIG,DUPP | |
1838 FDB QBRAN,DIGS2 | |
1839 FDB BRAN,DIGS1 | |
1840 DIGS2 FDB EXIT | |
1841 | |
1842 ; SIGN ( n -- ) | |
1843 ; Add a minus sign to the numeric output string. | |
1844 | |
1845 FDB SIGN,L1190 | |
1846 L1200 FCB 4,"SIGN" | |
1847 SIGN jsr DOLST | |
1848 FDB ZLESS | |
1849 FDB QBRAN,SIGN1 | |
1850 FDB DOLIT,'-',HOLD | |
1851 SIGN1 FDB EXIT | |
1852 | |
1853 ; #> ( w -- b u ) | |
1854 ; Prepare the output string to be TYPE'd. | |
1855 | |
1856 FDB EDIGS,L1200 | |
1857 L1210 FCB 2,"#>" | |
1858 EDIGS jsr DOLST | |
1859 FDB DROP,HLD,AT | |
1860 FDB PAD,OVER,SUBB,EXIT | |
1861 | |
1862 ; str ( w -- b u ) | |
1863 ; Convert a signed integer to a numeric string. | |
1864 | |
1865 FDB STR,L1210 | |
1866 L1220 FCB 3,"str" | |
1867 STR jsr DOLST | |
1868 FDB DUPP,TOR,ABSS | |
1869 FDB BDIGS,DIGS,RFROM | |
1870 FDB SIGN,EDIGS,EXIT | |
1871 | |
1872 ; HEX ( -- ) | |
1873 ; Use radix 16 as base for numeric conversions. | |
1874 | |
1875 FDB HEX,L1220 | |
1876 L1230 FCB 3,"HEX" | |
1877 HEX jsr DOLST | |
1878 FDB DOCLIT | |
1879 FCB 16 | |
1880 FDB BASE,STORE,EXIT | |
1881 | |
1882 ; DECIMAL ( -- ) | |
1883 ; Use radix 10 as base for numeric conversions. | |
1884 | |
1885 FDB DECIM,L1230 | |
1886 L1240 FCB 7,"DECIMAL" | |
1887 DECIM jsr DOLST | |
1888 FDB DOCLIT | |
1889 FCB 10 | |
1890 FDB BASE,STORE,EXIT | |
1891 | |
1892 ;; Numeric input, single precision | |
1893 | |
1894 ; DIGIT? ( c base -- u t ) | |
1895 ; Convert a character to its numeric value. A flag indicates success. | |
1896 | |
1897 FDB DIGTQ,L1240 | |
1898 L1250 FCB 6,"DIGIT?" | |
1899 DIGTQ jsr DOLST | |
1900 FDB TOR,DOLIT,'0',SUBB | |
1901 FDB DOCLIT | |
1902 FCB 9 | |
1903 FDB OVER,LESS | |
1904 FDB QBRAN,DGTQ1 | |
1905 FDB DOCLIT | |
1906 FCB 7 | |
1907 FDB SUBB | |
1908 FDB DUPP,DOLIT,10,LESS,ORR | |
1909 DGTQ1 FDB DUPP,RFROM,ULESS,EXIT | |
1910 | |
1911 ; NUMBER? ( a -- n T | a F ) | |
1912 ; Convert a number string to integer. Push a flag on tos. | |
1913 | |
1914 FDB NUMBQ,L1250 | |
1915 L1260 FCB 7,"NUMBER?" | |
1916 NUMBQ jsr DOLST | |
1917 FDB BASE,AT,TOR,ZERO,OVER,COUNT | |
1918 FDB OVER,CAT,DOLIT,'$',EQUAL | |
1919 FDB QBRAN,NUMQ1 | |
1920 FDB HEX,SWAP,PLUS1 | |
1921 FDB SWAP,MINUS1 | |
1922 NUMQ1 FDB OVER,CAT,DOLIT,'-',EQUAL,TOR | |
1923 FDB SWAP,RAT,SUBB,SWAP,RAT,PLUS,QDUP | |
1924 FDB QBRAN,NUMQ6 | |
1925 FDB MINUS1,TOR | |
1926 NUMQ2 FDB DUPP,TOR,CAT,BASE,AT,DIGTQ | |
1927 FDB QBRAN,NUMQ4 | |
1928 FDB SWAP,BASE,AT,STAR,PLUS,RFROM | |
1929 FDB PLUS1 | |
1930 FDB DONXT,NUMQ2 | |
1931 FDB RAT,SWAP,DROP | |
1932 FDB QBRAN,NUMQ3 | |
1933 FDB NEGAT | |
1934 NUMQ3 FDB SWAP | |
1935 FDB BRAN,NUMQ5 | |
1936 NUMQ4 FDB RFROM,RFROM,DDROP,DDROP,ZERO | |
1937 NUMQ5 FDB DUPP | |
1938 NUMQ6 FDB RFROM,DDROP | |
1939 FDB RFROM,BASE,STORE,EXIT | |
1940 | |
1941 ;; Basic I/O | |
1942 | |
1943 ; ?KEY ( -- c T | F ) | |
1944 ; Return input character and true, or a false if no input. | |
1945 | |
1946 | |
1947 FDB QKEY,L1260 | |
1948 L1270 FCB 4,"?KEY" | |
1949 QKEY jsr DOLST | |
1950 FDB TQKEY,ATEXE,EXIT | |
1951 | |
1952 ; KEY ( -- c ) | |
1953 ; Wait for and return an input character. | |
1954 | |
1955 FDB KEY,L1270 | |
1956 L1280 FCB 3,"KEY" | |
1957 KEY jsr DOLST | |
1958 KEY1 FDB QKEY | |
1959 FDB QBRAN,KEY1 | |
1960 FDB EXIT | |
1961 | |
1962 ; EMIT ( c -- ) | |
1963 ; Send a character to the output device. | |
1964 | |
1965 FDB EMIT,L1280 | |
1966 L1290 FCB 4,"EMIT" | |
1967 EMIT jsr DOLST | |
1968 FDB TEMIT,ATEXE,EXIT | |
1969 | |
1970 ; NUF? ( -- t ) | |
1971 ; Return false if no input, else pause and if CR return true. | |
1972 | |
1973 FDB NUFQ,L1290 | |
1974 L1300 FCB 4,"NUF?" | |
1975 NUFQ jsr DOLST | |
1976 FDB QKEY,DUPP | |
1977 FDB QBRAN,NUFQ1 | |
1978 FDB DDROP,KEY,DOCLIT | |
1979 FCB CRR | |
1980 FDB EQUAL | |
1981 NUFQ1 FDB EXIT | |
1982 | |
1983 ; PACE ( -- ) | |
1984 ; Send a pace character for the file downloading process. | |
1985 | |
1986 FDB PACE,L1300 | |
1987 L1310 FCB 4,"PACE" | |
1988 PACE jsr DOLST | |
1989 FDB DOCLIT | |
1990 FCB 11 | |
1991 FDB EMIT,EXIT | |
1992 | |
1993 ; SPACE ( -- ) | |
1994 ; Send the blank character to the output device. | |
1995 | |
1996 FDB SPACE,L1310 | |
1997 L1320 FCB 5,"SPACE" | |
1998 SPACE jsr DOLST | |
1999 FDB BLANK,EMIT,EXIT | |
2000 | |
2001 ; SPACES ( +n -- ) | |
2002 ; Send n spaces to the output device. | |
2003 | |
2004 FDB SPACS,L1320 | |
2005 L1330 FCB 6,"SPACES" | |
2006 SPACS jsr DOLST | |
2007 FDB ZERO,MAX,TOR | |
2008 FDB BRAN,CHAR2 | |
2009 CHAR1 FDB SPACE | |
2010 CHAR2 FDB DONXT,CHAR1 | |
2011 FDB EXIT | |
2012 | |
2013 ; TYPE ( b u -- ) | |
2014 ; Output u characters from b. | |
2015 | |
2016 FDB TYPES,L1330 | |
2017 L1340 FCB 4,"TYPE" | |
2018 TYPES jsr DOLST | |
2019 FDB TOR | |
2020 FDB BRAN,TYPE2 | |
2021 TYPE1 FDB DUPP,CAT,EMIT | |
2022 FDB PLUS1 | |
2023 TYPE2 FDB DONXT,TYPE1 | |
2024 FDB DROP,EXIT | |
2025 | |
2026 ; CR ( -- ) | |
2027 ; Output a carriage return and a line feed. | |
2028 | |
2029 FDB CR,L1340 | |
2030 L1350 FCB 2,"CR" | |
2031 CR jsr DOLST | |
2032 FDB DOCLIT | |
2033 FCB CRR | |
2034 FDB EMIT | |
2035 FDB DOCLIT | |
2036 FCB LF | |
2037 FDB EMIT,EXIT | |
2038 | |
2039 ; do$ ( -- a ) | |
2040 ; Return the address of a compiled string. | |
2041 | |
2042 FDB DOSTR,L1350 | |
2043 L1360 FCB COMPO+3,"do$" | |
2044 DOSTR jsr DOLST | |
2045 FDB RFROM,RAT,RFROM,COUNT,PLUS | |
2046 FDB ALGND,TOR,SWAP,TOR,EXIT | |
2047 | |
2048 ; $"| ( -- a ) | |
2049 ; Run time routine compiled by $". Return address of a compiled string. | |
2050 | |
2051 FDB STRQP,L1360 | |
2052 L1370 FCB COMPO+3,'$','"','|' | |
2053 STRQP jsr DOLST | |
2054 FDB DOSTR,EXIT ;force a call to do$ | |
2055 | |
2056 ; ."| ( -- ) | |
2057 ; Run time routine of ." . Output a compiled string. | |
2058 | |
2059 FDB DOTQP,L1370 | |
2060 L1380 FCB COMPO+3,'.','"','|' | |
2061 DOTQP jsr DOLST | |
2062 FDB DOSTR,COUNT,TYPES,EXIT | |
2063 | |
2064 ; .R ( n +n -- ) | |
2065 ; Display an integer in a field of n columns, right justified. | |
2066 | |
2067 FDB DOTR,L1380 | |
2068 L1390 FCB 2,".R" | |
2069 DOTR jsr DOLST | |
2070 FDB TOR,STR,RFROM,OVER,SUBB | |
2071 FDB SPACS,TYPES,EXIT | |
2072 | |
2073 ; U.R ( u +n -- ) | |
2074 ; Display an unsigned integer in n column, right justified. | |
2075 | |
2076 FDB UDOTR,L1390 | |
2077 L1400 FCB 3,"U.R" | |
2078 UDOTR jsr DOLST | |
2079 FDB TOR,BDIGS,DIGS,EDIGS | |
2080 FDB RFROM,OVER,SUBB | |
2081 FDB SPACS,TYPES,EXIT | |
2082 | |
2083 ; U. ( u -- ) | |
2084 ; Display an unsigned integer in free format. | |
2085 | |
2086 FDB UDOT,L1400 | |
2087 L1410 FCB 2,"U." | |
2088 UDOT jsr DOLST | |
2089 FDB BDIGS,DIGS,EDIGS | |
2090 FDB SPACE,TYPES,EXIT | |
2091 | |
2092 ; . ( w -- ) | |
2093 ; Display an integer in free format, preceeded by a space. | |
2094 | |
2095 FDB DOT,L1410 | |
2096 L1420 FCB 1,"." | |
2097 DOT jsr DOLST | |
2098 FDB BASE,AT,DOCLIT | |
2099 FCB 10 | |
2100 FDB XORR ;?decimal | |
2101 FDB QBRAN,DOT1 | |
2102 FDB UDOT,EXIT ;no, display unsigned | |
2103 DOT1 FDB STR,SPACE,TYPES,EXIT ;yes, display signed | |
2104 | |
2105 ; ? ( a -- ) | |
2106 ; Display the contents in a memory cell. | |
2107 | |
2108 FDB QUEST,L1420 | |
2109 L1430 FCB 1,"?" | |
2110 QUEST jsr DOLST | |
2111 FDB AT,DOT,EXIT | |
2112 | |
2113 ;; Parsing | |
2114 | |
2115 ; parse ( b u c -- b u delta ; <string> ) | |
2116 ; Scan string delimited by c. Return found string and its offset. | |
2117 | |
2118 FDB PARS,L1430 | |
2119 L1440 FCB 5,"parse" | |
2120 PARS jsr DOLST | |
2121 FDB TEMP,STORE,OVER,TOR,DUPP | |
2122 FDB QBRAN,PARS8 | |
2123 FDB MINUS1,TEMP,AT,BLANK,EQUAL | |
2124 FDB QBRAN,PARS3 | |
2125 FDB TOR | |
2126 PARS1 FDB BLANK,OVER,CAT ;skip leading blanks ONLY | |
2127 FDB SUBB,ZLESS,INVER | |
2128 FDB QBRAN,PARS2 | |
2129 FDB PLUS1 | |
2130 FDB DONXT,PARS1 | |
2131 FDB RFROM,DROP,ZERO,DUPP,EXIT | |
2132 PARS2 FDB RFROM | |
2133 PARS3 FDB OVER,SWAP | |
2134 FDB TOR | |
2135 PARS4 FDB TEMP,AT,OVER,CAT,SUBB ;scan for delimiter | |
2136 FDB TEMP,AT,BLANK,EQUAL | |
2137 FDB QBRAN,PARS5 | |
2138 FDB ZLESS | |
2139 PARS5 FDB QBRAN,PARS6 | |
2140 FDB PLUS1 | |
2141 FDB DONXT,PARS4 | |
2142 FDB DUPP,TOR | |
2143 FDB BRAN,PARS7 | |
2144 PARS6 FDB RFROM,DROP,DUPP | |
2145 FDB PLUS1,TOR | |
2146 PARS7 FDB OVER,SUBB | |
2147 FDB RFROM,RFROM,SUBB,EXIT | |
2148 PARS8 FDB OVER,RFROM,SUBB,EXIT | |
2149 | |
2150 ; PARSE ( c -- b u ; <string> ) | |
2151 ; Scan input stream and return counted string delimited by c. | |
2152 | |
2153 FDB PARSE,L1440 | |
2154 L1450 FCB 5,"PARSE" | |
2155 PARSE jsr DOLST | |
2156 FDB TOR,TIB,INN,AT,PLUS ;current input buffer pointer | |
2157 FDB NTIB,AT,INN,AT,SUBB ;remaining count | |
2158 FDB RFROM,PARS,INN,PSTOR,EXIT | |
2159 | |
2160 ; .( ( -- ) | |
2161 ; Output following string up to next ) . | |
2162 | |
2163 FDB DOTPR,L1450 | |
2164 L1460 FCB IMEDD+2,".(" | |
2165 DOTPR jsr DOLST | |
2166 FDB DOLIT,')',PARSE,TYPES,EXIT | |
2167 | |
2168 ; ( ( -- ) | |
2169 ; Ignore following string up to next ) . A comment. | |
2170 | |
2171 FDB PAREN,L1460 | |
2172 L1470 FCB IMEDD+1,"(" | |
2173 PAREN jsr DOLST | |
2174 FDB DOLIT,')',PARSE,DDROP,EXIT | |
2175 | |
2176 ; \ ( -- ) | |
2177 ; Ignore following text till the end of line. | |
2178 | |
2179 FDB BKSLA,L1470 | |
2180 L1480 FCB IMEDD+1,92 ; '\' but give as numeric to avoid different escap char processing in different assemblers | |
2181 BKSLA jsr DOLST | |
2182 FDB NTIB,AT,INN,STORE,EXIT | |
2183 | |
2184 ; CHAR ( -- c ) | |
2185 ; Parse next word and return its first character. | |
2186 | |
2187 FDB CHAR,L1480 | |
2188 L1490 FCB 4,"CHAR" | |
2189 CHAR jsr DOLST | |
2190 FDB BLANK,PARSE,DROP,CAT,EXIT | |
2191 | |
2192 ; TOKEN ( -- a ; <string> ) | |
2193 ; Parse a word from input stream and copy it to name dictionary. | |
2194 | |
2195 FDB TOKEN,L1490 | |
2196 L1500 FCB 5,"TOKEN" | |
2197 TOKEN jsr DOLST | |
2198 FDB BLANK,PARSE,DOCLIT | |
2199 FCB 31 | |
2200 FDB MIN | |
2201 FDB NP,AT,OVER,SUBB,CELLM | |
2202 FDB PACKS,EXIT | |
2203 | |
2204 ; WORD ( c -- a ; <string> ) | |
2205 ; Parse a word from input stream and copy it to code dictionary. | |
2206 | |
2207 FDB WORD,L1500 | |
2208 L1510 FCB 4,"WORD" | |
2209 WORD jsr DOLST | |
2210 FDB PARSE,HERE,PACKS,EXIT | |
2211 | |
2212 ;; Dictionary search | |
2213 | |
2214 ; NAME> ( na -- ca ) | |
2215 ; Return a code address given a name address. | |
2216 | |
2217 FDB NAMET,L1510 | |
2218 L1520 FCB 5,"NAME>" | |
2219 NAMET jsr DOLST | |
2220 FDB CELLM,CELLM,AT,EXIT | |
2221 | |
2222 ; SAME? ( a a u -- a a f \ -0+ ) | |
2223 ; Compare u bytes in two strings. Return 0 if identical. | |
2224 | |
2225 FDB SAMEQ,L1520 | |
2226 L1530 FCB 5,"SAME?" | |
2227 SAMEQ jsr DOLST | |
2228 FDB TOR | |
2229 FDB BRAN,SAME2 | |
2230 SAME1 FDB OVER,RAT,PLUS,CAT | |
2231 FDB OVER,RAT,PLUS,CAT | |
2232 FDB SUBB,QDUP | |
2233 FDB QBRAN,SAME2 | |
2234 FDB RFROM,DROP,EXIT | |
2235 SAME2 FDB DONXT,SAME1 | |
2236 FDB DOLIT,0,EXIT | |
2237 | |
2238 ; find ( a va -- ca na | a F ) | |
2239 ; Search a vocabulary for a string. Return ca and na if succeeded. | |
2240 | |
2241 FDB FIND,L1530 | |
2242 L1540 FCB 4,"find" | |
2243 FIND jsr DOLST | |
2244 FDB SWAP,DUPP,CAT,MINUS1 | |
2245 FDB TEMP,STORE | |
2246 FDB DUPP,AT,TOR,CELLP,SWAP | |
2247 FIND1 FDB AT,DUPP | |
2248 FDB QBRAN,FIND6 | |
2249 FDB DUPP,AT,DOLIT,MASKK,ANDD,RAT,XORR | |
2250 FDB QBRAN,FIND2 | |
2251 FDB CELLP,MONE | |
2252 FDB BRAN,FIND3 | |
2253 FIND2 FDB CELLP,TEMP,AT,SAMEQ | |
2254 FIND3 FDB BRAN,FIND4 | |
2255 FIND6 FDB RFROM,DROP | |
2256 FDB SWAP,CELLM,SWAP,EXIT | |
2257 FIND4 FDB QBRAN,FIND5 | |
2258 FDB CELLM,CELLM | |
2259 FDB BRAN,FIND1 | |
2260 FIND5 FDB RFROM,DROP,SWAP,DROP | |
2261 FDB CELLM | |
2262 FDB DUPP,NAMET,SWAP,EXIT | |
2263 | |
2264 ; NAME? ( a -- ca na | a F ) | |
2265 ; Search all context vocabularies for a string. | |
2266 | |
2267 FDB NAMEQ,L1540 | |
2268 L1550 FCB 5,"NAME?" | |
2269 NAMEQ jsr DOLST | |
2270 FDB CNTXT,DUPP,DAT,XORR | |
2271 FDB QBRAN,NAMQ1 | |
2272 FDB CELLM | |
2273 NAMQ1 FDB TOR | |
2274 NAMQ2 FDB RFROM,CELLP,DUPP,TOR | |
2275 FDB AT,QDUP | |
2276 FDB QBRAN,NAMQ3 | |
2277 FDB FIND,QDUP | |
2278 FDB QBRAN,NAMQ2 | |
2279 FDB RFROM,DROP,EXIT | |
2280 NAMQ3 FDB RFROM,DROP | |
2281 FDB ZERO,EXIT | |
2282 | |
2283 ;; Terminal response | |
2284 | |
2285 ; ^H ( bot eot cur -- bot eot cur ) | |
2286 ; Backup the cursor by one character. | |
2287 | |
2288 FDB BKSP,L1550 | |
2289 L1560 FCB 2,"^H" | |
2290 BKSP jsr DOLST | |
2291 FDB TOR,OVER,RFROM,SWAP,OVER,XORR | |
2292 FDB QBRAN,BACK1 | |
2293 FDB DOLIT,BKSPP,TECHO,ATEXE,MINUS1 | |
2294 FDB BLANK,TECHO,ATEXE | |
2295 FDB DOLIT,BKSPP,TECHO,ATEXE | |
2296 BACK1 FDB EXIT | |
2297 | |
2298 ; TAP ( bot eot cur c -- bot eot cur ) | |
2299 ; Accept and echo the key stroke and bump the cursor. | |
2300 | |
2301 FDB TAP,L1560 | |
2302 L1570 FCB 3,"TAP" | |
2303 TAP jsr DOLST | |
2304 FDB DUPP,TECHO,ATEXE | |
2305 FDB OVER,CSTOR,PLUS1,EXIT | |
2306 | |
2307 ; kTAP ( bot eot cur c -- bot eot cur ) | |
2308 ; Process a key stroke, CR or backspace. | |
2309 | |
2310 FDB KTAP,L1570 | |
2311 L1580 FCB 4,"kTAP" | |
2312 KTAP jsr DOLST | |
2313 FDB DUPP,DOCLIT | |
2314 FCB CRR | |
2315 FDB XORR | |
2316 FDB QBRAN,KTAP2 | |
2317 FDB DUPP,DOLIT,BKSPP,XORR | |
2318 FDB SWAP,DOLIT,BKSPP2,XORR,ANDD | |
2319 FDB QBRAN,KTAP1 | |
2320 FDB BLANK,TAP,EXIT | |
2321 KTAP1 FDB BKSP,EXIT | |
2322 KTAP2 FDB DROP,SWAP,DROP,DUPP,EXIT | |
2323 | |
2324 ; accept ( b u -- b u ) | |
2325 ; Accept characters to input buffer. Return with actual count. | |
2326 | |
2327 FDB ACCEP,L1580 | |
2328 L1590 FCB 6,"ACCEPT" | |
2329 ACCEP jsr DOLST | |
2330 FDB OVER,PLUS,OVER | |
2331 ACCP1 FDB DDUP,XORR | |
2332 FDB QBRAN,ACCP4 | |
2333 FDB KEY,DUPP | |
2334 ; FDB BLANK,SUBB,DOLIT,95,ULESS | |
2335 FDB BLANK,DOLIT,127,WITHI | |
2336 FDB QBRAN,ACCP2 | |
2337 FDB TAP | |
2338 FDB BRAN,ACCP3 | |
2339 ACCP2 FDB TTAP,ATEXE | |
2340 ACCP3 FDB BRAN,ACCP1 | |
2341 ACCP4 FDB DROP,OVER,SUBB,EXIT | |
2342 | |
2343 ; EXPECT ( b u -- ) | |
2344 ; Accept input stream and store count in SPAN. | |
2345 | |
2346 FDB EXPEC,L1590 | |
2347 L1600 FCB 6,"EXPECT" | |
2348 EXPEC jsr DOLST | |
2349 FDB TEXPE,ATEXE,SPAN,STORE,DROP,EXIT | |
2350 | |
2351 ; QUERY ( -- ) | |
2352 ; Accept input stream to terminal input buffer. | |
2353 | |
2354 FDB QUERY,L1600 | |
2355 L1610 FCB 5,"QUERY" | |
2356 QUERY jsr DOLST | |
2357 FDB TIB,DOCLIT | |
2358 FCB 80 | |
2359 FDB TEXPE,ATEXE,NTIB,STORE | |
2360 FDB DROP,ZERO,INN,STORE,EXIT | |
2361 | |
2362 ;; Error handling | |
2363 | |
2364 ; CATCH ( ca -- 0 | err# ) | |
2365 ; Execute word at ca and set up an error frame for it. | |
2366 | |
2367 FDB CATCH,L1610 | |
2368 L1620 FCB 5,"CATCH" | |
2369 CATCH jsr DOLST | |
2370 FDB SPAT,TOR,HANDL,AT,TOR ;save error frame | |
2371 FDB RPAT,HANDL,STORE,EXECU ;execute | |
2372 FDB RFROM,HANDL,STORE ;restore error frame | |
2373 FDB RFROM,DROP,ZERO,EXIT ;no error | |
2374 | |
2375 ; THROW ( err# -- err# ) | |
2376 ; Reset system to current local error frame an update error flag. | |
2377 | |
2378 FDB THROW,L1620 | |
2379 L1630 FCB 5,"THROW" | |
2380 THROW jsr DOLST | |
2381 FDB HANDL,AT,RPSTO ;restore return stack | |
2382 FDB RFROM,HANDL,STORE ;restore handler frame | |
2383 FDB RFROM,SWAP,TOR,SPSTO ;restore data stack | |
2384 FDB DROP,RFROM,EXIT | |
2385 | |
2386 ; NULL$ ( -- a ) | |
2387 ; Return address of a null string with zero count. | |
2388 | |
2389 FDB NULLS,L1630 | |
2390 L1640 FCB 5,"NULL$" | |
2391 NULLS | |
2392 ;;;; jsr DOLST | |
2393 ;;;; FDB DOVAR ;emulate CREATE | |
2394 jsr FDOVAR | |
2395 FDB 0 | |
2396 FCB 99,111,121,111,116,101 | |
2397 | |
2398 ; ABORT ( -- ) | |
2399 ; Reset data stack and jump to QUIT. | |
2400 | |
2401 FDB ABORT,L1640 | |
2402 L1650 FCB 5,"ABORT" | |
2403 ABORT jsr DOLST | |
2404 FDB NULLS,THROW | |
2405 | |
2406 ; abort" ( f -- ) | |
2407 ; Run time routine of ABORT" . Abort with a message. | |
2408 | |
2409 FDB ABORQ,L1650 | |
2410 L1660 FCB COMPO+6,"abort",'"' | |
2411 ABORQ jsr DOLST | |
2412 FDB QBRAN,ABOR1 ;text flag | |
2413 FDB DOSTR,THROW ;pass error string | |
2414 ABOR1 FDB DOSTR,DROP,EXIT ;drop error | |
2415 | |
2416 ;; The text interpreter | |
2417 | |
2418 ; $INTERPRET ( a -- ) | |
2419 ; Interpret a word. If failed, try to convert it to an integer. | |
2420 | |
2421 FDB INTER,L1660 | |
2422 L1670 FCB 10,"$INTERPRET" | |
2423 INTER jsr DOLST | |
2424 FDB NAMEQ,QDUP ;?defined | |
2425 FDB QBRAN,INTE1 | |
2426 FDB AT,DOLIT,COMPO<<8,ANDD ;?compile only lexicon bits | |
2427 FDB ABORQ | |
2428 FCB 13," compile only" | |
2429 FDB EXECU,EXIT ;execute defined word | |
2430 INTE1 FDB TNUMB,ATEXE ;convert a number | |
2431 FDB QBRAN,INTE2 | |
2432 FDB EXIT | |
2433 INTE2 FDB THROW ;error | |
2434 | |
2435 ; [ ( -- ) | |
2436 ; Start the text interpreter. | |
2437 | |
2438 FDB LBRAC,L1670 | |
2439 L1680 FCB IMEDD+1,"[" | |
2440 LBRAC jsr DOLST | |
2441 FDB DOLIT,INTER,TEVAL,STORE,EXIT | |
2442 | |
2443 ; .OK ( -- ) | |
2444 ; Display 'ok' only while interpreting. | |
2445 | |
2446 FDB DOTOK,L1680 | |
2447 L1690 FCB 3,".OK" | |
2448 DOTOK jsr DOLST | |
2449 FDB DOLIT,INTER,TEVAL,AT,EQUAL | |
2450 FDB QBRAN,DOTO1 | |
2451 FDB DOTQP | |
2452 FCB 3," ok" | |
2453 DOTO1 FDB CR,EXIT | |
2454 | |
2455 ; ?STACK ( -- ) | |
2456 ; Abort if the data stack underflows. | |
2457 | |
2458 FDB QSTAC,L1690 | |
2459 L1700 FCB 6,"?STACK" | |
2460 QSTAC jsr DOLST | |
2461 FDB DEPTH,ZLESS ;check only for underflow | |
2462 FDB ABORQ | |
2463 FCB 10," underflow" | |
2464 FDB EXIT | |
2465 | |
2466 ; EVAL ( -- ) | |
2467 ; Interpret the input stream. | |
2468 | |
2469 FDB EVAL,L1700 | |
2470 L1710 FCB 4,"EVAL" | |
2471 EVAL jsr DOLST | |
2472 EVAL1 FDB TOKEN,DUPP,CAT ;?input stream empty | |
2473 FDB QBRAN,EVAL2 | |
2474 FDB TEVAL,ATEXE,QSTAC ;evaluate input, check stack | |
2475 FDB BRAN,EVAL1 | |
2476 EVAL2 FDB DROP,TPROM,ATEXE,EXIT ;prompt | |
2477 | |
2478 ;; Shell | |
2479 | |
2480 ; PRESET ( -- ) | |
2481 ; Reset data stack pointer and the terminal input buffer. | |
2482 | |
2483 FDB PRESE,L1710 | |
2484 L1720 FCB 6,"PRESET" | |
2485 PRESE jsr DOLST | |
2486 FDB SZERO,AT,SPSTO | |
2487 FDB DOLIT,TIBB,NTIB,CELLP,STORE,EXIT | |
2488 | |
2489 ; xio ( a a a -- ) | |
2490 ; Reset the I/O vectors 'EXPECT, 'TAP, 'ECHO and 'PROMPT. | |
2491 | |
2492 FDB XIO,L1720 | |
2493 L1730 FCB COMPO+3,"xio" | |
2494 XIO jsr DOLST | |
2495 FDB DOLIT,ACCEP,TEXPE,DSTOR | |
2496 FDB TECHO,DSTOR,EXIT | |
2497 | |
2498 ; FILE ( -- ) | |
2499 ; Select I/O vectors for file download. | |
2500 | |
2501 FDB FILE,L1730 | |
2502 L1740 FCB 4,"FILE" | |
2503 FILE jsr DOLST | |
2504 FDB DOLIT,PACE,DOLIT,DROP | |
2505 FDB DOLIT,KTAP,XIO,EXIT | |
2506 | |
2507 ; HAND ( -- ) | |
2508 ; Select I/O vectors for terminal interface. | |
2509 | |
2510 FDB HAND,L1740 | |
2511 L1750 FCB 4,"HAND" | |
2512 HAND jsr DOLST | |
2513 FDB DOLIT,DOTOK,DOLIT,EMIT | |
2514 FDB DOLIT,KTAP,XIO,EXIT | |
2515 | |
2516 ; I/O ( -- a ) | |
2517 ; Array to store default I/O vectors. | |
2518 | |
2519 FDB ISLO,L1750 | |
2520 L1760 FCB 3,"I/O" | |
2521 ISLO | |
2522 ;; jsr DOLST | |
2523 ;; FDB DOVAR ;emulate CREATE | |
2524 jsr FDOVAR | |
2525 FDB QRX,TXSTO ;default I/O vectors | |
2526 | |
2527 ; CONSOLE ( -- ) | |
2528 ; Initiate terminal interface. | |
2529 | |
2530 FDB CONSO,L1760 | |
2531 L1770 FCB 7,"CONSOLE" | |
2532 CONSO jsr DOLST | |
2533 FDB ISLO,DAT,TQKEY,DSTOR ;restore default I/O device | |
2534 FDB HAND,EXIT ;keyboard input | |
2535 | |
2536 ; QUIT ( -- ) | |
2537 ; Reset return stack pointer and start text interpreter. | |
2538 | |
2539 FDB QUIT,L1770 | |
2540 L1780 FCB 4,"QUIT" | |
2541 QUIT jsr DOLST | |
2542 FDB RZERO,AT,RPSTO ;reset return stack pointer | |
2543 QUIT1 FDB LBRAC ;start interpretation | |
2544 QUIT2 FDB QUERY ;get input | |
2545 FDB DOLIT,EVAL,CATCH,QDUP ;evaluate input | |
2546 FDB QBRAN,QUIT2 ;continue till error | |
2547 FDB TPROM,AT,TOR ;save input device | |
2548 FDB CONSO,NULLS,OVER,XORR ;?display error message | |
2549 FDB QBRAN,QUIT3 | |
2550 FDB SPACE,COUNT,TYPES ;error message | |
2551 FDB DOTQP | |
2552 FCB 3," ? " ;error prompt | |
2553 QUIT3 FDB RFROM,DOLIT,DOTOK,XORR ;?file input | |
2554 FDB QBRAN,QUIT4 | |
2555 FDB DOLIT,ERR,EMIT ;file error, tell host | |
2556 QUIT4 FDB PRESE ;some cleanup | |
2557 FDB BRAN,QUIT1 | |
2558 | |
2559 ;; The compiler | |
2560 | |
2561 ; ' ( -- ca ) | |
2562 ; Search context vocabularies for the next word in input stream. | |
2563 | |
2564 FDB TICK,L1780 | |
2565 L1790 FCB 1,"'" | |
2566 TICK jsr DOLST | |
2567 FDB TOKEN,NAMEQ ;?defined | |
2568 FDB QBRAN,TICK1 | |
2569 FDB EXIT ;yes, push code address | |
2570 TICK1 FDB THROW ;no, error | |
2571 | |
2572 ; ALLOT ( n -- ) | |
2573 ; Allocate n bytes to the code dictionary. | |
2574 | |
2575 FDB ALLOT,L1790 | |
2576 L1800 FCB 5,"ALLOT" | |
2577 ALLOT jsr DOLST | |
2578 FDB CP,PSTOR,EXIT ;adjust code pointer | |
2579 | |
2580 ; , ( w -- ) | |
2581 ; Compile an integer into the code dictionary. | |
2582 | |
2583 FDB COMMA,L1800 | |
2584 L1810 FCB 1,"," | |
2585 COMMA jsr DOLST | |
2586 FDB HERE,DUPP,CELLP ;cell boundary | |
2587 FDB CP,STORE,STORE,EXIT ;adjust code pointer and compile | |
2588 | |
2589 ; [COMPILE] ( -- ; <string> ) | |
2590 ; Compile the next immediate word into code dictionary. | |
2591 | |
2592 FDB BCOMP,L1810 | |
2593 L1820 FCB IMEDD+9,"[COMPILE]" | |
2594 BCOMP jsr DOLST | |
2595 FDB TICK,COMMA,EXIT | |
2596 | |
2597 ; COMPILE ( -- ) | |
2598 ; Compile the next address in colon list to code dictionary. | |
2599 | |
2600 FDB COMPI,L1820 | |
2601 L1830 FCB COMPO+7,"COMPILE" | |
2602 COMPI jsr DOLST | |
2603 FDB RFROM,DUPP,AT,COMMA ;compile address | |
2604 FDB CELLP,TOR,EXIT ;adjust return address | |
2605 | |
2606 ; LITERAL ( w -- ) | |
2607 ; Compile tos to code dictionary as an integer literal. | |
2608 | |
2609 FDB LITER,L1830 | |
2610 L1840 FCB IMEDD+7,"LITERAL" | |
2611 LITER jsr DOLST | |
2612 FDB COMPI,DOLIT,COMMA,EXIT | |
2613 | |
2614 ; $," ( -- ) | |
2615 ; Compile a literal string up to next " . | |
2616 | |
2617 FDB STRCQ,L1840 | |
2618 L1850 FCB 3,"$,",'"' | |
2619 STRCQ jsr DOLST | |
2620 FDB DOLIT,'"',WORD ;move string to code dictionary | |
2621 FDB COUNT,PLUS,ALGND ;calculate aligned end of string | |
2622 FDB CP,STORE,EXIT ;adjust the code pointer | |
2623 | |
2624 ; RECURSE ( -- ) | |
2625 ; Make the current word available for compilation. | |
2626 | |
2627 FDB RECUR,L1850 | |
2628 L1860 FCB IMEDD+7,"RECURSE" | |
2629 RECUR jsr DOLST | |
2630 FDB LAST,AT,NAMET,COMMA,EXIT | |
2631 | |
2632 ;; Structures | |
2633 | |
2634 ; DO ( -- a m ) | |
2635 ; Start a DO-LOOP/+LOOP structure in a colon definition. | |
2636 | |
2637 FDB DO,L1860 | |
2638 L1861 FCB IMEDD+2,"DO" | |
2639 DO jsr DOLST | |
2640 FDB COMPI,DODO,HERE | |
2641 FDB ONE ; marker for DO | |
2642 FDB EXIT | |
2643 | |
2644 ; ?DO ( -- a m ) | |
2645 ; Start a ?DO-LOOP/+LOOP structure in a colon definition. | |
2646 | |
2647 FDB QDO,L1861 | |
2648 L1862 FCB IMEDD+3,"?DO" | |
2649 QDO jsr DOLST | |
2650 FDB COMPI,DOQDO,HERE | |
2651 FDB COMPI,0 ; branch destination placeholder | |
2652 FDB TWO ; marker for ?DO | |
2653 FDB EXIT | |
2654 | |
2655 ; (?DO) ( w w -- ) | |
2656 ; Runtime part of DO in a DO-LOOP/+LOOP structure. | |
2657 | |
2658 FDB DOQDO,L1862 | |
2659 L1862A FCB 5,"(?DO)" | |
2660 DOQDO | |
2661 puls d ;start | |
2662 cmpd ,s ;start < end -> ok | |
2663 blt DOQDO1 | |
2664 leas 2,s ;drop end | |
2665 ldu ,u | |
2666 pulu pc ;branch past loop | |
2667 DOQDO1 | |
2668 puls x ;end | |
2669 stx ,--y ;end to return stack | |
2670 std ,--y ;start to return stack | |
2671 leau 2,u ;skip jump forward | |
2672 pulu pc | |
2673 | |
2674 ; -DO ( -- a m ) | |
2675 ; Start a -DO-LOOP/+LOOP structure in a colon definition. | |
2676 | |
2677 FDB MDO,L1862A | |
2678 L1862B FCB IMEDD+3,"-DO" | |
2679 MDO jsr DOLST | |
2680 FDB COMPI,DOMDO,HERE | |
2681 FDB COMPI,0 ; branch destination placeholder | |
2682 FDB TWO ; marker for ?DO/-DO | |
2683 FDB EXIT | |
2684 | |
2685 ; (-DO) ( w w -- ) | |
2686 ; Runtime part of -DO in a -DO-LOOP/+LOOP structure. | |
2687 | |
2688 FDB DOMDO,L1862B | |
2689 L1862C FCB 5,"(-DO)" | |
2690 DOMDO | |
2691 puls d ;start | |
2692 cmpd ,s ;start > end -> ok | |
2693 bgt DOMDO1 | |
2694 leas 2,s ;drop end | |
2695 ldu ,u | |
2696 pulu pc ;branch past loop | |
2697 DOMDO1 | |
2698 puls x ;end | |
2699 stx ,--y ;end to return stack | |
2700 std ,--y ;start to return stack | |
2701 leau 2,u ;skip jump forward | |
2702 pulu pc | |
2703 | |
2704 ; (DO) ( w w -- ) | |
2705 ; Runtime part of DO in a DO-LOOP/+LOOP structure. | |
2706 | |
2707 FDB DODO,L1862C | |
2708 L1863 FCB 4,"(DO)" | |
2709 DODO | |
2710 puls d,x ;start first, end second | |
2711 stx ,--y ;end to return stack | |
2712 std ,--y ;start to return stack | |
2713 pulu pc | |
2714 | |
2715 ; (LOOP) ( -- ) | |
2716 ; Runtime part of LOOP | |
2717 | |
2718 FDB DOLOOP,L1863 | |
2719 L1864 FCB 6,"(LOOP)" | |
2720 DOLOOP | |
2721 ldd #1 | |
2722 bra DOPLOF | |
2723 | |
2724 ; (+LOOP) ( -- ) | |
2725 ; Runtime part of +LOOP | |
2726 | |
2727 FDB DOPLOOP,L1864 | |
2728 L1865 FCB IMEDD+7,"(+LOOP)" | |
2729 DOPLOOP | |
2730 ldd ,s++ ; increment | |
2731 bpl DOPLOF ; forward | |
2732 addd ,y ; start/index | |
2733 cmpd 2,y ; end | |
2734 ble DOPLO1 ; index <= end -> leave | |
2735 std ,y | |
2736 ldu ,u ; branch to begin of loop | |
2737 pulu pc | |
2738 | |
2739 DOPLOF addd ,y ; start/index | |
2740 cmpd 2,y ; end | |
2741 bge DOPLO1 ; index >= end -> leave | |
2742 std ,y ; save back | |
2743 ldu ,u ; branch to begin of loop | |
2744 pulu pc | |
2745 DOPLO1 | |
2746 leau 2,u ; skip back destination | |
2747 leay 4,y ; remove index and upper from r stack | |
2748 pulu pc | |
2749 | |
2750 ; LOOP ( a m -- ) | |
2751 ; Terminate a DO/?DO-LOOP loop structure. | |
2752 | |
2753 FDB LOOP,L1865 | |
2754 L1866 FCB IMEDD+4,"LOOP" | |
2755 LOOP jsr DOLST | |
2756 FDB COMPI,DOLOOP | |
2757 FDB TWO,EQUAL,QBRAN,LOOP1 | |
2758 FDB HERE,CELLP,OVER,STORE,CELLP ; branch forward destination | |
2759 LOOP1 FDB COMMA,EXIT | |
2760 | |
2761 | |
2762 ; +LOOP ( a m -- ) | |
2763 ; Terminate a DO/?DO-+LOOP loop structure. | |
2764 | |
2765 FDB PLOOP,L1866 | |
2766 L1867 FCB IMEDD+5,"+LOOP" | |
2767 PLOOP jsr DOLST | |
2768 FDB COMPI,DOPLOOP | |
2769 FDB TWO,EQUAL,QBRAN,PLOOP1 | |
2770 FDB HERE,CELLP,OVER,STORE,CELLP ; branch forward destination | |
2771 PLOOP1 FDB COMMA,EXIT | |
2772 | |
2773 ; LEAVE ( -- ) | |
2774 ; Leave DO/LOOP | |
2775 | |
2776 FDB LEAVE,L1867 | |
2777 L1868 FCB 5,"LEAVE" | |
2778 LEAVE | |
2779 ldd ,y ;take index on return stack | |
2780 std 2,y ;and change end to it | |
2781 pulu pc | |
2782 | |
2783 ; FOR ( -- a ) | |
2784 ; Start a FOR-NEXT loop structure in a colon definition. | |
2785 | |
2786 FDB FOR,L1867 | |
2787 L1870 FCB IMEDD+3,"FOR" | |
2788 FOR jsr DOLST | |
2789 FDB COMPI,TOR,HERE,EXIT | |
2790 | |
2791 ; BEGIN ( -- a ) | |
2792 ; Start an infinite or indefinite loop structure. | |
2793 | |
2794 FDB BEGIN,L1870 | |
2795 L1880 FCB IMEDD+5,"BEGIN" | |
2796 BEGIN jsr DOLST | |
2797 FDB HERE,EXIT | |
2798 | |
2799 ; NEXT ( a -- ) | |
2800 ; Terminate a FOR-NEXT loop structure. | |
2801 | |
2802 FDB NEXT,L1880 | |
2803 L1890 FCB IMEDD+4,"NEXT" | |
2804 NEXT jsr DOLST | |
2805 FDB COMPI,DONXT,COMMA,EXIT | |
2806 | |
2807 ; UNTIL ( a -- ) | |
2808 ; Terminate a BEGIN-UNTIL indefinite loop structure. | |
2809 | |
2810 FDB UNTIL,L1890 | |
2811 L1900 FCB IMEDD+5,"UNTIL" | |
2812 UNTIL jsr DOLST | |
2813 FDB COMPI,QBRAN,COMMA,EXIT | |
2814 | |
2815 ; AGAIN ( a -- ) | |
2816 ; Terminate a BEGIN-AGAIN infinite loop structure. | |
2817 | |
2818 FDB AGAIN,L1900 | |
2819 L1910 FCB IMEDD+5,"AGAIN" | |
2820 AGAIN jsr DOLST | |
2821 FDB COMPI,BRAN,COMMA,EXIT | |
2822 | |
2823 ; IF ( -- A ) | |
2824 ; Begin a conditional branch structure. | |
2825 | |
2826 FDB IFF,L1910 | |
2827 L1920 FCB IMEDD+2,"IF" | |
2828 IFF jsr DOLST | |
2829 FDB COMPI,QBRAN,HERE | |
2830 FDB ZERO,COMMA,EXIT | |
2831 | |
2832 ; AHEAD ( -- A ) | |
2833 ; Compile a forward branch instruction. | |
2834 | |
2835 FDB AHEAD,L1920 | |
2836 L1930 FCB IMEDD+5,"AHEAD" | |
2837 AHEAD jsr DOLST | |
2838 FDB COMPI,BRAN,HERE,ZERO,COMMA,EXIT | |
2839 | |
2840 ; REPEAT ( A a -- ) | |
2841 ; Terminate a BEGIN-WHILE-REPEAT indefinite loop. | |
2842 | |
2843 FDB REPEA,L1930 | |
2844 L1940 FCB IMEDD+6,"REPEAT" | |
2845 REPEA jsr DOLST | |
2846 FDB AGAIN,HERE,SWAP,STORE,EXIT | |
2847 | |
2848 ; THEN ( A -- ) | |
2849 ; Terminate a conditional branch structure. | |
2850 | |
2851 FDB THENN,L1940 | |
2852 L1950 FCB IMEDD+4,"THEN" | |
2853 THENN jsr DOLST | |
2854 FDB HERE,SWAP,STORE,EXIT | |
2855 | |
2856 ; AFT ( a -- a A ) | |
2857 ; Jump to THEN in a FOR-AFT-THEN-NEXT loop the first time through. | |
2858 | |
2859 FDB AFT,L1950 | |
2860 L1960 FCB IMEDD+3,"AFT" | |
2861 AFT jsr DOLST | |
2862 FDB DROP,AHEAD,BEGIN,SWAP,EXIT | |
2863 | |
2864 ; ELSE ( A -- A ) | |
2865 ; Start the false clause in an IF-ELSE-THEN structure. | |
2866 | |
2867 FDB ELSEE,L1960 | |
2868 L1970 FCB IMEDD+4,"ELSE" | |
2869 ELSEE jsr DOLST | |
2870 FDB AHEAD,SWAP,THENN,EXIT | |
2871 | |
2872 ; WHILE ( a -- A a ) | |
2873 ; Conditional branch out of a BEGIN-WHILE-REPEAT loop. | |
2874 | |
2875 FDB WHILE,L1970 | |
2876 L1980 FCB IMEDD+5,"WHILE" | |
2877 WHILE jsr DOLST | |
2878 FDB IFF,SWAP,EXIT | |
2879 | |
2880 ; ABORT" ( -- ; <string> ) | |
2881 ; Conditional abort with an error message. | |
2882 | |
2883 FDB ABRTQ,L1980 | |
2884 L1990 FCB IMEDD+6,"ABORT",'"' | |
2885 ABRTQ jsr DOLST | |
2886 FDB COMPI,ABORQ,STRCQ,EXIT | |
2887 | |
2888 ; $" ( -- ; <string> ) | |
2889 ; Compile an inline string literal. | |
2890 | |
2891 FDB STRQ,L1990 | |
2892 L2000 FCB IMEDD+2,'$','"' | |
2893 STRQ jsr DOLST | |
2894 FDB COMPI,STRQP,STRCQ,EXIT | |
2895 | |
2896 ; ." ( -- ; <string> ) | |
2897 ; Compile an inline string literal to be typed out at run time. | |
2898 | |
2899 FDB DOTQ,L2000 | |
2900 L2010 FCB IMEDD+2,'.','"' | |
2901 DOTQ jsr DOLST | |
2902 FDB COMPI,DOTQP,STRCQ,EXIT | |
2903 | |
2904 ;; Name compiler | |
2905 | |
2906 ; ?UNIQUE ( a -- a ) | |
2907 ; Display a warning message if the word already exists. | |
2908 | |
2909 FDB UNIQU,L2010 | |
2910 L2020 FCB 7,"?UNIQUE" | |
2911 UNIQU jsr DOLST | |
2912 FDB DUPP,NAMEQ ;?name exists | |
2913 FDB QBRAN,UNIQ1 | |
2914 FDB DOTQP ;redefinitions are OK | |
2915 FCB 7," reDef " ;but the user should be warned | |
2916 FDB OVER,COUNT,TYPES ;just in case its not planned | |
2917 UNIQ1 FDB DROP,EXIT | |
2918 | |
2919 ; $,n ( na -- ) | |
2920 ; Build a new dictionary name using the string at na. | |
2921 | |
2922 FDB SNAME,L2020 | |
2923 L2030 FCB 3,"$,n" | |
2924 SNAME jsr DOLST | |
2925 FDB DUPP,CAT ;?null input | |
2926 FDB QBRAN,PNAM1 | |
2927 FDB UNIQU ;?redefinition | |
2928 FDB DUPP,LAST,STORE ;save na for vocabulary link | |
2929 FDB HERE,ALGND,SWAP ;align code address | |
2930 FDB CELLM ;link address | |
2931 FDB CRRNT,AT,AT,OVER,STORE | |
2932 FDB CELLM,DUPP,NP,STORE ;adjust name pointer | |
2933 FDB STORE,EXIT ;save code pointer | |
2934 PNAM1 FDB STRQP | |
2935 FCB 5," name" ;null input | |
2936 FDB THROW | |
2937 | |
2938 ;; FORTH compiler | |
2939 | |
2940 ; $COMPILE ( a -- ) | |
2941 ; Compile next word to code dictionary as a token or literal. | |
2942 | |
2943 FDB SCOMP,L2030 | |
2944 L2040 FCB 8,"$COMPILE" | |
2945 SCOMP jsr DOLST | |
2946 FDB NAMEQ,QDUP ;?defined | |
2947 FDB QBRAN,SCOM2 | |
2948 FDB AT,DOLIT,IMEDD<<8,ANDD ;?immediate | |
2949 FDB QBRAN,SCOM1 | |
2950 FDB EXECU,EXIT ;its immediate, execute | |
2951 SCOM1 FDB COMMA,EXIT ;its not immediate, compile | |
2952 SCOM2 FDB TNUMB,ATEXE ;try to convert to number | |
2953 FDB QBRAN,SCOM3 | |
2954 FDB LITER,EXIT ;compile number as integer | |
2955 SCOM3 FDB THROW ;error | |
2956 | |
2957 ; OVERT ( -- ) | |
2958 ; Link a new word into the current vocabulary. | |
2959 | |
2960 FDB OVERT,L2040 | |
2961 L2050 FCB 5,"OVERT" | |
2962 OVERT jsr DOLST | |
2963 FDB LAST,AT,CRRNT,AT,STORE,EXIT | |
2964 | |
2965 ; ; ( -- ) | |
2966 ; Terminate a colon definition. | |
2967 | |
2968 FDB SEMIS,L2050 | |
2969 L2060 FCB IMEDD+COMPO+1,";" | |
2970 SEMIS jsr DOLST | |
2971 FDB COMPI,EXIT,LBRAC,OVERT,EXIT | |
2972 | |
2973 ; ] ( -- ) | |
2974 ; Start compiling the words in the input stream. | |
2975 | |
2976 FDB RBRAC,L2060 | |
2977 L2070 FCB 1,"]" | |
2978 RBRAC jsr DOLST | |
2979 FDB DOLIT,SCOMP,TEVAL,STORE,EXIT | |
2980 | |
2981 ; call, ( ca -- ) | |
2982 ; Assemble a call instruction to ca. | |
2983 | |
2984 FDB CALLC,L2070 | |
2985 L2080 FCB 5,"call," | |
2986 CALLC jsr DOLST | |
2987 FDB DOCLIT | |
2988 FCB CALLL | |
2989 FDB HERE,CSTOR ;Direct Threaded Code | |
2990 FDB ONE,ALLOT | |
2991 FDB COMMA,EXIT ;DTC 6809 extended addr jsr | |
2992 | |
2993 ; : ( -- ; <string> ) | |
2994 ; Start a new colon definition using next word as its name. | |
2995 | |
2996 FDB COLON,L2080 | |
2997 L2090 FCB 1,":" | |
2998 COLON jsr DOLST | |
2999 FDB TOKEN,SNAME,DOLIT,DOLST | |
3000 FDB CALLC,RBRAC,EXIT | |
3001 | |
3002 ; IMMEDIATE ( -- ) | |
3003 ; Make the last compiled word an immediate word. | |
3004 | |
3005 FDB IMMED,L2090 | |
3006 L2100 FCB 9,"IMMEDIATE" | |
3007 IMMED jsr DOLST | |
3008 FDB DOLIT,IMEDD<<8,LAST,AT,AT,ORR | |
3009 FDB LAST,AT,STORE,EXIT | |
3010 | |
3011 ;; Defining words | |
3012 | |
3013 ; USER ( u -- ; <string> ) | |
3014 ; Compile a new user variable. | |
3015 | |
3016 FDB USER,L2100 | |
3017 L2110 FCB 4,"USER" | |
3018 USER jsr DOLST | |
3019 FDB TOKEN,SNAME,OVERT | |
3020 ;;;; FDB DOLIT,DOLST,CALLC | |
3021 ;;;; FDB DOLIT,DOUSE,COMMA | |
3022 ; fast implementation .... | |
3023 FDB DOLIT,FDOUSE,CALLC | |
3024 FDB COMMA,EXIT | |
3025 | |
3026 ; CREATE ( -- ; <string> ) | |
3027 ; Compile a new array entry without allocating code space. | |
3028 | |
3029 FDB CREAT,L2110 | |
3030 L2120 FCB 6,"CREATE" | |
3031 CREAT jsr DOLST | |
3032 FDB TOKEN,SNAME,OVERT | |
3033 ;;;; FDB DOLIT,DOLST,CALLC | |
3034 ;;;; FDB DOLIT,DOVAR,COMMA,EXIT | |
3035 ; fast implementation .... | |
3036 FDB DOLIT,FDOVAR,CALLC,EXIT | |
3037 | |
3038 ; VARIABLE ( -- ; <string> ) | |
3039 ; Compile a new variable initialized to 0. | |
3040 | |
3041 FDB VARIA,L2120 | |
3042 L2130 FCB 8,"VARIABLE" | |
3043 VARIA jsr DOLST | |
3044 FDB CREAT,ZERO,COMMA,EXIT | |
3045 | |
3046 ; CONSTANT ( w -- ; <string> ) | |
3047 ; Compile a new constant with value w. | |
3048 | |
3049 FDB CONST,L2130 | |
3050 L2135 FCB 8,"CONSTANT" | |
3051 CONST jsr DOLST | |
3052 FDB TOKEN,SNAME,OVERT | |
3053 FDB DOLIT,DOCONST,CALLC | |
3054 FDB COMMA,EXIT | |
3055 | |
3056 ;; Tools | |
3057 | |
3058 ; _TYPE ( b u -- ) | |
3059 ; Display a string. Filter non-printing characters. | |
3060 | |
3061 FDB UTYPE,L2135 | |
3062 L2140 FCB 5,"_TYPE" | |
3063 UTYPE jsr DOLST | |
3064 FDB TOR ;start count down loop | |
3065 FDB BRAN,UTYP2 ;skip first pass | |
3066 UTYP1 FDB DUPP,CAT,TCHAR,EMIT ;display only printable | |
3067 FDB PLUS1 ;increment address | |
3068 UTYP2 FDB DONXT,UTYP1 ;loop till done | |
3069 FDB DROP,EXIT | |
3070 | |
3071 ; dm+ ( a u -- a ) | |
3072 ; Dump u bytes from , leaving a+u on the stack. | |
3073 | |
3074 FDB DUMPP,L2140 | |
3075 L2150 FCB 3,"dm+" | |
3076 DUMPP jsr DOLST | |
3077 FDB OVER,DOLIT,4,UDOTR ;display address | |
3078 FDB SPACE,TOR ;start count down loop | |
3079 FDB BRAN,PDUM2 ;skip first pass | |
3080 PDUM1 FDB DUPP,CAT,DOLIT,3,UDOTR ;display numeric data | |
3081 FDB PLUS1 ;increment address | |
3082 PDUM2 FDB DONXT,PDUM1 ;loop till done | |
3083 FDB EXIT | |
3084 | |
3085 ; DUMP ( a u -- ) | |
3086 ; Dump u bytes from a, in a formatted manner. | |
3087 | |
3088 FDB DUMP,L2150 | |
3089 L2160 FCB 4,"DUMP" | |
3090 DUMP jsr DOLST | |
3091 FDB BASE,AT,TOR,HEX ;save radix, set hex | |
3092 FDB DOCLIT | |
3093 FCB 16 | |
3094 FDB SLASH ;change count to lines | |
3095 FDB TOR ;start count down loop | |
3096 DUMP1 FDB CR,DOCLIT | |
3097 FCB 16 | |
3098 FDB DDUP,DUMPP ;display numeric | |
3099 FDB ROT,ROT | |
3100 FDB TWO,SPACS,UTYPE ;display printable characters | |
3101 FDB NUFQ,INVER ;user control | |
3102 FDB QBRAN,DUMP2 | |
3103 FDB DONXT,DUMP1 ;loop till done | |
3104 FDB BRAN,DUMP3 | |
3105 DUMP2 FDB RFROM,DROP ;cleanup loop stack, early exit | |
3106 DUMP3 FDB DROP,RFROM,BASE,STORE ;restore radix | |
3107 FDB EXIT | |
3108 | |
3109 ; .S ( ... -- ... ) | |
3110 ; Display the contents of the data stack. | |
3111 | |
3112 FDB DOTS,L2160 | |
3113 L2170 FCB 2,".S" | |
3114 DOTS jsr DOLST | |
3115 FDB CR,DEPTH ;stack depth | |
3116 FDB TOR ;start count down loop | |
3117 FDB BRAN,DOTS2 ;skip first pass | |
3118 DOTS1 FDB RAT,PICK,DOT ;index stack, display contents | |
3119 DOTS2 FDB DONXT,DOTS1 ;loop till done | |
3120 FDB DOTQP | |
3121 FCB 4," <sp" | |
3122 FDB EXIT | |
3123 | |
3124 ; !CSP ( -- ) | |
3125 ; Save stack pointer in CSP for error checking. | |
3126 | |
3127 FDB STCSP,L2170 | |
3128 L2180 FCB 4,"!CSP" | |
3129 STCSP jsr DOLST | |
3130 FDB SPAT,CSP,STORE,EXIT ;save pointer | |
3131 | |
3132 ; ?CSP ( -- ) | |
3133 ; Abort if stack pointer differs from that saved in CSP. | |
3134 | |
3135 FDB QCSP,L2180 | |
3136 L2190 FCB 4,"?CSP" | |
3137 QCSP jsr DOLST | |
3138 FDB SPAT,CSP,AT,XORR ;compare pointers | |
3139 FDB ABORQ ;abort if different | |
3140 FCB 6,"stacks" | |
3141 FDB EXIT | |
3142 | |
3143 ; >NAME ( ca -- na | F ) | |
3144 ; Convert code address to a name address. | |
3145 | |
3146 FDB TNAME,L2190 | |
3147 L2200 FCB 5,">NAME" | |
3148 TNAME jsr DOLST | |
3149 FDB CRRNT ;vocabulary link | |
3150 TNAM1 FDB CELLP,AT,QDUP ;check all vocabularies | |
3151 FDB QBRAN,TNAM4 | |
3152 FDB DDUP | |
3153 TNAM2 FDB AT,DUPP ;?last word in a vocabulary | |
3154 FDB QBRAN,TNAM3 | |
3155 FDB DDUP,NAMET,XORR ;compare | |
3156 FDB QBRAN,TNAM3 | |
3157 FDB CELLM ;continue with next word | |
3158 FDB BRAN,TNAM2 | |
3159 TNAM3 FDB SWAP,DROP,QDUP | |
3160 FDB QBRAN,TNAM1 | |
3161 FDB SWAP,DROP,SWAP,DROP,EXIT | |
3162 TNAM4 FDB DROP,DOLIT,0,EXIT | |
3163 | |
3164 ; .ID ( na -- ) | |
3165 ; Display the name at address. | |
3166 | |
3167 FDB DOTID,L2200 | |
3168 L2210 FCB 3,".ID" | |
3169 DOTID jsr DOLST | |
3170 FDB QDUP ;if zero no name | |
3171 FDB QBRAN,DOTI1 | |
3172 FDB COUNT,DOCLIT | |
3173 FCB $1F | |
3174 FDB ANDD ;mask lexicon bits | |
3175 FDB UTYPE,EXIT ;display name string | |
3176 DOTI1 FDB DOTQP | |
3177 FCB 9," {noName}" | |
3178 FDB EXIT | |
3179 | |
3180 ; SEE ( -- ; <string> ) | |
3181 ; A simple decompiler. | |
3182 | |
3183 FDB SEE,L2210 | |
3184 L2220 FCB 3,"SEE" | |
3185 SEE jsr DOLST | |
3186 FDB TICK ;starting address | |
3187 FDB PLUS1 ;skip JSR | |
3188 ;primitive check ... | |
3189 FDB BASE,AT,TOR,HEX ;switch to hex base | |
3190 FDB DUPP,AT,DOLIT,DOLST,XORR | |
3191 ;high level word? | |
3192 FDB QBRAN,SEE1 ;yes! | |
3193 FDB CR,DOTQP ;primitive word only | |
3194 FCB 9, " PRIMITVE" | |
3195 FDB BRAN,SEE5 ;exit | |
3196 SEE1 FDB CR,CELLP,DUPP,UDOT,SPACE | |
3197 FDB DUPP,AT,DUPP ;?does it contain a zero | |
3198 FDB QBRAN,SEE2 | |
3199 FDB TNAME ;?is it a name | |
3200 SEE2 FDB QDUP ;name address or zero | |
3201 FDB QBRAN,SEE3 | |
3202 | |
3203 FDB SPACE,DOTID ;display name | |
3204 FDB DUPP,AT | |
3205 | |
3206 FDB DUPP,DOLIT,DOCLIT,EQUAL ; doCLIT? | |
3207 FDB QBRAN,SEE21 | |
3208 FDB OVER,CELLP,CAT,SPACE,UDOT ; CLIT: get only single byte | |
3209 FDB SWAP,PLUS1,SWAP | |
3210 FDB BRAN,SEE28 | |
3211 | |
3212 SEE21 FDB DUPP,DOLIT,DOLIT,EQUAL ; doCLIT? | |
3213 FDB OVER,DOLIT,QBRAN,EQUAL,ORR ; ?BRAN ? | |
3214 FDB OVER,DOLIT,BRAN,EQUAL,ORR; BRANCH ? | |
3215 FDB OVER,DOLIT,DONXT,EQUAL,ORR; next ? (from FOR/NEXT) | |
3216 FDB OVER,DOLIT,DOLOOP,EQUAL,ORR; (LOOP) ? | |
3217 FDB OVER,DOLIT,DOPLOOP,EQUAL,ORR; (+LOOP) ? | |
3218 FDB OVER,DOLIT,DODO,EQUAL,ORR; (DO) ? | |
3219 FDB OVER,DOLIT,DOQDO,EQUAL,ORR; (?DO) ? | |
3220 FDB OVER,DOLIT,DOMDO,EQUAL,ORR; (-DO) ? | |
3221 FDB QBRAN,SEE27 | |
3222 FDB SWAP,CELLP,DUPP,AT,SPACE,UDOT,SWAP ; LIT: get word | |
3223 FDB BRAN,SEE28 | |
3224 SEE27 | |
3225 FDB DUPP,DOLIT,DOTQP,EQUAL ; ." ..." | |
3226 FDB OVER,DOLIT,ABORQ,EQUAL,ORR ; ABORT" ..." | |
3227 FDB OVER,DOLIT,STRQP,EQUAL,ORR ; $" ..." | |
3228 FDB QBRAN,SEE29 ; last case aalway to SEE29!! | |
3229 FDB SWAP,CELLP ; print compiled string | |
3230 FDB DUPP,COUNT,TYPES,DOCLIT | |
3231 FCB 34 | |
3232 FDB EMIT | |
3233 FDB COUNT,PLUS,CELLM,SWAP ; adjust continuation address | |
3234 | |
3235 SEE28 FDB DROP ; LEAVL, without EXIT check | |
3236 FDB BRAN,SEE4 | |
3237 SEE29 FDB DROP ; ELSE | |
3238 FDB BRAN,SEE31 ; cleanup, check for EXIT | |
3239 | |
3240 SEE3 FDB DUPP,AT,UDOT ;display number | |
3241 FDB BRAN,SEE4 | |
3242 SEE31 FDB DUPP,AT,DOLIT,EXIT,XORR ; stop on EXIT word | |
3243 ; but not if SEE decompiles itself! | |
3244 FDB QBRAN,SEE5 | |
3245 SEE4 FDB NUFQ ;user control | |
3246 FDB QBRAN,SEE1 | |
3247 SEE5 FDB RFROM,BASE,STORE,DROP,EXIT | |
3248 | |
3249 ; WORDS ( -- ) | |
3250 ; Display the names in the context vocabulary. | |
3251 | |
3252 FDB WORDS,L2220 | |
3253 L2230 FCB 5,"WORDS" | |
3254 WORDS jsr DOLST | |
3255 FDB CR,CNTXT,AT ;only in context | |
3256 WORS1 FDB AT,QDUP ;?at end of list | |
3257 FDB QBRAN,WORS2 | |
3258 FDB DUPP,SPACE,DOTID ;display a name | |
3259 FDB CELLM,NUFQ ;user control | |
3260 FDB QBRAN,WORS1 | |
3261 FDB DROP | |
3262 WORS2 FDB EXIT | |
3263 | |
3264 ;; Hardware reset | |
3265 | |
3266 ; VER ( -- n ) | |
3267 ; Return the version number of this implementation. | |
3268 | |
3269 FDB VERSN,L2230 | |
3270 L2240 FCB 3,"VER" | |
3271 VERSN jsr DOLST | |
3272 FDB DOLIT,VER*256+EXT,EXIT | |
3273 | |
3274 ; hi ( -- ) | |
3275 ; Display the sign-on message of eForth. | |
3276 | |
3277 FDB HI,L2240 | |
3278 L2250 FCB 2,"hi" | |
3279 HI jsr DOLST | |
3280 FDB STOIO,CR,DOTQP ;initialize I/O | |
3281 FCB 11,"eForth v" ;model | |
3282 FCB VER+'0','.',EXT+'0' ;version | |
3283 FDB CR,EXIT | |
3284 | |
3285 ; 'BOOT ( -- a ) | |
3286 ; The application startup vector. | |
3287 | |
3288 FDB TBOOT,L2250 | |
3289 L2260 FCB 5,"'BOOT" | |
3290 TBOOT | |
3291 ;;;; jsr DOLST | |
3292 ;;;; FDB DOVAR | |
3293 jsr FDOVAR | |
3294 FDB HI ;application to boot | |
3295 | |
3296 ; COLD ( -- ) | |
3297 ; The hilevel cold start sequence. | |
3298 | |
3299 FDB COLD,L2260 | |
3300 L2270 FCB 4,"COLD" | |
3301 COLD jsr DOLST | |
3302 COLD1 FDB DOLIT,UZERO,DOLIT,UPP | |
3303 FDB DOLIT,ULAST-UZERO,CMOVE ;initialize user area | |
3304 FDB PRESE ;initialize data stack and TIB | |
3305 FDB TBOOT,ATEXE ;application boot | |
3306 FDB FORTH,CNTXT,AT,DUPP ;initialize search order | |
3307 FDB CRRNT,DSTOR,OVERT | |
3308 ; TEST | |
3309 ; FDB DOLIT,10,DOLIT,1 | |
3310 ; FDB DODO | |
3311 ; | |
3312 FDB QUIT ;start interpretation | |
3313 FDB BRAN,COLD1 ;just in case | |
3314 | |
3315 ;=============================================================== | |
3316 | |
3317 LASTN EQU L2270 ;last name address in name dictionary | |
3318 | |
3319 NTOP EQU NAMEE ;next available memory in name dictionary | |
3320 CTOP EQU * ;next available memory in code dictionary | |
3321 | |
3322 | |
3323 END ORIG | |
3324 | |
3325 ;=============================================================== | |
3326 |