| blob | 8d42260788497cb1ab392f5a10a93ebd3e4113b6 |
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; dsFORTH v0.0.1
3 ;; based on AberSoft FIG-Forth v1.1A
4 ;; restored & partially rewritten by Ketmar
5 ;; distribution terms: GNU GPL v3
6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 ;; dedicated to Enota
8 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9 ;; excuse me my English, i'm not a native speaker
10 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
11 ;; the code has to be optimized!!!
12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
13 DEFFMT SCLBOOT
15 USE_SMALL_MULDIV EQU 0
17 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
18 ;; word format:
19 ;; db len_flags
20 ;; name
21 ;; dw lfa
22 ;; dw cfa
23 ;; ....
24 ;; len_flags:
25 ;; bits 0-4: length
26 ;; bit 5: SMUDGE flag (=1: word definition isn't finished)
27 ;; bit 6: IMMEDIATE flag (=1: true)
28 ;; bit 7: always 1
29 ;; the last byte of the name always has bit 7 set
30 ;;
31 ;; for CODE words: cfa points to the body
32 ;; for FORTH words: cfa points to "_doforth"
33 ;; for CONST words: cfa points to "_doconst"
34 ;; for VAR words: cfa points to "_dovar"
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
38 ;; tech info
39 ;; registers:
40 ;; BC: address interpreter insrtuction pointer
41 ;; IX: USER-var base
42 ;; IY: used by ROM, do not change
43 ;; all other regs are free
44 ;;
45 ;; stacks:
46 ;; data stack: machine stask (PUSH/POP)
47 ;; exec stack: address with f_curRP (last item)
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
51 org #6000
52 ;; start address: #6000
53 run_cold:
54 di
55 jp run_0 ;; DO NOT CHANGE THIS TO JR!
56 run_warm:
57 di
58 ld bc,WARMbody
59 jr run_1
60 run_0:
61 ;; k8: test for 128k
62 push bc
63 ; save byte at #C000 for 48K
64 ld a,(#C000)
65 ex af,af'
66 ; check for 128K
67 ld hl,#4000
68 xor a
69 ; reset #C000
70 ld (#C000),a
71 ld (hl),a
72 ld bc,#7FFD
73 ld a,#15
74 out (c),a ;; now #C000 should be the screen page #5
75 ld (#C000),a ;; trash it
76 ld a,#10
77 out (c),a ;; and go back (just in case) %-)
78 ld a,(hl)
79 or a ;; now check if we really trashed the scrren
80 jr z,run_ok48
81 ld a,1
82 run_ok48:
83 ld (f_is128K),a
84 ; restore #C000
85 ex af,af'
86 ld (#C000),a
87 ld a,#08
88 ld (#5C6A),a ; CAPS
89 ld a,#3F
90 ld i,a
91 im 1
92 ld bc,COLDbody
93 run_1:
94 ld ix,(f_userBASE)
95 ld hl,(f_initSP)
96 ld sp,hl
97 ei
98 jr i_next
100 ;;;;;;;;;;;;;;; VARIABLES
101 ;; current RP
103 f_is128K: defb 0
104 f_cur7FFD: defb #10
105 f_curRP: defw #D7AE ;; ???
107 ;; address of the first "user" variable (def: run_cold-64)
108 f_userBASE: defw #D7B0
110 f_tib: defs 50,0
112 f_userDEF:
113 f_initSP:
114 defw #D600 ;; S0: starting SP. SP grows to addr #0000
115 defw #D7AE ;; R0: starting RP. RP grows to addr #0000
116 defw f_tib ;; TIB
117 defw 31 ;; WIDTH
118 defw 0 ;; WARNING
119 defw latest_byte ;; FENCE
120 defw latest_byte ;; DP
121 defw forth_voc_link ;; VOC-LINK
122 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
124 ;;; address interpreter
125 ;; AberSoft
126 i_pushde:
127 push de
128 i_pushhl:
129 push hl
130 i_next:
131 ld a,(bc)
132 inc bc
133 ld l,a
134 ld a,(bc)
135 inc bc
136 ld h,a
137 iexecx:
138 ld e,(hl)
139 inc hl
140 ld d,(hl)
141 ex de,hl
142 ; debug label
143 i_next_jmp:
144 jp (hl)
145 ;;; end of address interpreter
148 $FORTH_CONST (.NEXT) i_next
149 $FORTH_CONST (.PUSHHL) i_pushhl
150 $FORTH_CONST (.PUSHDEHL) i_pushde
151 $FORTH_CONST (@CUR-RP) f_curRP
152 $FORTH_CONST (@CUR-BASE) f_userBASE
153 $FORTH_CONST (LAST-7FFD) f_cur7FFD
156 $FORTH_CODE_WORD LIT
157 ;; AberSoft
158 ld a,(bc)
159 inc bc
160 ld l,a
161 ld a,(bc)
162 inc bc
163 ld h,a
164 jp i_pushhl
165 $FORTH_END_CODE_WORD LIT
167 $FORTH_CODE_WORD EXECUTE
168 ;; AberSoft
169 ;; ( cfa )
170 pop hl
171 jp iexecx
172 $FORTH_END_CODE_WORD EXECUTE
174 $FORTH_CODE_WORD BRANCH FBRANCH
175 ;; AberSoft
176 BRANCHbody:
177 ld h,b
178 ld l,c
179 ld e,(hl)
180 inc hl
181 ld d,(hl)
182 dec hl
183 add hl,de
184 ld c,l
185 ld b,h
186 jp i_next
187 $FORTH_END_CODE_WORD BRANCH
189 $FORTH_CODE_WORD 0BRANCH FBRANCH
190 ;; AberSoft
191 pop hl
192 ld a,l
193 or h
194 jr z,BRANCHbody
195 branchskip:
196 inc bc
197 inc bc
198 jp i_next
199 $FORTH_END_CODE_WORD 0BRANCH
201 $FORTH_CODE_WORD TBRANCH FBRANCH
202 ;; k8
203 pop hl
204 ld a,l
205 or h
206 jr nz,BRANCHbody
207 jr branchskip
208 $FORTH_END_CODE_WORD TBRANCH
210 $FORTH_CODE_WORD (LOOP) FBRANCH
211 ;; AberSoft
212 ld de,1
213 xloop:
214 ld hl,(f_curRP)
215 ld a,(hl)
216 add a,e
217 ld (hl),a
218 ld e,a
219 inc hl
220 ld a,(hl)
221 adc a,d
222 ld (hl),a
223 inc hl
224 inc d
225 dec d
226 ld d,a
227 jp m,xloop0
228 ld a,e
229 sub (hl)
230 ld a,d
231 inc hl
232 sbc a,(hl)
233 jr xloop1
234 xloop0:
235 ld a,(hl)
236 sub e
237 inc hl
238 ld a,(hl)
239 sbc a,d
240 xloop1:
241 jp m,BRANCHbody
242 inc hl
243 ld (f_curRP),hl
244 inc bc
245 inc bc
246 jp i_next
247 $FORTH_END_CODE_WORD (LOOP)
249 $FORTH_CODE_WORD (+LOOP) FBRANCH
250 ;; AberSoft
251 pop de
252 jr xloop
253 $FORTH_END_CODE_WORD (+LOOP)
255 $FORTH_CODE_WORD (DO)
256 ;; AberSoft
257 ld hl,(f_curRP)
258 dec hl
259 dec hl
260 dec hl
261 dec hl
262 ld (f_curRP),hl
263 pop de
264 ld (hl),e
265 inc hl
266 ld (hl),d
267 pop de
268 inc hl
269 ld (hl),e
270 inc hl
271 ld (hl),d
272 jp i_next
273 $FORTH_END_CODE_WORD (DO)
275 $FORTH_CODE_WORD I
276 ;; AberSoft
277 ld hl,(f_curRP)
278 ld e,(hl)
279 inc hl
280 ld d,(hl)
281 push de
282 jp i_next
283 $FORTH_END_CODE_WORD I
285 $FORTH_CODE_WORD I'
286 ;; AberSoft
287 ld hl,(f_curRP)
288 inc hl
289 inc hl
290 ld e,(hl)
291 inc hl
292 ld d,(hl)
293 push de
294 jp i_next
295 $FORTH_END_CODE_WORD I'
297 $FORTH_CODE_WORD J
298 ;; AberSoft
299 ld hl,(f_curRP)
300 inc hl
301 inc hl
302 inc hl
303 inc hl
304 ld e,(hl)
305 inc hl
306 ld d,(hl)
307 push de
308 jp i_next
309 $FORTH_END_CODE_WORD J
311 $FORTH_CODE_WORD DIGIT
312 ;; AberSoft
313 pop hl
314 pop de
315 ld a,e
316 sub #30
317 jp m,digit1
318 cp 10
319 jp m,digit0
320 sub 7
321 cp 10
322 jp m,digit1
323 digit0:
324 cp l
325 jp p,digit1
326 ld e,a
327 ld hl,1
328 jp i_pushde
329 digit1:
330 ld l,h
331 jp i_pushhl
332 $FORTH_END_CODE_WORD DIGIT
334 $FORTH_CODE_WORD (FIND)
335 ;; AberSoft
336 ;; ( addr l addr2 -- pfa b tf ok)
337 ;; ( addr l addr2 -- ff bad)
338 pop de
339 xfind0:
340 pop hl
341 push hl
342 ld a,(de)
343 xor (hl)
344 and #3F
345 jr nz,xfind4
346 xfind1:
347 inc hl
348 inc de
349 ld a,(de)
350 xor (hl)
351 add a,a
352 jr nz,xfind3
353 jr nc,xfind1
354 ld hl,5
355 add hl,de
356 ex (sp),hl
357 xfind2:
358 dec de
359 ld a,(de)
360 or a
361 jp p,xfind2
362 ld e,a
363 ld d,0
364 ld hl,1
365 jp i_pushde
366 xfind3:
367 jr c,xfind5
368 xfind4:
369 inc de
370 ld a,(de)
371 or a
372 jp p,xfind4
373 xfind5:
374 inc de
375 ex de,hl
376 ld e,(hl)
377 inc hl
378 ld d,(hl)
379 ld a,d
380 or e
381 jr nz,xfind0
382 pop hl
383 ld hl,0
384 jp i_pushhl
385 $FORTH_END_CODE_WORD (FIND)
387 $FORTH_CODE_WORD ENCLOSE
388 ;; AberSoft
389 ;; ( addr delimeter -- addr w_start_ofs w_end_ofs next_scan_ofs )
390 pop de ;; E=delimeter
391 pop hl ;; HL=addr
392 push hl
394 ld a,e
395 ld d,a
396 ld e,#FF
397 dec hl
399 ;; here: E=word len; A=delim; HL=addr
400 enclose0:
401 ;; skip delimiters
402 inc hl
403 inc e
404 cp (hl)
405 jr z,enclose0
407 ld d,0
408 push de ;; store # of delimiters before the word
410 ld d,a ;; D=delimiter
411 ;; check for "end of buffer" (#0)
412 ld a,(hl)
413 and a
414 jr nz,enclose1
416 ;; oops... no more blondies on the island
417 ld d,0
418 inc e
419 push de ;; store full length
421 dec e
422 push de ;; store position of the next char to scan
423 jp i_next
425 ;; here: E=word len; D=delim; HL=addr
426 enclose1:
427 ;; now collect the word itself
428 ld a,d
429 inc hl
430 inc e
431 cp (hl)
432 jr z,enclose2 ;; word ends?
433 ;; no, check "end of buffer"
434 ld a,(hl)
435 and a
436 jr nz,enclose1
438 ;; oops... no more blondies on the island
439 ld d,0
440 push de ;; store full length
441 push de ;; store position of the next char to scan (???)
442 jp i_next
444 enclose2:
445 ld d,0
446 push de ;; store full length
447 inc e
448 push de ;; store position of the next char to scan
449 jp i_next
450 $FORTH_END_CODE_WORD ENCLOSE
452 ;; check if BREAK is pressed
453 $FORTH_CODE_WORD ?BREAK
454 ;; AberSoft, k8
455 ;; ( -- break_flag)
456 ld hl,0
457 call #1F54 ;; uses only A
458 jr c,term0
459 inc l
460 term0:
461 jp i_pushhl
462 $FORTH_END_CODE_WORD ?BREAK
464 $FORTH_CODE_WORD PAGE-CMOVE
465 ;; k8
466 ;; CMOVE with page swapping
467 ;; ( from to len destpage -- )
468 ;; addr must be >= #C000
469 pop de ; destpage
470 ld a,e
471 ;;AND #07 ; we can have much more memory
472 ; get other args and save BC
473 ld l,c
474 ld h,b
475 pop bc ; length
476 pop de ; dest
477 ex (sp),hl ; save BC and get src
478 ld a,b
479 or c
480 jr z,cmove0
481 ; move
482 exx
483 ld bc,#7FFD
484 di
485 out (c),a
486 exx
487 ldir
488 exx
489 ld a,(f_cur7FFD)
490 out (c),a
491 ei
492 jr cmove0
493 $FORTH_END_CODE_WORD PAGE-CMOVE
495 $FORTH_CODE_WORD CMOVE
496 ;; AberSoft
497 ;; ( from to len -- )
498 ld l,c
499 ld h,b
500 pop bc
501 pop de
502 ex (sp),hl
503 ld a,b
504 or c
505 jr z,cmove0
506 ldir
507 cmove0:
508 pop bc
509 jp i_next
510 $FORTH_END_CODE_WORD CMOVE
512 $FORTH_CODE_WORD FILL
513 ;; AberSoft
514 ld l,c
515 ld h,b
516 pop de
517 pop bc
518 ex (sp),hl
519 ex de,hl
520 fill0:
521 ld a,b
522 or c
523 jr z,fill1
524 ld a,l
525 ld (de),a
526 inc de
527 dec bc
528 jr fill0
529 fill1:
530 pop bc
531 jp i_next
532 $FORTH_END_CODE_WORD FILL
534 IF USE_SMALL_MULDIV
535 include "fastmuldiv_small.zas"
536 ELSE
537 include "fastmuldiv.zas"
538 ENDIF
540 $FORTH_CODE_WORD 256U*
541 ;; k8
542 ;; ( n -- n*256u )
543 pop hl
544 ld h,l
545 ld l,0
546 jp i_pushhl
547 $FORTH_END_CODE_WORD 256U*
549 $FORTH_CODE_WORD 256U/
550 ;; k8
551 ;; ( n -- n/256u )
552 pop hl
553 ld l,h
554 ld h,0
555 jp i_pushhl
556 $FORTH_END_CODE_WORD 256U/
558 $FORTH_CODE_WORD 2U/
559 ;; k8
560 ;; ( n -- n/2 )
561 pop hl
562 or a
563 rr h
564 rr l
565 jp i_pushhl
566 $FORTH_END_CODE_WORD 2U/
568 $FORTH_CODE_WORD 2U*
569 ;; k8
570 ;; ( n -- n*2 )
571 pop hl
572 or a
573 rl l
574 rl h
575 jp i_pushhl
576 $FORTH_END_CODE_WORD 2U*
578 $FORTH_CODE_WORD 2UMOD
579 ;; k8
580 ;; ( n -- n%2 )
581 pop hl
582 ld a,l
583 and #01
584 ld l,a
585 ld h,0
586 jp i_pushhl
587 $FORTH_END_CODE_WORD 2UMOD
589 $FORTH_CODE_WORD 256UMOD
590 ;; k8
591 ;; ( n -- n%256u )
592 pop hl
593 ld h,0
594 jp i_pushhl
595 $FORTH_END_CODE_WORD 256UMOD
597 $FORTH_CODE_WORD AND
598 ;; AberSoft
599 ;; ( n0 n1 -- n )
600 pop de
601 pop hl
602 ld a,e
603 and l
604 ld l,a
605 ld a,d
606 and h
607 ld h,a
608 jp i_pushhl
609 $FORTH_END_CODE_WORD AND
611 ;; "logical" and
612 $FORTH_CODE_WORD LAND
613 ;; k8
614 ;; ( n0 n1 -- 0 or 1 )
615 pop de
616 pop hl
617 ld a,l
618 or h
619 jp z,i_pushhl
620 ex de,hl
621 ld a,l
622 or h
623 jp z,i_pushhl
624 ld hl,1
625 jp i_pushhl
626 $FORTH_END_CODE_WORD LAND
628 $FORTH_CODE_WORD OR
629 ;; AberSoft
630 ;; ( n0 n1 -- n )
631 pop de
632 pop hl
633 ld a,e
634 or l
635 ld l,a
636 ld a,d
637 or h
638 ld h,a
639 jp i_pushhl
640 $FORTH_END_CODE_WORD OR
642 ;; "logical" or
643 $FORTH_CODE_WORD LOR
644 ;; k8
645 ;; ( n0 n1 -- 0 or 1 )
646 pop de
647 pop hl
648 ld a,l
649 or h
650 jr nz,logor_push_one
651 ;; hl is 0 here
652 ld a,d
653 or e
654 jp z,i_pushhl
655 logor_push_one:
656 ld hl,1
657 jp i_pushhl
658 $FORTH_END_CODE_WORD LOR
660 ;; "logical" not-not
661 $FORTH_CODE_WORD NOTNOT
662 ;; k8
663 ;; ( n -- 0 or 1 )
664 pop hl
665 ld a,l
666 or h
667 jp z,i_pushhl
668 ld hl,1
669 jp i_pushhl
670 $FORTH_END_CODE_WORD NOTNOT
672 $FORTH_CODE_WORD XOR
673 ;; AberSoft
674 ;; ( n0 n1 -- n )
675 pop de
676 pop hl
677 ld a,e
678 xor l
679 ld l,a
680 ld a,d
681 xor h
682 ld h,a
683 jp i_pushhl
684 $FORTH_END_CODE_WORD XOR
686 ;; get current SP
687 $FORTH_CODE_WORD SP@
688 ;; AberSoft
689 ;; ( -- sp )
690 ld hl,0
691 add hl,sp
692 jp i_pushhl
693 $FORTH_END_CODE_WORD SP@
695 $FORTH_CODE_WORD sp!
696 ;; AberSoft
697 ;; SP := [SP0]
698 ld e,(ix+6)
699 ld d,(ix+7)
700 ex de,hl
701 ld sp,hl
702 jp i_next
703 $FORTH_END_CODE_WORD sp!
705 ;; get current RP
706 $FORTH_CODE_WORD RP@
707 ;; AberSoft
708 ;; ( -- rp )
709 ld hl,(f_curRP)
710 jp i_pushhl
711 $FORTH_END_CODE_WORD RP@
713 $FORTH_CODE_WORD RP!
714 ;; AberSoft
715 ;; RP := [RP0]
716 ld e,(ix+8)
717 ld d,(ix+9)
718 ex de,hl
719 jr rsetrpnext
720 $FORTH_END_CODE_WORD RP!
722 ;; end of "colon" word
723 ;; break "LOAD"
724 $FORTH_CODE_WORD ;S
725 ;; AberSoft
726 ;; ( -- )
727 ld hl,(f_curRP)
728 ld c,(hl)
729 inc hl
730 ld b,(hl)
731 inc hl
732 jr rsetrpnext
733 $FORTH_END_CODE_WORD ;S
735 ;; DO/LOOP will stop on the next iteration
736 $FORTH_CODE_WORD LEAVE
737 ;; AberSoft
738 ;; ( -- )
739 ld hl,(f_curRP)
740 ld e,(hl)
741 inc hl
742 ld d,(hl)
743 inc hl
744 ld (hl),e
745 inc hl
746 ld (hl),d
747 jp i_next
748 $FORTH_END_CODE_WORD LEAVE
750 ;; move value from paremeter stack to execution stack
751 $FORTH_CODE_WORD >R
752 ;; AberSoft
753 ;; ( n -- || n )
754 pop de
755 ld hl,(f_curRP)
756 dec hl
757 ld (hl),d
758 dec hl
759 ld (hl),e
760 rsetrpnext:
761 ld (f_curRP),hl
762 jp i_next
763 $FORTH_END_CODE_WORD >R
765 ;; move value from execution stack to paremeter stack
766 $FORTH_CODE_WORD R>
767 ;; AberSoft
768 ;; ( n || -- n )
769 ld hl,(f_curRP)
770 ld e,(hl)
771 inc hl
772 ld d,(hl)
773 inc hl
774 push de
775 jr rsetrpnext
776 $FORTH_END_CODE_WORD R>
778 ;; copy value from execution stack to paremeter stack
779 $FORTH_CODE_WORD R@
780 ;; AberSoft
781 ;; ( n || -- n || n)
782 ld hl,(f_curRP)
783 ld e,(hl)
784 inc hl
785 ld d,(hl)
786 push de
787 jp i_next
788 $FORTH_END_CODE_WORD R@
790 $FORTH_CODE_WORD RDROP
791 ;; k8
792 ;; ( || n -- || )
793 ld hl,(f_curRP)
794 inc hl
795 inc hl
796 jr rsetrpnext
797 $FORTH_END_CODE_WORD RDROP
800 $FORTH_CODE_WORD 0=
801 ;; AberSoft
802 ;; ( n -- flag )
803 zequ:
804 pop hl
805 ld a,l
806 or h
807 inc hl
808 jp z,i_pushhl
809 ld hl,0
810 jp i_pushhl
811 $FORTH_END_CODE_WORD 0=
813 $FORTH_CODE_WORD NOT
814 ;; AberSoft
815 ;; ( n -- flag )
816 jr zequ
817 $FORTH_END_CODE_WORD NOT
819 $FORTH_CODE_WORD 0<
820 ;; k8
821 ;; ( n1 -- flag )
822 pop hl
823 ld a,h
824 ld hl,0
825 bit 7,a
826 jr z,zless0
827 inc hl
828 zless0:
829 jp i_pushhl
830 $FORTH_END_CODE_WORD 0<
832 $FORTH_CODE_WORD <
833 ;; AberSoft
834 ;; ( n0 n1 -- flag )
835 pop de
836 pop hl
837 ld a,d
838 xor h
839 jp m,less0
840 and a
841 sbc hl,de
842 less0:
843 inc h
844 dec h
845 jp m,less1
846 ld hl,0
847 jp i_pushhl
848 less1:
849 ld hl,1
850 jp i_pushhl
851 $FORTH_END_CODE_WORD <
853 $FORTH_WORD U<
854 ;; AberSoft
855 ;; ( n0 n1 -- flag )
856 2DUP XOR 0< 0BRANCH uless0
857 DROP 0< 0= BRANCH uless1
858 uless0:
859 - 0<
860 uless1:
861 ;S
862 $FORTH_END_WORD U<
864 $FORTH_WORD U>
865 ;; AberSoft
866 ;; ( n0 n1 -- flag )
867 >R 1- R> U< 0=
868 ;S
869 $FORTH_END_WORD U>
871 $FORTH_WORD >
872 ;; AberSoft
873 ;; ( n0 n1 -- flag )
874 SWAP < ;S
875 $FORTH_END_WORD >
877 $FORTH_WORD =
878 ;; AberSoft
879 ;; ( n0 n1 -- flag )
880 - 0= ;S
881 $FORTH_END_WORD =
883 $FORTH_CODE_WORD <>
884 ;; k8
885 ;; ( n0 n1 -- flag )
886 notequ_code:
887 pop hl
888 pop de
889 ld a,h
890 sub a,d
891 jr nz,notequ_neq
892 ld a,l
893 sub a,e
894 jr nz,notequ_neq
895 ld l,a
896 ld h,a
897 jp i_pushhl
898 notequ_neq:
899 ld hl,1
900 jp i_pushhl
901 $FORTH_END_CODE_WORD <>
902 ;; k8
903 ;; ( n0 n1 -- flag )
904 ;; - 0= 0= ;S
905 ;;$FORTH_END_WORD <>
907 $FORTH_CODE_WORD !=
908 ;; k8
909 ;; ( n0 n1 -- flag )
910 jp notequ_code
911 $FORTH_END_CODE_WORD !=
913 $FORTH_WORD <=
914 ;; k8
915 ;; ( n0 n1 -- flag )
916 2DUP < >R = R> OR ;S
917 $FORTH_END_WORD <=
919 $FORTH_WORD >=
920 ;; k8
921 ;; ( n0 n1 -- flag )
922 2DUP > >R = R> OR ;S
923 $FORTH_END_WORD >=
925 $FORTH_CODE_WORD 1+
926 ;; k8
927 pop hl
928 inc hl
929 jp i_pushhl
930 $FORTH_END_CODE_WORD 1+
932 $FORTH_CODE_WORD 2+
933 ;; k8
934 pop hl
935 inc hl
936 inc hl
937 jp i_pushhl
938 $FORTH_END_CODE_WORD 2+
940 $FORTH_CODE_WORD 4+
941 ;; k8
942 pop hl
943 inc hl
944 inc hl
945 inc hl
946 inc hl
947 jp i_pushhl
948 $FORTH_END_CODE_WORD 4+
950 $FORTH_CODE_WORD 1-
951 ;; k8
952 pop hl
953 dec hl
954 jp i_pushhl
955 $FORTH_END_CODE_WORD 1-
957 $FORTH_CODE_WORD 2-
958 ;; k8
959 pop hl
960 dec hl
961 dec hl
962 jp i_pushhl
963 $FORTH_END_CODE_WORD 2-
965 $FORTH_CODE_WORD 4-
966 ;; k8
967 pop hl
968 dec hl
969 dec hl
970 dec hl
971 dec hl
972 jp i_pushhl
973 $FORTH_END_CODE_WORD 4-
975 $FORTH_CODE_WORD +
976 ;; AberSoft
977 ;; ( n0 n1 -- n )
978 pop de
979 pop hl
980 add hl,de
981 jp i_pushhl
982 $FORTH_END_CODE_WORD +
984 $FORTH_CODE_WORD -
985 ;; AberSoft
986 ;; ( n0 n1 -- n )
987 pop de
988 pop hl
989 and a
990 sbc hl,de
991 jp i_pushhl
992 $FORTH_END_CODE_WORD -
994 $FORTH_CODE_WORD D+
995 ;; AberSoft
996 ;; ( d0 d1 -- d )
997 ld hl,6
998 add hl,sp
999 ld e,(hl)
1000 ld (hl),c
1001 inc hl
1002 ld d,(hl)
1003 ld (hl),b
1004 pop bc
1005 pop hl
1006 add hl,de
1007 ex de,hl
1008 pop hl
1009 sbc hl,bc
1010 pop bc
1011 push de
1012 jp i_pushhl
1013 $FORTH_END_CODE_WORD D+
1015 ;; change sign
1016 ;; TODO: error on -32768?
1017 $FORTH_CODE_WORD NEGATE
1018 ;; AberSoft
1019 ;; ( n -- -n )
1020 pop de
1021 ld hl,0
1022 and a
1023 sbc hl,de
1024 jp i_pushhl
1025 $FORTH_END_CODE_WORD NEGATE
1027 ;; change sign
1028 ;; TODO: error on MAXLONGINT?
1029 $FORTH_CODE_WORD DNEGATE
1030 ;; AberSoft
1031 ;; ( d -- -d )
1032 pop hl
1033 pop de
1034 sub a
1035 sub e
1036 ld e,a
1037 ld a,0
1038 sbc a,d
1039 ld d,a
1040 ld a,0
1041 sbc a,l
1042 ld l,a
1043 ld a,0
1044 sbc a,h
1045 ld h,a
1046 push de
1047 jp i_pushhl
1048 $FORTH_END_CODE_WORD DNEGATE
1050 $FORTH_CODE_WORD DROP
1051 ;; AberSoft
1052 ;; ( n -- )
1053 doonedrop:
1054 pop hl
1055 jp i_next
1056 $FORTH_END_CODE_WORD DROP
1058 $FORTH_CODE_WORD 2DROP
1059 ;; k8
1060 ;; ( n0 n1 -- )
1061 pop hl
1062 jr doonedrop
1063 $FORTH_END_CODE_WORD 2DROP
1065 $FORTH_CODE_WORD OVER
1066 ;; AberSoft
1067 ;; ( n0 n1 -- n0 n1 n0 )
1068 pop de
1069 pop hl
1070 push hl
1071 jp i_pushde
1072 $FORTH_END_CODE_WORD OVER
1074 $FORTH_WORD 2OVER
1075 ;; AberSoft
1076 ;; ( d0 d1 -- d0 d1 d0 )
1077 ;; k8: rewrite on asm?
1078 2SWAP 2DUP >R >R 2SWAP R> R> ;S
1079 $FORTH_END_WORD 2OVER
1081 $FORTH_CODE_WORD SWAP
1082 ;; AberSoft
1083 ;; ( n0 n1 -- n1 n0 )
1084 pop hl
1085 ex (sp),hl
1086 jp i_pushhl
1087 $FORTH_END_CODE_WORD SWAP
1089 $FORTH_WORD 2SWAP
1090 ;; AberSoft
1091 ;; ( d0 d1 -- d1 d0 )
1092 ;; k8: rewrite on asm?
1093 ROT >R ROT R> ;S
1094 $FORTH_END_WORD 2SWAP
1096 $FORTH_CODE_WORD DUP
1097 ;; AberSoft
1098 ;; ( n -- n n )
1099 pop hl
1100 push hl
1101 jp i_pushhl
1102 $FORTH_END_CODE_WORD DUP
1104 $FORTH_CODE_WORD -DUP
1105 ;; k8
1106 ;; ( n -- n n ) if n is not 0
1107 ;; ( n -- n ) if n is 0
1108 pop hl
1109 push hl
1110 ld a,l
1111 or h
1112 jp z,i_next
1113 jp i_pushhl
1114 $FORTH_END_CODE_WORD -DUP
1116 $FORTH_CODE_WORD 2DUP
1117 ;; AberSoft
1118 ;; ( d -- d d )
1119 pop hl
1120 pop de
1121 push de
1122 push hl
1123 jp i_pushde
1124 $FORTH_END_CODE_WORD 2DUP
1126 $FORTH_CODE_WORD ROT
1127 ;; AberSoft
1128 ;; ( n0 n1 n2 -- n1 n2 n0 )
1129 pop de
1130 pop hl
1131 ex (sp),hl
1132 jp i_pushde
1133 $FORTH_END_CODE_WORD ROT
1135 $FORTH_CODE_WORD +!
1136 ;; AberSoft
1137 ;; ( n a -- )
1138 pop hl
1139 pop de
1140 ld a,(hl)
1141 add a,e
1142 ld (hl),a
1143 inc hl
1144 ld a,(hl)
1145 adc a,d
1146 ld (hl),a
1147 jp i_next
1148 $FORTH_END_CODE_WORD +!
1150 $FORTH_CODE_WORD TOGGLE
1151 ;; AberSoft
1152 ;; ( a n -- )
1153 pop de
1154 pop hl
1155 ld a,(hl)
1156 xor e
1157 ld (hl),a
1158 jp i_next
1159 $FORTH_END_CODE_WORD TOGGLE
1161 $FORTH_CODE_WORD 2@
1162 ;; AberSoft
1163 ;; ( a -- d )
1164 pop hl
1165 inc hl
1166 inc hl
1167 ld e,(hl)
1168 inc hl
1169 ld d,(hl)
1170 push de
1171 dec hl
1172 dec hl
1173 ld d,(hl)
1174 dec hl
1175 ld e,(hl)
1176 push de
1177 jp i_next
1178 $FORTH_END_CODE_WORD 2@
1180 $FORTH_CODE_WORD C@
1181 ;; AberSoft
1182 ;; ( a -- c )
1183 pop hl
1184 ld l,(hl)
1185 ld h,0
1186 jp i_pushhl
1187 $FORTH_END_CODE_WORD C@
1189 $FORTH_CODE_WORD @
1190 ;; AberSoft
1191 ;; ( a -- n )
1192 pop hl
1193 ld e,(hl)
1194 inc hl
1195 ld d,(hl)
1196 push de
1197 jp i_next
1198 $FORTH_END_CODE_WORD @
1200 $FORTH_CODE_WORD 2!
1201 ;; AberSoft
1202 ;; ( a -- d )
1203 pop hl
1204 pop de
1205 ld (hl),e
1206 inc hl
1207 ld (hl),d
1208 inc hl
1209 pop de
1210 ld (hl),e
1211 inc hl
1212 ld (hl),d
1213 jp i_next
1214 $FORTH_END_CODE_WORD 2!
1216 $FORTH_CODE_WORD C!
1217 ;; AberSoft
1218 ;; ( a -- c )
1219 pop hl
1220 pop de
1221 ld (hl),e
1222 jp i_next
1223 $FORTH_END_CODE_WORD C!
1225 $FORTH_CODE_WORD !
1226 ;; AberSoft
1227 ;; ( n a -- )
1228 pop hl
1229 pop de
1230 ld (hl),e
1231 inc hl
1232 ld (hl),d
1233 jp i_next
1234 $FORTH_END_CODE_WORD !
1236 $FORTH_CODE_WORD 0C!
1237 ;; AberSoft
1238 ;; ( a -- )
1239 pop hl
1240 ld (hl),0
1241 jp i_next
1242 $FORTH_END_CODE_WORD 0C!
1244 $FORTH_CODE_WORD 0!
1245 ;; AberSoft
1246 ;; ( a -- )
1247 pop hl
1248 ld (hl),0
1249 inc hl
1250 ld (hl),0
1251 jp i_next
1252 $FORTH_END_CODE_WORD 0!
1254 $FORTH_CODE_WORD 1C!
1255 ;; k8
1256 ;; ( a -- )
1257 pop hl
1258 ld (hl),1
1259 jp i_next
1260 $FORTH_END_CODE_WORD 1C!
1262 $FORTH_CODE_WORD 1!
1263 ;; k8
1264 ;; ( a -- )
1265 pop hl
1266 ld (hl),1
1267 inc hl
1268 ld (hl),0
1269 jp i_next
1270 $FORTH_END_CODE_WORD 1!
1273 $FORTH_CODE_WORD FORTH-WORD?
1274 ;; k8
1275 ;; ( pfa -- flag )
1276 pop hl
1277 dec hl
1278 ld d, (hl)
1279 dec hl
1280 ld e, (hl)
1281 ld hl,_doforth
1282 sbc hl,de
1283 ld a,h
1284 or l
1285 ld hl,1
1286 jr z,isfword0
1287 dec l
1288 isfword0:
1289 jp i_pushhl
1290 $FORTH_END_CODE_WORD FORTH-WORD?
1293 $FORTH_WORD : IMM
1294 ;; AberSoft
1295 ?EXEC !CSP CURRENT @ CONTEXT ! CREATE ]
1296 (;CODE)
1297 $FORTH_END_WORD :
1298 _doforth:
1299 ld hl,(f_curRP)
1300 dec hl
1301 ld (hl),b
1302 dec hl
1303 ld (hl),c
1304 ld (f_curRP),hl
1305 inc de
1306 ld c,e
1307 ld b,d
1308 _doforth_dbg:
1309 jp i_next
1311 $FORTH_WORD ; IMM
1312 ;; AberSoft
1313 ?CSP COMPILE ;S
1314 SMUDGE [ ;S
1315 $FORTH_END_WORD ;
1317 $FORTH_WORD CONSTANT
1318 ;; AberSoft
1319 CREATE SMUDGE ,
1320 (;CODE)
1321 $FORTH_END_WORD CONSTANT
1322 _doconst:
1323 inc de
1324 ex de,hl
1325 ld e,(hl)
1326 inc hl
1327 ld d,(hl)
1328 doxvarx:
1329 push de
1330 jp i_next
1332 $FORTH_WORD VARIABLE
1333 ;; AberSoft
1334 CONSTANT (;CODE)
1335 $FORTH_END_WORD VARIABLE
1336 _dovar:
1337 inc de
1338 jr doxvarx
1340 $FORTH_WORD 2CONSTANT
1341 ;; AberSoft
1342 CREATE SMUDGE HERE 2! 4 ALLOT
1343 (;CODE)
1344 $FORTH_END_WORD 2CONSTANT
1345 _do2const:
1346 inc de
1347 ex de,hl
1348 inc hl
1349 inc hl
1350 ld e,(hl)
1351 inc hl
1352 ld d,(hl)
1353 push de
1354 dec hl
1355 dec hl
1356 ld d,(hl)
1357 dec hl
1358 ld e,(hl)
1359 jr doxvarx
1361 $FORTH_WORD 2VARIABLE
1362 ;; AberSoft
1363 2CONSTANT
1364 (;CODE)
1365 $FORTH_END_WORD 2VARIABLE
1366 _do2var:
1367 jr _dovar
1368 ;; INC DE
1369 ;; PUSH DE
1370 ;; JP i_next
1372 $FORTH_WORD USER
1373 ;; AberSoft
1374 CONSTANT (;CODE)
1375 $FORTH_END_WORD USER
1376 _douser:
1377 inc de
1378 ex de,hl
1379 ld e,(hl)
1380 ld d,0
1381 push ix
1382 pop hl
1383 add hl,de
1384 jp i_pushhl
1386 ;;;;;;;;;;;;;; some speedup constants
1387 $FORTH_CONST 0 0
1388 $FORTH_CONST 1 1
1389 $FORTH_CONST 2 2
1390 $FORTH_CONST 3 3
1391 $FORTH_CONST 4 4
1392 $FORTH_CONST BL 32
1394 $FORTH_CONST c/l #40
1396 $FORTH_WORD +ORIGIN
1397 LIT run_cold + ;S
1398 $FORTH_END_WORD +ORIGIN
1400 ;; these ones will be inited by COLD with the predefined values
1401 $FORTH_USER S0 #06
1402 $FORTH_USER R0 #08
1403 $FORTH_USER TIB #0A
1404 $FORTH_USER WIDTH #0C
1405 $FORTH_USER WARNING #0E
1406 $FORTH_USER FENCE #10
1407 $FORTH_USER DP #12
1408 $FORTH_USER VOC-LINK #14
1409 ;; these ones will not be inited by COLD
1410 $FORTH_USER BLK #16
1411 $FORTH_USER IN #18
1412 $FORTH_USER READ-ONLY #1A
1413 $FORTH_USER SCR #1C
1414 ;; OFFSET is the offset for BLOCK operation
1415 ;; i.e. actual block number will be n+OFFSET
1416 $FORTH_USER OFFSET #1E
1417 $FORTH_USER CONTEXT #20
1418 $FORTH_USER CURRENT #22
1419 $FORTH_USER STATE #24
1420 $FORTH_USER BASE #26
1421 $FORTH_USER DPL #28
1422 $FORTH_USER FLD #2A
1423 $FORTH_USER CSP #2C
1424 $FORTH_USER R# #2E
1425 $FORTH_USER HLD #30
1426 ;; new var for TLOAD
1427 $FORTH_USER TLOAD-Y #32
1428 $FORTH_USER SHOW-HIDDEN #34
1431 ;; 6x8 printing driver
1432 include "emit6.zas"
1433 include "key6.zas"
1436 $FORTH_CODE_WORD BYE
1437 ;; return to TR-DOS
1438 jp #3D00
1439 ;;;; return to BASIC?
1440 ;; LD A,#17
1441 ;; LD (f_cur7FFD),A
1442 ;; LD BC,#7FFD
1443 ;; OUT (C),A
1444 ;; LD HL,0
1445 ;; PUSH HL
1446 ;; JP #3D2F
1447 $FORTH_END_CODE_WORD BYE
1449 $FORTH_CODE_WORD 128K?
1450 ld a,(f_is128K)
1451 cw_is_128k_done:
1452 ld l,a
1453 ld h,0
1454 jp i_pushhl
1455 $FORTH_END_CODE_WORD 128K?
1457 $FORTH_CODE_WORD 48K?
1458 ld a,(f_is128K)
1459 or a
1460 ld a,1
1461 jr z,cw_is_128k_done
1462 xor a
1463 jr cw_is_128k_done
1464 $FORTH_END_CODE_WORD 48K?
1466 $FORTH_WORD .CREDITZ
1467 ;; k8
1468 (.") ~\n48K/128K dsFORTH v0.0.1\n~
1469 (.") ~original version: \x7F Abersoft, 1983\n~
1470 (.") ~modifications by Ketmar//Invisible Vector\n~
1471 ;; (.") ~distribution terms: GNU GPL\n~
1472 ;S
1473 $FORTH_END_WORD .CREDITZ
1476 $FORTH_WORD HERE
1477 ;; AberSoft
1478 DP @ ;S
1479 $FORTH_END_WORD HERE
1481 $FORTH_WORD ALLOT
1482 ;; AberSoft,k8
1483 ;; k8 checks on
1484 SP@ LIT 32 - DP @ U< 0BRANCH allot0 (.") ~ALLOT: out of memory!~ CR ABORT ;; "
1485 allot0:
1486 ;; k8 checks off
1487 DP +! ;S
1488 $FORTH_END_WORD ALLOT
1490 $FORTH_WORD ,
1491 ;; AberSoft
1492 HERE ! 2 ALLOT ;S
1493 $FORTH_END_WORD ,
1495 $FORTH_WORD C,
1496 ;; AberSoft
1497 HERE C! 1 ALLOT ;S
1498 $FORTH_END_WORD C,
1501 $FORTH_WORD TRAVERSE
1502 ;; AberSoft
1503 SWAP
1504 traverse0:
1505 OVER + LIT 127 OVER C@ <
1506 0BRANCH traverse0
1507 SWAP DROP ;S
1508 $FORTH_END_WORD TRAVERSE
1511 $FORTH_WORD LATEST
1512 ;; AberSoft
1513 CURRENT @ @ ;S
1514 $FORTH_END_WORD LATEST
1516 $FORTH_WORD LFA
1517 ;; AberSoft
1518 4 - ;S
1519 $FORTH_END_WORD LFA
1521 $FORTH_WORD CFA
1522 ;; AberSoft
1523 2- ;S
1524 $FORTH_END_WORD CFA
1526 $FORTH_WORD NFA
1527 ;; AberSoft
1528 LIT 5 - LIT -1 TRAVERSE ;S
1529 $FORTH_END_WORD NFA
1531 $FORTH_WORD PFA
1532 ;; AberSoft
1533 1 TRAVERSE LIT 5 + ;S
1534 $FORTH_END_WORD PFA
1537 $FORTH_WORD !CSP
1538 ;; AberSoft
1539 SP@ CSP ! ;S
1540 $FORTH_END_WORD !CSP
1542 $FORTH_WORD ?ERROR
1543 ;; AberSoft
1544 ;; ( flag code -- )
1545 SWAP 0BRANCH qerror0
1546 ERROR BRANCH qerror1
1547 qerror0:
1548 DROP
1549 qerror1:
1550 ;S
1551 $FORTH_END_WORD ?ERROR
1553 $FORTH_WORD ?COMP
1554 ;; AberSoft
1555 STATE @ 0= LIT 17 ?ERROR ;S
1556 $FORTH_END_WORD ?COMP
1558 $FORTH_WORD ?EXEC
1559 ;; AberSoft
1560 STATE @ LIT 18 ?ERROR ;S
1561 $FORTH_END_WORD ?EXEC
1563 $FORTH_WORD ?PAIRS
1564 ;; AberSoft
1565 - LIT 19 ?ERROR ;S
1566 $FORTH_END_WORD ?PAIRS
1568 $FORTH_WORD ?CSP
1569 ;; AberSoft
1570 SP@ CSP @ - LIT 20 ?ERROR ;S
1571 $FORTH_END_WORD ?CSP
1573 $FORTH_WORD ?LOADING
1574 ;; AberSoft
1575 BLK @ 0= LIT 22 ?ERROR ;S
1576 $FORTH_END_WORD ?LOADING
1578 $FORTH_WORD COMPILE
1579 ;; AberSoft
1580 ?COMP R> DUP 2+ >R @ , ;S
1581 $FORTH_END_WORD COMPILE
1583 $FORTH_WORD [ IMM
1584 ;; AberSoft
1585 STATE 0! ;S
1586 $FORTH_END_WORD [
1588 $FORTH_WORD ]
1589 ;; AberSoft
1590 LIT #C0 STATE ! ;S
1591 $FORTH_END_WORD ]
1593 $FORTH_WORD SMUDGE
1594 ;; AberSoft
1595 LATEST LIT #20 TOGGLE ;S
1596 $FORTH_END_WORD SMUDGE
1598 $FORTH_WORD HEX
1599 ;; AberSoft
1600 LIT 16 BASE ! ;S
1601 $FORTH_END_WORD HEX
1603 $FORTH_WORD DECIMAL
1604 ;; AberSoft
1605 LIT 10 BASE ! ;S
1606 $FORTH_END_WORD DECIMAL
1608 $FORTH_WORD (;CODE)
1609 ;; AberSoft
1610 R> LATEST PFA CFA ! ;S
1611 $FORTH_END_WORD (;CODE)
1613 $FORTH_WORD ;CODE IMM
1614 ;; AberSoft
1615 ?CSP COMPILE (;CODE)
1616 [ SMUDGE ;S
1617 $FORTH_END_WORD ;CODE
1619 $FORTH_WORD <BUILDS
1620 ;; AberSoft
1621 0 CONSTANT ;S
1622 $FORTH_END_WORD <BUILDS
1624 $FORTH_WORD DOES>
1625 ;; AberSoft
1626 R> LATEST PFA !
1627 (;CODE)
1628 $FORTH_END_WORD DOES>
1629 _dodoes:
1630 ld hl,(f_curRP)
1631 dec hl
1632 ld (hl),b
1633 dec hl
1634 ld (hl),c
1635 ld (f_curRP),hl
1636 inc de
1637 ex de,hl
1638 ld c,(hl)
1639 inc hl
1640 ld b,(hl)
1641 inc hl
1642 jp i_pushhl
1644 $FORTH_WORD COUNT
1645 ;; AberSoft
1646 ;; ( a -- a+1 (a) )
1647 DUP 1+ SWAP C@ ;S
1648 $FORTH_END_WORD COUNT
1650 $FORTH_WORD -TRAILING
1651 ;; AberSoft
1652 DUP 0 (DO)
1653 ntrailing0:
1654 OVER OVER + 1- C@ BL - 0BRANCH ntrailing1
1655 LEAVE BRANCH ntrailing2
1656 ntrailing1:
1657 1-
1658 ntrailing2:
1659 (LOOP) ntrailing0
1660 ;S
1661 $FORTH_END_WORD -TRAILING
1664 $FORTH_WORD ." IMM ;;"
1665 ;; AberSoft, k8
1666 LIT 34 STATE @ 0BRANCH dotq0
1667 COMPILE (.") ;;"
1668 WORD C@ 1+ ALLOT BRANCH dotq1
1669 dotq0:
1670 WORD COUNT TYPE
1671 dotq1:
1672 ;S
1673 $FORTH_END_WORD ."
1675 $FORTH_CODE_WORD (")
1676 ld a,(bc)
1677 inc bc
1678 ld l,a
1679 ld h,0
1680 push bc ;; addr
1681 push hl ;; length
1682 add hl,bc
1683 ld b,h
1684 ld c,l
1685 jp i_next
1686 $FORTH_END_CODE_WORD (") ;;"
1688 $FORTH_WORD " IMM ;; "
1689 ;; AberSoft, k8
1690 ;; ( -- c addr )
1691 ;; compile string into the current definition
1692 ;; or place it at PAD (depends of current STATE)
1693 LIT 34 STATE @ 0BRANCH dots0
1694 COMPILE (") ;;"
1695 WORD C@ 1+ ALLOT BRANCH dots1
1696 dots0:
1697 TEXT PAD COUNT
1698 dots1:
1699 ;S
1700 $FORTH_END_WORD " ;;"
1702 include "editstr.zas"
1704 $FORTH_WORD EXPECT
1705 ;; k8
1706 ;; ( addr len -- )
1707 1- (EDITSTR-MAXLEN) ! (EDITSTR-ADDR) !
1708 (EDITSTR-LEN) 0! (EDITSTR-cp) 0!
1709 XEDITSTR ;S
1710 $FORTH_END_WORD EXPECT
1712 $FORTH_WORD QUERY
1713 ;; AberSoft
1714 TIB @ LIT 80 EXPECT IN 0! ;S
1715 $FORTH_END_WORD QUERY
1717 ;; ~ will be changed to char with code 0 by ZASM
1718 ;; this word will be called by INTERPRET
1719 ;; when it meets the end of line marker (0x00)
1720 ;; zwb: break INTERPRET
1721 ;; zw2: continue INTERPRETING
1722 $FORTH_WORD ~ IMM ;; #0
1723 ;; AberSoft, k8
1724 TLOAD-Y @ 0BRANCH zwx
1725 FREADLN 0BRANCH zwx1 ;; no more lines
1726 DROP TIB ! IN 0! BRANCH zw2
1727 zwx1:
1728 TLOAD-Y 0! LIT f_userDEF 4+ @ DUP 0! TIB ! IN 0!
1729 ?EXEC RDROP
1730 BRANCH zwb
1731 zwx:
1732 BLK @ 0BRANCH zw1
1733 1 BLK +! IN 0! BLK @ b/SCR 1- AND 0= 0BRANCH zw0
1734 zwb:
1735 ?EXEC RDROP
1736 zw0:
1737 BRANCH zw2
1738 zw1:
1739 RDROP
1740 zw2:
1741 ;S
1742 $FORTH_END_WORD ~
1744 $FORTH_WORD ERASE
1745 ;; AberSoft
1746 ;; ( addr len -- )
1747 0 FILL ;S
1748 $FORTH_END_WORD ERASE
1750 $FORTH_WORD BLANKS
1751 ;; AberSoft
1752 ;; ( addr len -- )
1753 BL FILL ;S
1754 $FORTH_END_WORD BLANKS
1757 $FORTH_WORD HOLD
1758 ;; AberSoft
1759 ;; ( -- )
1760 LIT -1 HLD +! HLD @ C! ;S
1761 $FORTH_END_WORD HOLD
1763 $FORTH_WORD PAD
1764 ;; AberSoft
1765 ;; ( -- pad )
1766 HERE LIT 68 + ;S
1767 $FORTH_END_WORD PAD
1770 ;; read next word from the input stream
1771 ;; place it at HERE as the counted string
1772 $FORTH_WORD WORD
1773 ;; AberSoft, k8
1774 ;; ( delimeter -- here )
1775 BLK @ 0BRANCH word0 ;; not LOADing?
1776 BLK @ BLOCK BRANCH word1 ;; else -- load block and get its address
1777 word0:
1778 TIB @
1779 word1:
1780 IN @ + SWAP ENCLOSE
1781 ;; ENCLOSE: ( addr delimeter -- addr w_start_ofs w_end_ofs next_scan_ofs )
1783 HERE LIT 34 BLANKS
1784 IN +! ;; ( addr w_start_ofs w_end_ofs )
1785 OVER - ;; ( addr w_start_ofs w_len )
1786 DUP >R HERE C! ;; length stored; ( addr w_start_ofs | w_len )
1787 + HERE 1+ R> CMOVE
1788 HERE ;S
1789 $FORTH_END_WORD WORD
1791 $FORTH_WORD (NUMBER)
1792 ;; AberSoft
1793 xnumber0:
1794 1+ DUP >R C@ BASE @ DIGIT 0BRANCH xnumber2
1795 SWAP BASE @ U* DROP ROT BASE @ U* D+ DPL @ 1+ 0BRANCH xnumber1
1796 1 DPL +!
1797 xnumber1:
1798 R> BRANCH xnumber0
1799 xnumber2:
1800 R> ;S
1801 $FORTH_END_WORD (NUMBER)
1803 $FORTH_WORD NUMBER
1804 ;; AberSoft
1805 0 0 ROT DUP 1+ C@ LIT 45 = DUP >R + LIT -1
1806 number0:
1807 DPL ! (NUMBER) DUP C@ BL - 0BRANCH number1
1808 DUP C@ LIT 46 - 0 ?ERROR 0
1809 BRANCH number0
1810 number1:
1811 DROP R> 0BRANCH number2
1812 DNEGATE
1813 number2:
1814 ;S
1815 $FORTH_END_WORD NUMBER
1817 ;; read next word from the input stream
1818 ;; search it in the dictionary
1819 $FORTH_WORD -FIND
1820 ;; AberSoft, k8
1821 ;; ( -- pfa b tf ok)
1822 ;; ( -- ff bad)
1823 BL WORD CONTEXT @ @ (FIND)
1824 DUP 0= 0BRANCH nfind0
1825 DROP HERE LATEST (FIND)
1826 nfind0:
1827 ;S
1828 $FORTH_END_WORD -FIND
1830 $FORTH_WORD (ABORT)
1831 ;; AberSoft
1832 ;; ( )
1833 ABORT
1834 $FORTH_END_WORD (ABORT)
1836 $FORTH_WORD ERROR
1837 ;; AberSoft
1838 ;; ( n )
1839 TLOAD-Y 0!
1840 WARNING @ 0< 0BRANCH error0
1841 (ABORT)
1842 error0:
1843 HERE COUNT TYPE (.") ~? ~ MESSAGE ;; "
1844 sp! BLK @ -DUP 0BRANCH error1
1845 IN @ SWAP
1846 error1:
1847 LIT f_userDEF 4+ @ TIB !
1848 QUIT
1849 $FORTH_END_WORD ERROR
1851 $FORTH_WORD ID.
1852 ;; AberSoft
1853 ;; ( a -- )
1854 PAD LIT 32 LIT 95 FILL
1855 DUP PFA LFA OVER - PAD SWAP CMOVE
1856 PAD COUNT LIT 31 AND 2DUP + 1- DUP @ LIT #FF7F AND SWAP !
1857 TYPE SPACE ;S
1858 $FORTH_END_WORD ID.
1860 $FORTH_WORD CREATE
1861 ;; AberSoft
1862 -FIND 0BRANCH create0
1863 DROP NFA ID. 4 MESSAGE SPACE
1864 create0:
1865 HERE DUP C@ WIDTH @ MIN 1+ ALLOT DUP
1866 LIT #A0 TOGGLE HERE 1- LIT #80 TOGGLE
1867 LATEST , CURRENT @ ! HERE 2+ , ;S
1868 $FORTH_END_WORD CREATE
1870 $FORTH_WORD [COMPILE] IMM
1871 ;; AberSoft
1872 -FIND 0= 0 ?ERROR DROP CFA , ;S
1873 $FORTH_END_WORD [COMPILE]
1875 $FORTH_WORD LITERAL IMM
1876 ;; AberSoft
1877 STATE @ 0BRANCH literal0
1878 COMPILE LIT ,
1879 literal0:
1880 ;S
1881 $FORTH_END_WORD LITERAL
1883 $FORTH_WORD DLITERAL IMM
1884 ;; AberSoft
1885 STATE @ 0BRANCH dliteral0
1886 SWAP LITERAL LITERAL
1887 dliteral0:
1888 ;S
1889 $FORTH_END_WORD DLITERAL
1891 $FORTH_WORD ?STACK
1892 ;; AberSoft
1893 SP@ S0 @ SWAP U< 1 ?ERROR SP@ HERE LIT 128 + U< LIT 7 ?ERROR ;S
1894 $FORTH_END_WORD ?STACK
1896 $FORTH_WORD INTERPRET
1897 ;; AberSoft
1898 interpret0:
1899 -FIND 0BRANCH interpret3
1900 STATE @ < 0BRANCH interpret1
1901 CFA , BRANCH interpret2
1902 interpret1:
1903 CFA EXECUTE
1904 interpret2:
1905 ?STACK BRANCH interpret6
1906 interpret3:
1907 HERE NUMBER DPL @ 1+ 0BRANCH interpret4
1908 DLITERAL BRANCH interpret5
1909 interpret4:
1910 DROP LITERAL
1911 interpret5:
1912 ?STACK
1913 interpret6:
1914 BRANCH interpret0
1915 $FORTH_END_WORD INTERPRET
1917 $FORTH_WORD IMMEDIATE
1918 ;; AberSoft
1919 LATEST LIT #40 TOGGLE ;S
1920 $FORTH_END_WORD IMMEDIATE
1922 $FORTH_WORD DEFINITIONS
1923 ;; AberSoft
1924 CONTEXT @ CURRENT ! ;S
1925 $FORTH_END_WORD DEFINITIONS
1927 $FORTH_WORD ( IMM
1928 ;; AberSoft, k8
1929 LIT 41 WORD DROP ;S
1930 $FORTH_END_WORD (
1932 ;;FIXME: NOT PROPERLY TESTED!
1933 $FORTH_WORD \ IMM
1934 ;; k8
1935 BLK @ 0BRANCH cmt_eol_tib
1936 BLK @ BLOCK BRANCH cmt_eol_main ;; else -- load block and get its address
1937 cmt_eol_tib:
1938 TIB @
1939 cmt_eol_main:
1940 DUP
1941 IN @ + ;; ( staddr curaddr )
1942 ;;DEBUG: CR DUP U.
1943 cmt_eol_loop:
1944 DUP C@
1945 ;;DEBUG: DUP XEMIT
1946 DUP 0BRANCH cmt_eol_done
1947 ;; non-zero
1948 DUP LIT 13 = TBRANCH cmt_eol_done
1949 DUP LIT 10 = TBRANCH cmt_eol_done
1950 DROP
1951 1+
1952 BRANCH cmt_eol_loop
1953 cmt_eol_done:
1954 DROP
1955 ;;DEBUG: SPACE DUP U. CR
1956 SWAP - IN !
1957 ;S
1958 $FORTH_END_WORD \
1961 $FORTH_WORD QUIT
1962 ;; AberSoft
1963 BLK 0! TLOAD-Y 0! [
1964 quit0:
1965 RP! CR QUERY INTERPRET STATE @ 0= 0BRANCH quit1
1966 (.") ~ok~ ;; "
1967 quit1:
1968 BRANCH quit0
1969 $FORTH_END_WORD QUIT
1972 $FORTH_WORD ABORT
1973 ;; AberSoft, k8
1974 sp! DECIMAL ?STACK .CREDITZ
1975 TLOAD-Y 0!
1976 FORTH DEFINITIONS QUIT
1977 $FORTH_END_WORD ABORT
1979 $FORTH_WORD WARM
1980 ;; AberSoft, k8
1981 WARMbody:
1982 ;; 8 1 16384 TR-SREAD
1983 RP! EMPTY-BUFFERS
1984 CLS ABORT
1985 $FORTH_END_WORD WARM
1987 $FORTH_WORD COLD
1988 ;; AberSoft, k8
1989 COLDbody:
1990 FIRST BUF-USE ! FIRST BUF-PREV ! DR0
1991 ;; the first USER is at f_userBASE+6
1992 LIT f_userDEF LIT f_userBASE @ LIT 6 + LIT 16 CMOVE
1993 RP!
1994 LIT f_userBASE @ LIT #1A + 0! ;; READ-ONLY
1995 LIT f_userBASE @ LIT #34 + 0! ;; SHOW-HIDDEN
1996 LIT latest_word LIT forth_voc_latest !
1997 LIT f_cur7FFD C@ LIT #7FFD OUTP
1998 WARM
1999 $FORTH_END_WORD COLD
2002 ;; convert normal singed number to double
2003 $FORTH_CODE_WORD S->D
2004 ;; AberSoft
2005 ;; ( n -- d )
2006 pop de
2007 ld hl,0
2008 ld a,d
2009 and #80
2010 jr z,s2d0
2011 dec hl
2012 s2d0:
2013 jp i_pushde
2014 $FORTH_END_CODE_WORD S->D
2016 $FORTH_WORD +-
2017 ;; AberSoft
2018 0< 0BRANCH pm0
2019 NEGATE
2020 pm0:
2021 ;S
2022 $FORTH_END_WORD +-
2024 $FORTH_WORD D+-
2025 ;; AberSoft
2026 0< 0BRANCH dpm0
2027 DNEGATE
2028 dpm0:
2029 ;S
2030 $FORTH_END_WORD D+-
2032 $FORTH_WORD ABS
2033 ;; AberSoft
2034 DUP +- ;S
2035 $FORTH_END_WORD ABS
2037 $FORTH_WORD DABS
2038 ;; AberSoft
2039 DUP D+- ;S
2040 $FORTH_END_WORD DABS
2042 $FORTH_WORD MIN
2043 ;; AberSoft
2044 2DUP > 0BRANCH min0
2045 SWAP
2046 min0:
2047 DROP
2048 ;S
2049 $FORTH_END_WORD MIN
2051 $FORTH_WORD MAX
2052 ;; AberSoft
2053 2DUP < 0BRANCH max0
2054 SWAP
2055 max0:
2056 DROP
2057 ;S
2058 $FORTH_END_WORD MAX
2060 $FORTH_WORD UMIN
2061 ;; AberSoft
2062 2DUP U> 0BRANCH umin0
2063 SWAP
2064 umin0:
2065 DROP
2066 ;S
2067 $FORTH_END_WORD UMIN
2069 $FORTH_WORD UMAX
2070 ;; AberSoft
2071 2DUP U< 0BRANCH umax0
2072 SWAP
2073 umax0:
2074 DROP
2075 ;S
2076 $FORTH_END_WORD UMAX
2079 $FORTH_WORD M*
2080 ;; AberSoft
2081 2DUP XOR >R ABS SWAP ABS U* R> D+- ;S
2082 $FORTH_END_WORD M*
2084 $FORTH_WORD M/
2085 ;; AberSoft
2086 OVER >R >R DABS R@ ABS U/MOD R> R@ XOR +- SWAP R> +- SWAP ;S
2087 $FORTH_END_WORD M/
2089 $FORTH_WORD *
2090 ;; AberSoft
2091 M* DROP ;S
2092 $FORTH_END_WORD *
2094 $FORTH_WORD /MOD
2095 ;; AberSoft
2096 >R S->D R> M/ ;S
2097 $FORTH_END_WORD /MOD
2099 $FORTH_WORD /
2100 ;; AberSoft
2101 /MOD SWAP DROP ;S
2102 $FORTH_END_WORD /
2104 $FORTH_WORD MOD
2105 ;; AberSoft
2106 /MOD DROP ;S
2107 $FORTH_END_WORD MOD
2109 $FORTH_WORD */MOD
2110 ;; AberSoft
2111 >R M* R> M/ ;S
2112 $FORTH_END_WORD */MOD
2114 $FORTH_WORD */
2115 ;; AberSoft
2116 */MOD SWAP DROP ;S
2117 $FORTH_END_WORD */
2119 $FORTH_WORD M/MOD
2120 ;; AberSoft
2121 >R 0 R@ U/MOD R> SWAP >R U/MOD R> ;S
2122 $FORTH_END_WORD M/MOD
2125 ;; show warning message
2126 $FORTH_WORD MESSAGE
2127 ;; AberSoft
2128 ;; ( num -- )
2129 ;; show warning text?
2130 WARNING @ 0BRANCH message1
2131 ;; message #0 is "word?" show no warning text
2132 -DUP 0BRANCH message0
2133 ;; show message line
2134 4 OFFSET @ b/SCR / - .LINE SPACE
2135 message0:
2136 BRANCH message2
2137 message1:
2138 (.") ~MSG #~ . ;; "
2139 message2:
2140 ;S
2141 $FORTH_END_WORD MESSAGE
2144 $FORTH_WORD ' IMM
2145 ;; AberSoft
2146 -FIND 0= 0 ?ERROR DROP LITERAL ;S
2147 $FORTH_END_WORD '
2149 $FORTH_WORD BACK
2150 ;; AberSoft
2151 HERE - , ;S
2152 $FORTH_END_WORD BACK
2154 $FORTH_WORD BEGIN IMM
2155 ;; AberSoft
2156 ?COMP HERE 1 ;S
2157 $FORTH_END_WORD BEGIN
2159 $FORTH_WORD ENDIF IMM
2160 ;; AberSoft
2161 ?COMP 2 ?PAIRS HERE OVER - SWAP ! ;S
2162 $FORTH_END_WORD ENDIF
2164 $FORTH_WORD THEN IMM
2165 ;; AberSoft
2166 ENDIF ;S
2167 $FORTH_END_WORD THEN
2169 $FORTH_WORD DO IMM
2170 ;; AberSoft
2171 COMPILE (DO)
2172 HERE 3 ;S
2173 $FORTH_END_WORD DO
2175 $FORTH_WORD LOOP IMM
2176 ;; AberSoft
2177 3 ?PAIRS COMPILE (LOOP)
2178 BACK ;S
2179 $FORTH_END_WORD LOOP
2181 $FORTH_WORD +LOOP IMM
2182 ;; AberSoft
2183 3 ?PAIRS COMPILE (+LOOP)
2184 BACK ;S
2185 $FORTH_END_WORD +LOOP
2187 $FORTH_WORD UNTIL IMM
2188 ;; AberSoft
2189 1 ?PAIRS COMPILE 0BRANCH
2190 BACK ;S
2191 $FORTH_END_WORD UNTIL
2193 $FORTH_WORD END IMM
2194 ;; AberSoft
2195 UNTIL ;S
2196 $FORTH_END_WORD END
2198 $FORTH_WORD AGAIN IMM
2199 ;; AberSoft
2200 1 ?PAIRS COMPILE BRANCH
2201 BACK ;S
2202 $FORTH_END_WORD AGAIN
2204 $FORTH_WORD REPEAT IMM
2205 ;; AberSoft
2206 >R >R AGAIN R> R> 2- ENDIF ;S
2207 $FORTH_END_WORD REPEAT
2209 $FORTH_WORD IF IMM
2210 ;; AberSoft
2211 COMPILE 0BRANCH
2212 HERE 0 , 2 ;S
2213 $FORTH_END_WORD IF
2215 $FORTH_WORD IFNOT IMM
2216 ;; k8
2217 COMPILE TBRANCH
2218 HERE 0 , 2 ;S
2219 $FORTH_END_WORD IFNOT
2221 $FORTH_WORD ELSE IMM
2222 ;; AberSoft
2223 2 ?PAIRS COMPILE BRANCH
2224 HERE 0 , SWAP 2 ENDIF 2 ;S
2225 $FORTH_END_WORD ELSE
2227 $FORTH_WORD WHILE IMM
2228 ;; AberSoft
2229 IF 2+ ;S
2230 $FORTH_END_WORD WHILE
2232 $FORTH_WORD <#
2233 ;; AberSoft
2234 PAD HLD ! ;S
2235 $FORTH_END_WORD <#
2237 $FORTH_WORD #>
2238 ;; AberSoft
2239 DROP DROP HLD @ PAD OVER - ;S
2240 $FORTH_END_WORD #>
2242 $FORTH_WORD SIGN
2243 ;; AberSoft
2244 ROT 0< 0BRANCH sign0
2245 LIT 45 HOLD
2246 sign0:
2247 ;S
2248 $FORTH_END_WORD SIGN
2250 $FORTH_WORD #
2251 ;; AberSoft
2252 BASE @ M/MOD ROT LIT 9 OVER < 0BRANCH sharp0
2253 LIT 7 +
2254 sharp0:
2255 LIT 48 + HOLD ;S
2256 $FORTH_END_WORD #
2258 $FORTH_WORD #S
2259 ;; AberSoft
2260 ns0:
2261 # OVER OVER OR 0= 0BRANCH ns0
2262 ;S
2263 $FORTH_END_WORD #S
2265 $FORTH_WORD D.R
2266 ;; AberSoft
2267 >R SWAP OVER DABS <# #S SIGN #> R> OVER - SPACES TYPE ;S
2268 $FORTH_END_WORD D.R
2270 $FORTH_WORD .R
2271 ;; AberSoft
2272 >R S->D R> D.R ;S
2273 $FORTH_END_WORD .R
2275 $FORTH_WORD D.
2276 ;; AberSoft
2277 0 D.R SPACE ;S
2278 $FORTH_END_WORD D.
2280 $FORTH_WORD .
2281 ;; AberSoft
2282 S->D D. ;S
2283 $FORTH_END_WORD .
2285 $FORTH_WORD ?
2286 ;; AberSoft
2287 @ . ;S
2288 $FORTH_END_WORD ?
2290 $FORTH_WORD U.
2291 ;; AberSoft
2292 0 D. ;S
2293 $FORTH_END_WORD U.
2295 $FORTH_WORD KEY-WAIT-CR-SPACE
2296 ;; k8
2297 ;; ( -- )
2298 key_wait_cr_space_loop:
2299 KEY
2300 DUP LIT 13 = SWAP LIT 32 = OR
2301 0BRANCH key_wait_cr_space_loop
2302 ;S
2303 $FORTH_END_WORD KEY-WAIT-CR-SPACE
2305 $FORTH_WORD KEY-SCROLL-MSG-WAIT
2306 ;; k8
2307 ;; ( -- )
2308 (.") "\r<press ENTER...>" ;;"
2309 KEY-WAIT-CR-SPACE
2310 EMITCR CONWIDTH 1- SPACES EMITCR
2311 ;S
2312 $FORTH_END_WORD KEY-SCROLL-MSG-WAIT
2314 ;; k8
2315 $FORTH_VAR (SCROLL-CRCOUNT) 0
2316 $FORTH_VAR (SCROLL-CRMAX) 20
2318 $FORTH_WORD (SCROLL-CR-RESET)
2319 ;; k8
2320 ;; ( -- )
2321 (SCROLL-CRCOUNT) 0! ;S
2322 $FORTH_END_WORD (SCROLL-CR-RESET)
2324 $FORTH_WORD (SCROLL-CR)
2325 ;; k8
2326 ;; ( -- )
2327 CR
2328 (SCROLL-CRCOUNT) @ 1+
2329 DUP (SCROLL-CRMAX) @ >= 0BRANCH words_cr_nowait
2330 KEY-SCROLL-MSG-WAIT
2331 DROP 0
2332 words_cr_nowait:
2333 (SCROLL-CRCOUNT) !
2334 ;S
2335 $FORTH_END_WORD (SCROLL-CR)
2337 $FORTH_WORD WORDS
2338 ;; AberSoft, k8
2339 ;; ( -- )
2340 0 >R CONTEXT @ @
2341 (SCROLL-CR-RESET)
2343 vlist0:
2344 SHOW-HIDDEN @ 0= 0BRANCH vlist0_1
2345 ;; check if hidden word
2346 DUP 1+ C@ LIT 40 - 0BRANCH vlist4
2348 vlist0_1:
2349 DUP C@ LIT 31 AND R@ SWAP - DUP 0< 0BRANCH vlist1
2350 (SCROLL-CR) DROP DUP C@ LIT 31 AND CONWIDTH SWAP -
2351 vlist1:
2352 RDROP >R
2354 DUP
2355 ;; ID.
2356 COUNT LIT 31 AND -DUP 0BRANCH vlistT9
2357 0 (DO)
2358 vlistT1:
2359 DUP C@ LIT 127 AND XEMIT 1+
2360 (LOOP) vlistT1
2361 vlistT9:
2362 DROP
2364 R@ 0= 0BRANCH vlist2
2365 (SCROLL-CR) RDROP CONWIDTH BRANCH vlist3
2366 vlist2:
2367 SPACE R> 1-
2369 vlist3:
2370 >R
2371 vlist4:
2372 PFA LFA @ DUP 0= ?BREAK OR
2373 0BRANCH vlist0
2374 R> 2DROP ;S
2375 $FORTH_END_WORD WORDS
2378 $FORTH_WORD LIST
2379 ;; AberSoft
2380 DECIMAL CR DUP SCR ! (.") ~SCR #~ . ;; "
2381 LIT 16 0 (DO)
2382 list0:
2383 CR I 3 .R SPACE I SCR @ .LINE ?BREAK 0BRANCH list1
2384 LEAVE
2385 list1:
2386 (LOOP) list0
2387 CR ;S
2388 $FORTH_END_WORD LIST
2390 ;; read next word from the input stream
2391 ;; place it at PAD as the counted string
2392 $FORTH_WORD TEXT
2393 ;; AberSoft, k8
2394 ;; ( delimeter -- )
2395 HERE c/l 1+ BLANKS
2396 WORD PAD c/l 1+ CMOVE ;S
2397 $FORTH_END_WORD TEXT
2399 $FORTH_WORD LINE
2400 ;; AberSoft
2401 DUP LIT #FFF0 AND LIT 23 ?ERROR SCR @ (LINE) DROP ;S
2402 $FORTH_END_WORD LINE
2404 $FORTH_WORD SIZE
2405 ;; AberSoft
2406 HERE 0 +ORIGIN - ;S
2407 $FORTH_END_WORD SIZE
2409 $FORTH_WORD FREE
2410 ;; AberSoft
2411 SP@ HERE - ;S
2412 $FORTH_END_WORD FREE
2414 $FORTH_WORD FORGET
2415 ;; AberSoft
2416 CURRENT @ CONTEXT @ - LIT 24 ?ERROR
2417 ' DUP FENCE @ U< LIT 21 ?ERROR
2418 DUP NFA DP ! LFA @ CURRENT @ ! ;S
2419 $FORTH_END_WORD FORGET
2421 $FORTH_WORD U.R
2422 ;; AberSoft
2423 >R 0 R> D.R ;S
2424 $FORTH_END_WORD U.R
2426 $FORTH_WORD EXIT
2427 ;; AberSoft
2428 RDROP ;S
2429 $FORTH_END_WORD EXIT
2431 $FORTH_WORD CASE IMM
2432 ;; AberSoft
2433 ?COMP CSP @ !CSP 4 ;S
2434 $FORTH_END_WORD CASE
2436 $FORTH_WORD OF IMM
2437 ;; AberSoft
2438 4 ?PAIRS COMPILE OVER
2439 COMPILE =
2440 COMPILE 0BRANCH
2441 HERE 0 , COMPILE DROP
2442 LIT 5 ;S
2443 $FORTH_END_WORD OF
2445 $FORTH_WORD ENDOF IMM
2446 ;; AberSoft
2447 LIT 5 ?PAIRS COMPILE BRANCH
2448 HERE 0 , SWAP 2 ENDIF 4 ;S
2449 $FORTH_END_WORD ENDOF
2451 $FORTH_WORD OTHERWISE IMM
2452 ;; k8
2453 ;; part of CASE: OTHERWISE ( val ) ... ENDOF
2454 4 ?PAIRS
2455 COMPILE 0BRANCH
2456 HERE 0 ,
2457 LIT 5 ;S
2458 $FORTH_END_WORD OTHERWISE
2460 $FORTH_WORD ENDCASE IMM
2461 ;; AberSoft
2462 4 ?PAIRS
2463 COMPILE DROP
2464 endcase0:
2465 SP@ CSP @ = 0=
2466 0BRANCH endcase1
2467 2 ENDIF
2468 BRANCH endcase0
2469 endcase1:
2470 CSP !
2471 ;S
2472 $FORTH_END_WORD ENDCASE
2475 ;; FORTH vocabulary
2476 $FORTH_DOES FORTH voc_does IMM
2477 ;; k8, AberSoft
2478 defw #A081 ;; name
2479 forth_voc_latest:
2480 defw latest_word ;; prev voc latest
2481 forth_voc_link:
2482 defw 0 ;; prev voc-link
2484 $FORTH_WORD VOCABULARY
2485 ;; AberSoft
2486 <BUILDS LIT #A081 , CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES>
2487 voc_does:
2488 2+ CONTEXT ! ;S
2489 $FORTH_END_WORD VOCABULARY
2491 ;; VOCABULARY BODY:
2492 ;; "DOES>" ptr
2493 ;; name: " "
2494 ;; lfa
2495 ;; old voc-link
2498 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2499 ;; buffers, blocks, etc...
2500 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2501 include "trdos.zas"
2502 include "blocks.zas"
2503 include "textfile.zas"
2504 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2505 ;; end of buffers, blocks, etc...
2506 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2508 include "ext0.zas"
2509 include "dump.zas"
2511 ;;;;;;;;;;;;;;;;;;;; INSERT YOUR WORDS BELOW ;;;;;;;;;;;;;;;;;;;;
2512 ;;
2513 ;;
2514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2516 ;;!!!!!! THIS LABEL SHOULD BE JUST BEFORE THE LAST DEFINED WORD
2517 latest_word:
2518 ;;!!!!!! DO NOT REMOVE THIS WORD! THE SYSTEM USES IT
2519 $FORTH_WORD NOOP
2520 ;S
2521 $FORTH_END_WORD NOOP
2523 latest_byte: defw 666