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