| blob | 49bee8418408ec71db96e19d7da3cf839b5f45aa |
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
16 ;; word format:
17 ;; db len_flags
18 ;; name
19 ;; dw lfa
20 ;; dw cfa
21 ;; ....
22 ;; len_flags:
23 ;; bits 0-4: length
24 ;; bit 5: SMUDGE flag (=1: word definition isn't finished)
25 ;; bit 6: IMMEDIATE flag (=1: true)
26 ;; bit 7: always 1
27 ;; the last byte of the name always has bit 7 set
28 ;;
29 ;; for CODE words: cfa points to the body
30 ;; for FORTH words: cfa points to "_doforth"
31 ;; for CONST words: cfa points to "_doconst"
32 ;; for VAR words: cfa points to "_dovar"
33 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
35 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;; tech info
37 ;; registers:
38 ;; BC: address interpreter insrtuction pointer
39 ;; IX: USER-var base
40 ;; IY: used by ROM, do not change
41 ;; all other regs are free
42 ;;
43 ;; stacks:
44 ;; data stack: machine stask (PUSH/POP)
45 ;; exec stack: address with f_curRP (last item)
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49 org #6000
50 ;; start address: #6000
51 run_cold:
52 di
53 jp run_0 ;; DO NOT CHANGE THIS TO JR!
54 run_warm:
55 di
56 ld bc,WARMbody
57 jr run_1
58 run_0:
59 ;; k8: test for 128k
60 push bc
61 ; save byte at #C000 for 48K
62 ld a,(#C000)
63 ex af,af'
64 ; check for 128K
65 ld hl,#4000
66 xor a
67 ; reset #C000
68 ld (#C000),a
69 ld (hl),a
70 ld bc,#7FFD
71 ld a,#15
72 out (c),a ;; now #C000 should be the screen page #5
73 ld (#C000),a ;; trash it
74 ld a,#10
75 out (c),a ;; and go back (just in case) %-)
76 ld a,(hl)
77 or a ;; now check if we really trashed the scrren
78 jr z,run_ok48
79 ld a,1
80 run_ok48:
81 ld (f_is128K),a
82 ; restore #C000
83 ex af,af'
84 ld (#C000),a
85 ld a,#08
86 ld (#5C6A),a ; CAPS
87 ld a,#3F
88 ld i,a
89 im 1
90 ld bc,COLDbody
91 run_1:
92 ld ix,(f_userBASE)
93 ld hl,(f_initSP)
94 ld sp,hl
95 ei
96 jr i_next
98 ;;;;;;;;;;;;;;; VARIABLES
99 ;; current RP
101 f_is128K: defb 0
102 f_cur7FFD: defb #10
103 f_curRP: defw #D7AE ;; ???
105 ;; address of the first "user" variable (def: run_cold-64)
106 f_userBASE: defw #D7B0
108 f_tib: defs 50,0
110 f_userDEF:
111 f_initSP:
112 defw #D600 ;; S0: starting SP. SP grows to addr #0000
113 defw #D7AE ;; R0: starting RP. RP grows to addr #0000
114 defw f_tib ;; TIB
115 defw 31 ;; WIDTH
116 defw 0 ;; WARNING
117 defw latest_byte ;; FENCE
118 defw latest_byte ;; DP
119 defw forth_voc_link ;; VOC-LINK
120 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
122 ;;; address interpreter
123 ;; AberSoft
124 i_pushde:
125 push de
126 i_pushhl:
127 push hl
128 i_next:
129 ld a,(bc)
130 inc bc
131 ld l,a
132 ld a,(bc)
133 inc bc
134 ld h,a
135 iexecx:
136 ld e,(hl)
137 inc hl
138 ld d,(hl)
139 ex de,hl
140 ; debug label
141 i_next_jmp:
142 jp (hl)
143 ;;; end of address interpreter
146 $FORTH_CONST (.NEXT) i_next
147 $FORTH_CONST (.PUSHHL) i_pushhl
148 $FORTH_CONST (.PUSHDEHL) i_pushde
149 $FORTH_CONST (@CUR-RP) f_curRP
150 $FORTH_CONST (@CUR-BASE) f_userBASE
151 $FORTH_CONST (LAST-7FFD) f_cur7FFD
154 ;; 6x8 printing driver
155 include "emit6.zas"
156 include "key6.zas"
159 $FORTH_CODE_WORD BYE
160 ;; return to TR-DOS
161 jp #3D00
162 ;;;; return to BASIC?
163 ;; LD A,#17
164 ;; LD (f_cur7FFD),A
165 ;; LD BC,#7FFD
166 ;; OUT (C),A
167 ;; LD HL,0
168 ;; PUSH HL
169 ;; JP #3D2F
170 $FORTH_END_CODE_WORD BYE
172 $FORTH_CODE_WORD 128K?
173 ld a,(f_is128K)
174 cw_is_128k_done:
175 ld l,a
176 ld h,0
177 jp i_pushhl
178 $FORTH_END_CODE_WORD 128K?
180 $FORTH_CODE_WORD 48K?
181 ld a,(f_is128K)
182 or a
183 ld a,1
184 jr z,cw_is_128k_done
185 xor a
186 jr cw_is_128k_done
187 $FORTH_END_CODE_WORD 48K?
189 $FORTH_WORD .CREDITZ
190 ;; k8
191 (.") ~\n48K/128K dsFORTH v0.0.1\n~
192 (.") ~original version: \x7F Abersoft, 1983\n~
193 (.") ~modifications by Ketmar//Invisible Vector\n~
194 ;; (.") ~distribution terms: GNU GPL\n~
195 ;S
196 $FORTH_END_WORD .CREDITZ
198 $FORTH_CODE_WORD LIT
199 ;; AberSoft
200 ld a,(bc)
201 inc bc
202 ld l,a
203 ld a,(bc)
204 inc bc
205 ld h,a
206 jp i_pushhl
207 $FORTH_END_CODE_WORD LIT
209 $FORTH_CODE_WORD EXECUTE
210 ;; AberSoft
211 ;; ( cfa )
212 pop hl
213 jp iexecx
214 $FORTH_END_CODE_WORD EXECUTE
216 $FORTH_CODE_WORD BRANCH FBRANCH
217 ;; AberSoft
218 BRANCHbody:
219 ld h,b
220 ld l,c
221 ld e,(hl)
222 inc hl
223 ld d,(hl)
224 dec hl
225 add hl,de
226 ld c,l
227 ld b,h
228 jp i_next
229 $FORTH_END_CODE_WORD BRANCH
231 $FORTH_CODE_WORD 0BRANCH FBRANCH
232 ;; AberSoft
233 pop hl
234 ld a,l
235 or h
236 jr z,BRANCHbody
237 branchskip:
238 inc bc
239 inc bc
240 jp i_next
241 $FORTH_END_CODE_WORD 0BRANCH
243 $FORTH_CODE_WORD TBRANCH FBRANCH
244 ;; k8
245 pop hl
246 ld a,l
247 or h
248 jr nz,BRANCHbody
249 jr branchskip
250 $FORTH_END_CODE_WORD TBRANCH
252 $FORTH_CODE_WORD (LOOP) FBRANCH
253 ;; AberSoft
254 ld de,1
255 xloop:
256 ld hl,(f_curRP)
257 ld a,(hl)
258 add a,e
259 ld (hl),a
260 ld e,a
261 inc hl
262 ld a,(hl)
263 adc a,d
264 ld (hl),a
265 inc hl
266 inc d
267 dec d
268 ld d,a
269 jp m,xloop0
270 ld a,e
271 sub (hl)
272 ld a,d
273 inc hl
274 sbc a,(hl)
275 jr xloop1
276 xloop0:
277 ld a,(hl)
278 sub e
279 inc hl
280 ld a,(hl)
281 sbc a,d
282 xloop1:
283 jp m,BRANCHbody
284 inc hl
285 ld (f_curRP),hl
286 inc bc
287 inc bc
288 jp i_next
289 $FORTH_END_CODE_WORD (LOOP)
291 $FORTH_CODE_WORD (+LOOP) FBRANCH
292 ;; AberSoft
293 pop de
294 jr xloop
295 $FORTH_END_CODE_WORD (+LOOP)
297 $FORTH_CODE_WORD (DO)
298 ;; AberSoft
299 ld hl,(f_curRP)
300 dec hl
301 dec hl
302 dec hl
303 dec hl
304 ld (f_curRP),hl
305 pop de
306 ld (hl),e
307 inc hl
308 ld (hl),d
309 pop de
310 inc hl
311 ld (hl),e
312 inc hl
313 ld (hl),d
314 jp i_next
315 $FORTH_END_CODE_WORD (DO)
317 $FORTH_CODE_WORD I
318 ;; AberSoft
319 ld hl,(f_curRP)
320 ld e,(hl)
321 inc hl
322 ld d,(hl)
323 push de
324 jp i_next
325 $FORTH_END_CODE_WORD I
327 $FORTH_CODE_WORD I'
328 ;; AberSoft
329 ld hl,(f_curRP)
330 inc hl
331 inc hl
332 ld e,(hl)
333 inc hl
334 ld d,(hl)
335 push de
336 jp i_next
337 $FORTH_END_CODE_WORD I'
339 $FORTH_CODE_WORD J
340 ;; AberSoft
341 ld hl,(f_curRP)
342 inc hl
343 inc hl
344 inc hl
345 inc hl
346 ld e,(hl)
347 inc hl
348 ld d,(hl)
349 push de
350 jp i_next
351 $FORTH_END_CODE_WORD J
353 $FORTH_CODE_WORD DIGIT
354 ;; AberSoft
355 pop hl
356 pop de
357 ld a,e
358 sub #30
359 jp m,digit1
360 cp 10
361 jp m,digit0
362 sub 7
363 cp 10
364 jp m,digit1
365 digit0:
366 cp l
367 jp p,digit1
368 ld e,a
369 ld hl,1
370 jp i_pushde
371 digit1:
372 ld l,h
373 jp i_pushhl
374 $FORTH_END_CODE_WORD DIGIT
376 $FORTH_CODE_WORD (FIND)
377 ;; AberSoft
378 ;; ( addr l addr2 -- pfa b tf ok)
379 ;; ( addr l addr2 -- ff bad)
380 pop de
381 xfind0:
382 pop hl
383 push hl
384 ld a,(de)
385 xor (hl)
386 and #3F
387 jr nz,xfind4
388 xfind1:
389 inc hl
390 inc de
391 ld a,(de)
392 xor (hl)
393 add a,a
394 jr nz,xfind3
395 jr nc,xfind1
396 ld hl,5
397 add hl,de
398 ex (sp),hl
399 xfind2:
400 dec de
401 ld a,(de)
402 or a
403 jp p,xfind2
404 ld e,a
405 ld d,0
406 ld hl,1
407 jp i_pushde
408 xfind3:
409 jr c,xfind5
410 xfind4:
411 inc de
412 ld a,(de)
413 or a
414 jp p,xfind4
415 xfind5:
416 inc de
417 ex de,hl
418 ld e,(hl)
419 inc hl
420 ld d,(hl)
421 ld a,d
422 or e
423 jr nz,xfind0
424 pop hl
425 ld hl,0
426 jp i_pushhl
427 $FORTH_END_CODE_WORD (FIND)
429 $FORTH_CODE_WORD ENCLOSE
430 ;; AberSoft
431 ;; ( addr delimeter -- addr w_start_ofs w_end_ofs next_scan_ofs )
432 pop de ;; E=delimeter
433 pop hl ;; HL=addr
434 push hl
436 ld a,e
437 ld d,a
438 ld e,#FF
439 dec hl
441 ;; here: E=word len; A=delim; HL=addr
442 enclose0:
443 ;; skip delimiters
444 inc hl
445 inc e
446 cp (hl)
447 jr z,enclose0
449 ld d,0
450 push de ;; store # of delimiters before the word
452 ld d,a ;; D=delimiter
453 ;; check for "end of buffer" (#0)
454 ld a,(hl)
455 and a
456 jr nz,enclose1
458 ;; oops... no more blondies on the island
459 ld d,0
460 inc e
461 push de ;; store full length
463 dec e
464 push de ;; store position of the next char to scan
465 jp i_next
467 ;; here: E=word len; D=delim; HL=addr
468 enclose1:
469 ;; now collect the word itself
470 ld a,d
471 inc hl
472 inc e
473 cp (hl)
474 jr z,enclose2 ;; word ends?
475 ;; no, check "end of buffer"
476 ld a,(hl)
477 and a
478 jr nz,enclose1
480 ;; oops... no more blondies on the island
481 ld d,0
482 push de ;; store full length
483 push de ;; store position of the next char to scan (???)
484 jp i_next
486 enclose2:
487 ld d,0
488 push de ;; store full length
489 inc e
490 push de ;; store position of the next char to scan
491 jp i_next
492 $FORTH_END_CODE_WORD ENCLOSE
494 ;; check if BREAK is pressed
495 $FORTH_CODE_WORD ?BREAK
496 ;; AberSoft, k8
497 ;; ( -- break_flag)
498 ld hl,0
499 call #1F54 ;; uses only A
500 jr c,term0
501 inc l
502 term0:
503 jp i_pushhl
504 $FORTH_END_CODE_WORD ?BREAK
506 $FORTH_CODE_WORD PAGE-CMOVE
507 ;; k8
508 ;; CMOVE with page swapping
509 ;; ( from to len destpage -- )
510 ;; addr must be >= #C000
511 pop de ; destpage
512 ld a,e
513 ;;AND #07 ; we can have much more memory
514 ; get other args and save BC
515 ld l,c
516 ld h,b
517 pop bc ; length
518 pop de ; dest
519 ex (sp),hl ; save BC and get src
520 ld a,b
521 or c
522 jr z,cmove0
523 ; move
524 exx
525 ld bc,#7FFD
526 di
527 out (c),a
528 exx
529 ldir
530 exx
531 ld a,(f_cur7FFD)
532 out (c),a
533 ei
534 jr cmove0
535 $FORTH_END_CODE_WORD PAGE-CMOVE
537 $FORTH_CODE_WORD CMOVE
538 ;; AberSoft
539 ;; ( from to len -- )
540 ld l,c
541 ld h,b
542 pop bc
543 pop de
544 ex (sp),hl
545 ld a,b
546 or c
547 jr z,cmove0
548 ldir
549 cmove0:
550 pop bc
551 jp i_next
552 $FORTH_END_CODE_WORD CMOVE
554 $FORTH_CODE_WORD FILL
555 ;; AberSoft
556 ld l,c
557 ld h,b
558 pop de
559 pop bc
560 ex (sp),hl
561 ex de,hl
562 fill0:
563 ld a,b
564 or c
565 jr z,fill1
566 ld a,l
567 ld (de),a
568 inc de
569 dec bc
570 jr fill0
571 fill1:
572 pop bc
573 jp i_next
574 $FORTH_END_CODE_WORD FILL
576 ;; include "fastmuldiv.zas"
577 include "fastmuldiv_small.zas"
579 $FORTH_CODE_WORD <<
580 ;; k8
581 ;; ( n -- n*2 )
582 pop hl
583 or a
584 rl l
585 rl h
586 jp i_pushhl
587 $FORTH_END_CODE_WORD <<
589 $FORTH_CODE_WORD >>
590 ;; k8
591 ;; ( n -- n*2 )
592 pop hl
593 or a
594 rr h
595 rr l
596 jp i_pushhl
597 $FORTH_END_CODE_WORD >>
599 $FORTH_CODE_WORD 256*
600 ;; k8
601 ;; ( n -- n*256 )
602 pop hl
603 ld h,l
604 ld l,0
605 jp i_pushhl
606 $FORTH_END_CODE_WORD 256*
608 $FORTH_CODE_WORD and
609 ;; AberSoft
610 ;; ( n0 n1 -- n )
611 pop de
612 pop hl
613 ld a,e
614 and l
615 ld l,a
616 ld a,d
617 and h
618 ld h,a
619 jp i_pushhl
620 $FORTH_END_CODE_WORD and
622 $FORTH_CODE_WORD or
623 ;; AberSoft
624 ;; ( n0 n1 -- n )
625 pop de
626 pop hl
627 ld a,e
628 or l
629 ld l,a
630 ld a,d
631 or h
632 ld h,a
633 jp i_pushhl
634 $FORTH_END_CODE_WORD or
636 $FORTH_CODE_WORD xor
637 ;; AberSoft
638 ;; ( n0 n1 -- n )
639 pop de
640 pop hl
641 ld a,e
642 xor l
643 ld l,a
644 ld a,d
645 xor h
646 ld h,a
647 jp i_pushhl
648 $FORTH_END_CODE_WORD xor
650 ;; get current SP
651 $FORTH_CODE_WORD SP@
652 ;; AberSoft
653 ;; ( -- sp )
654 ld hl,0
655 add hl,sp
656 jp i_pushhl
657 $FORTH_END_CODE_WORD SP@
659 $FORTH_CODE_WORD sp!
660 ;; AberSoft
661 ;; SP := [SP0]
662 ld e,(ix+6)
663 ld d,(ix+7)
664 ex de,hl
665 ld sp,hl
666 jp i_next
667 $FORTH_END_CODE_WORD sp!
669 ;; get current RP
670 $FORTH_CODE_WORD RP@
671 ;; AberSoft
672 ;; ( -- rp )
673 ld hl,(f_curRP)
674 jp i_pushhl
675 $FORTH_END_CODE_WORD RP@
677 $FORTH_CODE_WORD RP!
678 ;; AberSoft
679 ;; RP := [RP0]
680 ld e,(ix+8)
681 ld d,(ix+9)
682 ex de,hl
683 jr rsetrpnext
684 $FORTH_END_CODE_WORD RP!
686 ;; end of "colon" word
687 ;; break "LOAD"
688 $FORTH_CODE_WORD ;S
689 ;; AberSoft
690 ;; ( -- )
691 ld hl,(f_curRP)
692 ld c,(hl)
693 inc hl
694 ld b,(hl)
695 inc hl
696 jr rsetrpnext
697 $FORTH_END_CODE_WORD ;S
699 ;; DO/LOOP will stop on the next iteration
700 $FORTH_CODE_WORD LEAVE
701 ;; AberSoft
702 ;; ( -- )
703 ld hl,(f_curRP)
704 ld e,(hl)
705 inc hl
706 ld d,(hl)
707 inc hl
708 ld (hl),e
709 inc hl
710 ld (hl),d
711 jp i_next
712 $FORTH_END_CODE_WORD LEAVE
714 ;; move value from paremeter stack to execution stack
715 $FORTH_CODE_WORD >R
716 ;; AberSoft
717 ;; ( n -- || n )
718 pop de
719 ld hl,(f_curRP)
720 dec hl
721 ld (hl),d
722 dec hl
723 ld (hl),e
724 rsetrpnext:
725 ld (f_curRP),hl
726 jp i_next
727 $FORTH_END_CODE_WORD >R
729 ;; move value from execution stack to paremeter stack
730 $FORTH_CODE_WORD R>
731 ;; AberSoft
732 ;; ( n || -- n )
733 ld hl,(f_curRP)
734 ld e,(hl)
735 inc hl
736 ld d,(hl)
737 inc hl
738 push de
739 jr rsetrpnext
740 $FORTH_END_CODE_WORD R>
742 ;; copy value from execution stack to paremeter stack
743 $FORTH_CODE_WORD R@
744 ;; AberSoft
745 ;; ( n || -- n || n)
746 ld hl,(f_curRP)
747 ld e,(hl)
748 inc hl
749 ld d,(hl)
750 push de
751 jp i_next
752 $FORTH_END_CODE_WORD R@
754 $FORTH_CODE_WORD RDROP
755 ;; k8
756 ;; ( || n -- || )
757 ld hl,(f_curRP)
758 inc hl
759 inc hl
760 jr rsetrpnext
761 $FORTH_END_CODE_WORD RDROP
764 $FORTH_CODE_WORD 0=
765 ;; AberSoft
766 ;; ( n -- flag )
767 zequ:
768 pop hl
769 ld a,l
770 or h
771 ld hl,0
772 jr nz,zequ0
773 inc hl
774 zequ0:
775 jp i_pushhl
776 $FORTH_END_CODE_WORD 0=
778 $FORTH_CODE_WORD NOT
779 ;; AberSoft
780 ;; ( n -- flag )
781 jr zequ
782 $FORTH_END_CODE_WORD NOT
784 $FORTH_CODE_WORD 0<
785 ;; k8
786 ;; ( n1 -- flag )
787 pop hl
788 ld a,h
789 ld hl,0
790 bit 7,a
791 jr z,zless0
792 inc hl
793 zless0:
794 jp i_pushhl
795 $FORTH_END_CODE_WORD 0<
797 $FORTH_CODE_WORD <
798 ;; AberSoft
799 ;; ( n0 n1 -- flag )
800 pop de
801 pop hl
802 ld a,d
803 xor h
804 jp m,less0
805 and a
806 sbc hl,de
807 less0:
808 inc h
809 dec h
810 jp m,less1
811 ld hl,0
812 jp i_pushhl
813 less1:
814 ld hl,1
815 jp i_pushhl
816 $FORTH_END_CODE_WORD <
818 $FORTH_WORD U<
819 ;; AberSoft
820 ;; ( n0 n1 -- flag )
821 2DUP XOR 0< 0BRANCH uless0
822 DROP 0< 0= BRANCH uless1
823 uless0:
824 - 0<
825 uless1:
826 ;S
827 $FORTH_END_WORD U<
829 $FORTH_WORD U>
830 ;; AberSoft
831 ;; ( n0 n1 -- flag )
832 >R 1- R> U< 0=
833 ;S
834 $FORTH_END_WORD U>
836 $FORTH_WORD >
837 ;; AberSoft
838 ;; ( n0 n1 -- flag )
839 SWAP < ;S
840 $FORTH_END_WORD >
842 $FORTH_WORD =
843 ;; AberSoft
844 ;; ( n0 n1 -- flag )
845 - 0= ;S
846 $FORTH_END_WORD =
848 $FORTH_WORD <>
849 ;; k8
850 ;; ( n0 n1 -- flag )
851 - 0= 0= ;S
852 $FORTH_END_WORD <>
854 $FORTH_WORD <=
855 ;; k8
856 ;; ( n0 n1 -- flag )
857 2DUP < >R = R> OR ;S
858 $FORTH_END_WORD <=
860 $FORTH_WORD >=
861 ;; k8
862 ;; ( n0 n1 -- flag )
863 2DUP > >R = R> OR ;S
864 $FORTH_END_WORD >=
866 $FORTH_CODE_WORD 1+
867 ;; k8
868 pop hl
869 inc hl
870 jp i_pushhl
871 $FORTH_END_CODE_WORD 1+
873 $FORTH_CODE_WORD 2+
874 ;; k8
875 pop hl
876 inc hl
877 inc hl
878 jp i_pushhl
879 $FORTH_END_CODE_WORD 2+
881 $FORTH_CODE_WORD 4+
882 ;; k8
883 pop hl
884 inc hl
885 inc hl
886 inc hl
887 inc hl
888 jp i_pushhl
889 $FORTH_END_CODE_WORD 4+
891 $FORTH_CODE_WORD 1-
892 ;; k8
893 pop hl
894 dec hl
895 jp i_pushhl
896 $FORTH_END_CODE_WORD 1-
898 $FORTH_CODE_WORD 2-
899 ;; k8
900 pop hl
901 dec hl
902 dec hl
903 jp i_pushhl
904 $FORTH_END_CODE_WORD 2-
906 $FORTH_CODE_WORD 4-
907 ;; k8
908 pop hl
909 dec hl
910 dec hl
911 dec hl
912 dec hl
913 jp i_pushhl
914 $FORTH_END_CODE_WORD 4-
916 $FORTH_CODE_WORD +
917 ;; AberSoft
918 ;; ( n0 n1 -- n )
919 pop de
920 pop hl
921 add hl,de
922 jp i_pushhl
923 $FORTH_END_CODE_WORD +
925 $FORTH_CODE_WORD -
926 ;; AberSoft
927 ;; ( n0 n1 -- n )
928 pop de
929 pop hl
930 and a
931 sbc hl,de
932 jp i_pushhl
933 $FORTH_END_CODE_WORD -
935 $FORTH_CODE_WORD d+
936 ;; AberSoft
937 ;; ( d0 d1 -- d )
938 ld hl,6
939 add hl,sp
940 ld e,(hl)
941 ld (hl),c
942 inc hl
943 ld d,(hl)
944 ld (hl),b
945 pop bc
946 pop hl
947 add hl,de
948 ex de,hl
949 pop hl
950 sbc hl,bc
951 pop bc
952 push de
953 jp i_pushhl
954 $FORTH_END_CODE_WORD d+
956 ;; change sign
957 ;; TODO: error on -32768?
958 $FORTH_CODE_WORD NEGATE
959 ;; AberSoft
960 ;; ( n -- -n )
961 pop de
962 ld hl,0
963 and a
964 sbc hl,de
965 jp i_pushhl
966 $FORTH_END_CODE_WORD NEGATE
968 ;; change sign
969 ;; TODO: error on MAXLONGINT?
970 $FORTH_CODE_WORD DNEGATE
971 ;; AberSoft
972 ;; ( d -- -d )
973 pop hl
974 pop de
975 sub a
976 sub e
977 ld e,a
978 ld a,0
979 sbc a,d
980 ld d,a
981 ld a,0
982 sbc a,l
983 ld l,a
984 ld a,0
985 sbc a,h
986 ld h,a
987 push de
988 jp i_pushhl
989 $FORTH_END_CODE_WORD DNEGATE
991 $FORTH_CODE_WORD DROP
992 ;; AberSoft
993 ;; ( n -- )
994 doonedrop:
995 pop hl
996 jp i_next
997 $FORTH_END_CODE_WORD DROP
999 $FORTH_CODE_WORD 2DROP
1000 ;; k8
1001 ;; ( n0 n1 -- )
1002 pop hl
1003 jr doonedrop
1004 $FORTH_END_CODE_WORD 2DROP
1006 $FORTH_CODE_WORD OVER
1007 ;; AberSoft
1008 ;; ( n0 n1 -- n0 n1 n0 )
1009 pop de
1010 pop hl
1011 push hl
1012 jp i_pushde
1013 $FORTH_END_CODE_WORD OVER
1015 $FORTH_WORD 2OVER
1016 ;; AberSoft
1017 ;; ( d0 d1 -- d0 d1 d0 )
1018 ;; k8: rewrite on asm?
1019 2SWAP 2DUP >R >R 2SWAP R> R> ;S
1020 $FORTH_END_WORD 2OVER
1022 $FORTH_CODE_WORD SWAP
1023 ;; AberSoft
1024 ;; ( n0 n1 -- n1 n0 )
1025 pop hl
1026 ex (sp),hl
1027 jp i_pushhl
1028 $FORTH_END_CODE_WORD SWAP
1030 $FORTH_WORD 2SWAP
1031 ;; AberSoft
1032 ;; ( d0 d1 -- d1 d0 )
1033 ;; k8: rewrite on asm?
1034 ROT >R ROT R> ;S
1035 $FORTH_END_WORD 2SWAP
1037 $FORTH_CODE_WORD dup
1038 ;; AberSoft
1039 ;; ( n -- n n )
1040 pop hl
1041 push hl
1042 jp i_pushhl
1043 $FORTH_END_CODE_WORD dup
1045 $FORTH_CODE_WORD -dup
1046 ;; k8
1047 ;; ( n -- n n ) if n is not 0
1048 ;; ( n -- n ) if n is 0
1049 pop hl
1050 push hl
1051 ld a,l
1052 or h
1053 jp z,i_next
1054 jp i_pushhl
1055 $FORTH_END_CODE_WORD -dup
1057 $FORTH_CODE_WORD 2DUP
1058 ;; AberSoft
1059 ;; ( d -- d d )
1060 pop hl
1061 pop de
1062 push de
1063 push hl
1064 jp i_pushde
1065 $FORTH_END_CODE_WORD 2DUP
1067 $FORTH_CODE_WORD ROT
1068 ;; AberSoft
1069 ;; ( n0 n1 n2 -- n1 n2 n0 )
1070 pop de
1071 pop hl
1072 ex (sp),hl
1073 jp i_pushde
1074 $FORTH_END_CODE_WORD ROT
1076 $FORTH_CODE_WORD +!
1077 ;; AberSoft
1078 ;; ( n a -- )
1079 pop hl
1080 pop de
1081 ld a,(hl)
1082 add a,e
1083 ld (hl),a
1084 inc hl
1085 ld a,(hl)
1086 adc a,d
1087 ld (hl),a
1088 jp i_next
1089 $FORTH_END_CODE_WORD +!
1091 $FORTH_CODE_WORD TOGGLE
1092 ;; AberSoft
1093 ;; ( a n -- )
1094 pop de
1095 pop hl
1096 ld a,(hl)
1097 xor e
1098 ld (hl),a
1099 jp i_next
1100 $FORTH_END_CODE_WORD TOGGLE
1102 $FORTH_CODE_WORD 2@
1103 ;; AberSoft
1104 ;; ( a -- d )
1105 pop hl
1106 inc hl
1107 inc hl
1108 ld e,(hl)
1109 inc hl
1110 ld d,(hl)
1111 push de
1112 dec hl
1113 dec hl
1114 ld d,(hl)
1115 dec hl
1116 ld e,(hl)
1117 push de
1118 jp i_next
1119 $FORTH_END_CODE_WORD 2@
1121 $FORTH_CODE_WORD C@
1122 ;; AberSoft
1123 ;; ( a -- c )
1124 pop hl
1125 ld l,(hl)
1126 ld h,0
1127 jp i_pushhl
1128 $FORTH_END_CODE_WORD C@
1130 $FORTH_CODE_WORD @
1131 ;; AberSoft
1132 ;; ( a -- n )
1133 pop hl
1134 ld e,(hl)
1135 inc hl
1136 ld d,(hl)
1137 push de
1138 jp i_next
1139 $FORTH_END_CODE_WORD @
1141 $FORTH_CODE_WORD 2!
1142 ;; AberSoft
1143 ;; ( a -- d )
1144 pop hl
1145 pop de
1146 ld (hl),e
1147 inc hl
1148 ld (hl),d
1149 inc hl
1150 pop de
1151 ld (hl),e
1152 inc hl
1153 ld (hl),d
1154 jp i_next
1155 $FORTH_END_CODE_WORD 2!
1157 $FORTH_CODE_WORD c!
1158 ;; AberSoft
1159 ;; ( a -- c )
1160 pop hl
1161 pop de
1162 ld (hl),e
1163 jp i_next
1164 $FORTH_END_CODE_WORD c!
1166 $FORTH_CODE_WORD !
1167 ;; AberSoft
1168 ;; ( n a -- )
1169 pop hl
1170 pop de
1171 ld (hl),e
1172 inc hl
1173 ld (hl),d
1174 jp i_next
1175 $FORTH_END_CODE_WORD !
1177 $FORTH_CODE_WORD 0C!
1178 ;; AberSoft
1179 ;; ( a -- )
1180 pop hl
1181 ld (hl),0
1182 jp i_next
1183 $FORTH_END_CODE_WORD 0C!
1185 $FORTH_CODE_WORD 0!
1186 ;; AberSoft
1187 ;; ( a -- )
1188 pop hl
1189 ld (hl),0
1190 inc hl
1191 ld (hl),0
1192 jp i_next
1193 $FORTH_END_CODE_WORD 0!
1195 $FORTH_CODE_WORD 1C!
1196 ;; k8
1197 ;; ( a -- )
1198 pop hl
1199 ld (hl),1
1200 jp i_next
1201 $FORTH_END_CODE_WORD 1C!
1203 $FORTH_CODE_WORD 1!
1204 ;; k8
1205 ;; ( a -- )
1206 pop hl
1207 ld (hl),1
1208 inc hl
1209 ld (hl),0
1210 jp i_next
1211 $FORTH_END_CODE_WORD 1!
1214 $FORTH_CODE_WORD FORTH-WORD?
1215 ;; k8
1216 ;; ( pfa -- flag )
1217 pop hl
1218 dec hl
1219 ld d, (hl)
1220 dec hl
1221 ld e, (hl)
1222 ld hl,_doforth
1223 sbc hl,de
1224 ld a,h
1225 or l
1226 ld hl,1
1227 jr z,isfword0
1228 dec l
1229 isfword0:
1230 jp i_pushhl
1231 $FORTH_END_CODE_WORD FORTH-WORD?
1234 $FORTH_WORD : IMM
1235 ;; AberSoft
1236 ?EXEC !CSP CURRENT @ CONTEXT ! CREATE ]
1237 (;CODE)
1238 $FORTH_END_WORD :
1239 _doforth:
1240 ld hl,(f_curRP)
1241 dec hl
1242 ld (hl),b
1243 dec hl
1244 ld (hl),c
1245 ld (f_curRP),hl
1246 inc de
1247 ld c,e
1248 ld b,d
1249 _doforth_dbg:
1250 jp i_next
1252 $FORTH_WORD ; IMM
1253 ;; AberSoft
1254 ?CSP COMPILE ;S
1255 SMUDGE [ ;S
1256 $FORTH_END_WORD ;
1258 $FORTH_WORD CONSTANT
1259 ;; AberSoft
1260 CREATE SMUDGE ,
1261 (;CODE)
1262 $FORTH_END_WORD CONSTANT
1263 _doconst:
1264 inc de
1265 ex de,hl
1266 ld e,(hl)
1267 inc hl
1268 ld d,(hl)
1269 doxvarx:
1270 push de
1271 jp i_next
1273 $FORTH_WORD VARIABLE
1274 ;; AberSoft
1275 CONSTANT (;CODE)
1276 $FORTH_END_WORD VARIABLE
1277 _dovar:
1278 inc de
1279 jr doxvarx
1281 $FORTH_WORD 2CONSTANT
1282 ;; AberSoft
1283 CREATE SMUDGE HERE 2! 4 ALLOT
1284 (;CODE)
1285 $FORTH_END_WORD 2CONSTANT
1286 _do2const:
1287 inc de
1288 ex de,hl
1289 inc hl
1290 inc hl
1291 ld e,(hl)
1292 inc hl
1293 ld d,(hl)
1294 push de
1295 dec hl
1296 dec hl
1297 ld d,(hl)
1298 dec hl
1299 ld e,(hl)
1300 jr doxvarx
1302 $FORTH_WORD 2VARIABLE
1303 ;; AberSoft
1304 2CONSTANT
1305 (;CODE)
1306 $FORTH_END_WORD 2VARIABLE
1307 _do2var:
1308 jr _dovar
1309 ;; INC DE
1310 ;; PUSH DE
1311 ;; JP i_next
1313 $FORTH_WORD USER
1314 ;; AberSoft
1315 CONSTANT (;CODE)
1316 $FORTH_END_WORD USER
1317 _douser:
1318 inc de
1319 ex de,hl
1320 ld e,(hl)
1321 ld d,0
1322 push ix
1323 pop hl
1324 add hl,de
1325 jp i_pushhl
1327 ;;;;;;;;;;;;;; some speedup constants
1328 $FORTH_CONST 0 0
1329 $FORTH_CONST 1 1
1330 $FORTH_CONST 2 2
1331 $FORTH_CONST 3 3
1332 $FORTH_CONST 4 4
1333 $FORTH_CONST BL 32
1335 $FORTH_CONST c/l #40
1337 $FORTH_WORD +ORIGIN
1338 LIT run_cold + ;S
1339 $FORTH_END_WORD +ORIGIN
1341 ;; these ones will be inited by COLD with the predefined values
1342 $FORTH_USER S0 #06
1343 $FORTH_USER R0 #08
1344 $FORTH_USER TIB #0A
1345 $FORTH_USER WIDTH #0C
1346 $FORTH_USER WARNING #0E
1347 $FORTH_USER FENCE #10
1348 $FORTH_USER DP #12
1349 $FORTH_USER VOC-LINK #14
1350 ;; these ones will not be inited by COLD
1351 $FORTH_USER BLK #16
1352 $FORTH_USER IN #18
1353 $FORTH_USER READ-ONLY #1A
1354 $FORTH_USER SCR #1C
1355 ;; OFFSET is the offset for BLOCK operation
1356 ;; i.e. actual block number will be n+OFFSET
1357 $FORTH_USER OFFSET #1E
1358 $FORTH_USER CONTEXT #20
1359 $FORTH_USER CURRENT #22
1360 $FORTH_USER STATE #24
1361 $FORTH_USER BASE #26
1362 $FORTH_USER DPL #28
1363 $FORTH_USER FLD #2A
1364 $FORTH_USER CSP #2C
1365 $FORTH_USER R# #2E
1366 $FORTH_USER HLD #30
1367 ;; new var for TLOAD
1368 $FORTH_USER TLOAD-Y #32
1369 $FORTH_USER SHOW-HIDDEN #34
1372 $FORTH_WORD HERE
1373 ;; AberSoft
1374 DP @ ;S
1375 $FORTH_END_WORD HERE
1377 $FORTH_WORD ALLOT
1378 ;; AberSoft,k8
1379 ;; k8 checks on
1380 SP@ LIT 32 - DP @ U< 0BRANCH allot0 (.") ~ALLOT: out of memory!~ CR ABORT ;; "
1381 allot0:
1382 ;; k8 checks off
1383 DP +! ;S
1384 $FORTH_END_WORD ALLOT
1386 $FORTH_WORD ,
1387 ;; AberSoft
1388 HERE ! 2 ALLOT ;S
1389 $FORTH_END_WORD ,
1391 $FORTH_WORD c,
1392 ;; AberSoft
1393 HERE c! 1 ALLOT ;S
1394 $FORTH_END_WORD c,
1397 $FORTH_WORD TRAVERSE
1398 ;; AberSoft
1399 SWAP
1400 traverse0:
1401 OVER + LIT 127 OVER C@ <
1402 0BRANCH traverse0
1403 SWAP DROP ;S
1404 $FORTH_END_WORD TRAVERSE
1407 $FORTH_WORD LATEST
1408 ;; AberSoft
1409 CURRENT @ @ ;S
1410 $FORTH_END_WORD LATEST
1412 $FORTH_WORD LFA
1413 ;; AberSoft
1414 4 - ;S
1415 $FORTH_END_WORD LFA
1417 $FORTH_WORD CFA
1418 ;; AberSoft
1419 2- ;S
1420 $FORTH_END_WORD CFA
1422 $FORTH_WORD NFA
1423 ;; AberSoft
1424 LIT 5 - LIT -1 TRAVERSE ;S
1425 $FORTH_END_WORD NFA
1427 $FORTH_WORD PFA
1428 ;; AberSoft
1429 1 TRAVERSE LIT 5 + ;S
1430 $FORTH_END_WORD PFA
1433 $FORTH_WORD !CSP
1434 ;; AberSoft
1435 SP@ CSP ! ;S
1436 $FORTH_END_WORD !CSP
1438 $FORTH_WORD ?ERROR
1439 ;; AberSoft
1440 ;; ( flag code -- )
1441 SWAP 0BRANCH qerror0
1442 ERROR BRANCH qerror1
1443 qerror0:
1444 DROP
1445 qerror1:
1446 ;S
1447 $FORTH_END_WORD ?ERROR
1449 $FORTH_WORD ?COMP
1450 ;; AberSoft
1451 STATE @ 0= LIT 17 ?ERROR ;S
1452 $FORTH_END_WORD ?COMP
1454 $FORTH_WORD ?EXEC
1455 ;; AberSoft
1456 STATE @ LIT 18 ?ERROR ;S
1457 $FORTH_END_WORD ?EXEC
1459 $FORTH_WORD ?PAIRS
1460 ;; AberSoft
1461 - LIT 19 ?ERROR ;S
1462 $FORTH_END_WORD ?PAIRS
1464 $FORTH_WORD ?CSP
1465 ;; AberSoft
1466 SP@ CSP @ - LIT 20 ?ERROR ;S
1467 $FORTH_END_WORD ?CSP
1469 $FORTH_WORD ?LOADING
1470 ;; AberSoft
1471 BLK @ 0= LIT 22 ?ERROR ;S
1472 $FORTH_END_WORD ?LOADING
1474 $FORTH_WORD COMPILE
1475 ;; AberSoft
1476 ?COMP R> dup 2+ >R @ , ;S
1477 $FORTH_END_WORD COMPILE
1479 $FORTH_WORD [ IMM
1480 ;; AberSoft
1481 STATE 0! ;S
1482 $FORTH_END_WORD [
1484 $FORTH_WORD ]
1485 ;; AberSoft
1486 LIT #C0 STATE ! ;S
1487 $FORTH_END_WORD ]
1489 $FORTH_WORD SMUDGE
1490 ;; AberSoft
1491 LATEST LIT #20 TOGGLE ;S
1492 $FORTH_END_WORD SMUDGE
1494 $FORTH_WORD HEX
1495 ;; AberSoft
1496 LIT 16 BASE ! ;S
1497 $FORTH_END_WORD HEX
1499 $FORTH_WORD DECIMAL
1500 ;; AberSoft
1501 LIT 10 BASE ! ;S
1502 $FORTH_END_WORD DECIMAL
1504 $FORTH_WORD (;CODE)
1505 ;; AberSoft
1506 R> LATEST PFA CFA ! ;S
1507 $FORTH_END_WORD (;CODE)
1509 $FORTH_WORD ;CODE IMM
1510 ;; AberSoft
1511 ?CSP COMPILE (;CODE)
1512 [ SMUDGE ;S
1513 $FORTH_END_WORD ;CODE
1515 $FORTH_WORD <BUILDS
1516 ;; AberSoft
1517 0 CONSTANT ;S
1518 $FORTH_END_WORD <BUILDS
1520 $FORTH_WORD DOES>
1521 ;; AberSoft
1522 R> LATEST PFA !
1523 (;CODE)
1524 $FORTH_END_WORD DOES>
1525 _dodoes:
1526 ld hl,(f_curRP)
1527 dec hl
1528 ld (hl),b
1529 dec hl
1530 ld (hl),c
1531 ld (f_curRP),hl
1532 inc de
1533 ex de,hl
1534 ld c,(hl)
1535 inc hl
1536 ld b,(hl)
1537 inc hl
1538 jp i_pushhl
1540 $FORTH_WORD COUNT
1541 ;; AberSoft
1542 ;; ( a -- a+1 (a) )
1543 dup 1+ SWAP C@ ;S
1544 $FORTH_END_WORD COUNT
1546 $FORTH_WORD -TRAILING
1547 ;; AberSoft
1548 dup 0 (DO)
1549 ntrailing0:
1550 OVER OVER + 1- C@ BL - 0BRANCH ntrailing1
1551 LEAVE BRANCH ntrailing2
1552 ntrailing1:
1553 1-
1554 ntrailing2:
1555 (LOOP) ntrailing0
1556 ;S
1557 $FORTH_END_WORD -TRAILING
1560 $FORTH_WORD ." IMM ;;"
1561 ;; AberSoft, k8
1562 LIT 34 STATE @ 0BRANCH dotq0
1563 COMPILE (.") ;;"
1564 WORD C@ 1+ ALLOT BRANCH dotq1
1565 dotq0:
1566 WORD COUNT TYPE
1567 dotq1:
1568 ;S
1569 $FORTH_END_WORD ."
1571 $FORTH_CODE_WORD (")
1572 ld a,(bc)
1573 inc bc
1574 ld l,a
1575 ld h,0
1576 push bc ;; addr
1577 push hl ;; length
1578 add hl,bc
1579 ld b,h
1580 ld c,l
1581 jp i_next
1582 $FORTH_END_CODE_WORD (") ;;"
1584 $FORTH_WORD " IMM ;; "
1585 ;; AberSoft, k8
1586 ;; ( -- c addr )
1587 ;; compile string into the current definition
1588 ;; or place it at PAD (depends of current STATE)
1589 LIT 34 STATE @ 0BRANCH dots0
1590 COMPILE (") ;;"
1591 WORD C@ 1+ ALLOT BRANCH dots1
1592 dots0:
1593 TEXT PAD COUNT
1594 dots1:
1595 ;S
1596 $FORTH_END_WORD " ;;"
1598 include "editstr.zas"
1600 $FORTH_WORD EXPECT
1601 ;; k8
1602 ;; ( addr len -- )
1603 1- (EDITSTR-MAXLEN) ! (EDITSTR-ADDR) !
1604 (EDITSTR-LEN) 0! (EDITSTR-cp) 0!
1605 XEDITSTR ;S
1606 $FORTH_END_WORD EXPECT
1608 $FORTH_WORD QUERY
1609 ;; AberSoft
1610 TIB @ LIT 80 EXPECT in 0! ;S
1611 $FORTH_END_WORD QUERY
1613 ;; ~ will be changed to char with code 0 by ZASM
1614 ;; this word will be called by INTERPRET
1615 ;; when it meets the end of line marker (0x00)
1616 ;; zwb: break INTERPRET
1617 ;; zw2: continue INTERPRETING
1618 $FORTH_WORD ~ IMM ;; #0
1619 ;; AberSoft, k8
1620 TLOAD-Y @ 0BRANCH zwx
1621 FREADLN 0BRANCH zwx1 ;; no more lines
1622 DROP TIB ! in 0! BRANCH zw2
1623 zwx1:
1624 TLOAD-Y 0! LIT f_userDEF 4+ @ dup 0! TIB ! in 0!
1625 ?EXEC RDROP
1626 BRANCH zwb
1627 zwx:
1628 BLK @ 0BRANCH zw1
1629 1 BLK +! in 0! BLK @ b/SCR 1- and 0= 0BRANCH zw0
1630 zwb:
1631 ?EXEC RDROP
1632 zw0:
1633 BRANCH zw2
1634 zw1:
1635 RDROP
1636 zw2:
1637 ;S
1638 $FORTH_END_WORD ~
1640 $FORTH_WORD ERASE
1641 ;; AberSoft
1642 ;; ( addr len -- )
1643 0 FILL ;S
1644 $FORTH_END_WORD ERASE
1646 $FORTH_WORD BLANKS
1647 ;; AberSoft
1648 ;; ( addr len -- )
1649 BL FILL ;S
1650 $FORTH_END_WORD BLANKS
1653 $FORTH_WORD HOLD
1654 ;; AberSoft
1655 ;; ( -- )
1656 LIT -1 HLD +! HLD @ c! ;S
1657 $FORTH_END_WORD HOLD
1659 $FORTH_WORD PAD
1660 ;; AberSoft
1661 ;; ( -- pad )
1662 HERE LIT 68 + ;S
1663 $FORTH_END_WORD PAD
1666 ;; read next word from the input stream
1667 ;; place it at HERE as the counted string
1668 $FORTH_WORD WORD
1669 ;; AberSoft, k8
1670 ;; ( delimeter -- here )
1671 BLK @ 0BRANCH word0 ;; not LOADing?
1672 BLK @ BLOCK BRANCH word1 ;; else -- load block & get it's address
1673 word0:
1674 TIB @
1675 word1:
1676 in @ + SWAP ENCLOSE
1677 ;; ENCLOSE: ( addr delimeter -- addr w_start_ofs w_end_ofs next_scan_ofs )
1679 HERE LIT 34 BLANKS
1680 in +! ;; ( addr w_start_ofs w_end_ofs )
1681 OVER - ;; ( addr w_start_ofs w_len )
1682 dup >R HERE c! ;; length stored; ( addr w_start_ofs | w_len )
1683 + HERE 1+ R> CMOVE
1684 HERE ;S
1685 $FORTH_END_WORD WORD
1687 $FORTH_WORD (NUMBER)
1688 ;; AberSoft
1689 xnumber0:
1690 1+ dup >R C@ BASE @ DIGIT 0BRANCH xnumber2
1691 SWAP BASE @ U* DROP ROT BASE @ U* d+ DPL @ 1+ 0BRANCH xnumber1
1692 1 DPL +!
1693 xnumber1:
1694 R> BRANCH xnumber0
1695 xnumber2:
1696 R> ;S
1697 $FORTH_END_WORD (NUMBER)
1699 $FORTH_WORD NUMBER
1700 ;; AberSoft
1701 0 0 ROT dup 1+ C@ LIT 45 = dup >R + LIT -1
1702 number0:
1703 DPL ! (NUMBER) dup C@ BL - 0BRANCH number1
1704 dup C@ LIT 46 - 0 ?ERROR 0
1705 BRANCH number0
1706 number1:
1707 DROP R> 0BRANCH number2
1708 DNEGATE
1709 number2:
1710 ;S
1711 $FORTH_END_WORD NUMBER
1713 ;; read next word from the input stream
1714 ;; search it in the dictionary
1715 $FORTH_WORD -FIND
1716 ;; AberSoft, k8
1717 ;; ( -- pfa b tf ok)
1718 ;; ( -- ff bad)
1719 BL WORD CONTEXT @ @ (FIND)
1720 dup 0= 0BRANCH nfind0
1721 DROP HERE LATEST (FIND)
1722 nfind0:
1723 ;S
1724 $FORTH_END_WORD -FIND
1726 $FORTH_WORD (ABORT)
1727 ;; AberSoft
1728 ;; ( )
1729 ABORT
1730 $FORTH_END_WORD (ABORT)
1732 $FORTH_WORD ERROR
1733 ;; AberSoft
1734 ;; ( n )
1735 TLOAD-Y 0!
1736 WARNING @ 0< 0BRANCH error0
1737 (ABORT)
1738 error0:
1739 HERE COUNT TYPE (.") ~? ~ MESSAGE ;; "
1740 sp! BLK @ -dup 0BRANCH error1
1741 in @ SWAP
1742 error1:
1743 LIT f_userDEF 4+ @ TIB !
1744 QUIT
1745 $FORTH_END_WORD ERROR
1747 $FORTH_WORD ID.
1748 ;; AberSoft
1749 ;; ( a -- )
1750 PAD LIT 32 LIT 95 FILL
1751 dup PFA LFA OVER - PAD SWAP CMOVE
1752 PAD COUNT LIT 31 and 2DUP + 1- dup @ LIT #FF7F and SWAP !
1753 TYPE SPACE ;S
1754 $FORTH_END_WORD ID.
1756 $FORTH_WORD CREATE
1757 ;; AberSoft
1758 -FIND 0BRANCH create0
1759 DROP NFA ID. 4 MESSAGE SPACE
1760 create0:
1761 HERE dup C@ WIDTH @ MIN 1+ ALLOT dup
1762 LIT #A0 TOGGLE HERE 1- LIT #80 TOGGLE
1763 LATEST , CURRENT @ ! HERE 2+ , ;S
1764 $FORTH_END_WORD CREATE
1766 $FORTH_WORD [COMPILE] IMM
1767 ;; AberSoft
1768 -FIND 0= 0 ?ERROR DROP CFA , ;S
1769 $FORTH_END_WORD [COMPILE]
1771 $FORTH_WORD LITERAL IMM
1772 ;; AberSoft
1773 STATE @ 0BRANCH literal0
1774 COMPILE LIT ,
1775 literal0:
1776 ;S
1777 $FORTH_END_WORD LITERAL
1779 $FORTH_WORD DLITERAL IMM
1780 ;; AberSoft
1781 STATE @ 0BRANCH dliteral0
1782 SWAP LITERAL LITERAL
1783 dliteral0:
1784 ;S
1785 $FORTH_END_WORD DLITERAL
1787 $FORTH_WORD ?STACK
1788 ;; AberSoft
1789 SP@ S0 @ SWAP U< 1 ?ERROR SP@ HERE LIT 128 + U< LIT 7 ?ERROR ;S
1790 $FORTH_END_WORD ?STACK
1792 $FORTH_WORD INTERPRET
1793 ;; AberSoft
1794 interpret0:
1795 -FIND 0BRANCH interpret3
1796 STATE @ < 0BRANCH interpret1
1797 CFA , BRANCH interpret2
1798 interpret1:
1799 CFA EXECUTE
1800 interpret2:
1801 ?STACK BRANCH interpret6
1802 interpret3:
1803 HERE NUMBER DPL @ 1+ 0BRANCH interpret4
1804 DLITERAL BRANCH interpret5
1805 interpret4:
1806 DROP LITERAL
1807 interpret5:
1808 ?STACK
1809 interpret6:
1810 BRANCH interpret0
1811 $FORTH_END_WORD INTERPRET
1813 $FORTH_WORD IMMEDIATE
1814 ;; AberSoft
1815 LATEST LIT #40 TOGGLE ;S
1816 $FORTH_END_WORD IMMEDIATE
1818 $FORTH_WORD DEFINITIONS
1819 ;; AberSoft
1820 CONTEXT @ CURRENT ! ;S
1821 $FORTH_END_WORD DEFINITIONS
1823 $FORTH_WORD ( IMM
1824 ;; AberSoft, k8
1825 LIT 41 WORD DROP ;S
1826 $FORTH_END_WORD (
1828 $FORTH_WORD QUIT
1829 ;; AberSoft
1830 BLK 0! TLOAD-Y 0! [
1831 quit0:
1832 RP! CR QUERY INTERPRET STATE @ 0= 0BRANCH quit1
1833 (.") ~ok~ ;; "
1834 quit1:
1835 BRANCH quit0
1836 $FORTH_END_WORD QUIT
1839 $FORTH_WORD ABORT
1840 ;; AberSoft, k8
1841 sp! DECIMAL ?STACK .CREDITZ
1842 TLOAD-Y 0!
1843 FORTH DEFINITIONS QUIT
1844 $FORTH_END_WORD ABORT
1846 $FORTH_WORD WARM
1847 ;; AberSoft, k8
1848 WARMbody:
1849 ;; 8 1 16384 TR-SREAD
1850 RP! EMPTY-BUFFERS
1851 CLS ABORT
1852 $FORTH_END_WORD WARM
1854 $FORTH_WORD COLD
1855 ;; AberSoft, k8
1856 COLDbody:
1857 FIRST BUF-USE ! FIRST BUF-PREV ! DR0
1858 ;; the first USER is at f_userBASE+6
1859 LIT f_userDEF LIT f_userBASE @ LIT 6 + LIT 16 CMOVE
1860 RP!
1861 LIT f_userBASE @ LIT #1A + 0! ;; READ-ONLY
1862 LIT f_userBASE @ LIT #34 + 0! ;; SHOW-HIDDEN
1863 LIT latest_word LIT forth_voc_latest !
1864 LIT f_cur7FFD C@ LIT #7FFD OUTP
1865 WARM
1866 $FORTH_END_WORD COLD
1869 ;; convert normal singed number to double
1870 $FORTH_CODE_WORD S->d
1871 ;; AberSoft
1872 ;; ( n -- d )
1873 pop de
1874 ld hl,0
1875 ld a,d
1876 and #80
1877 jr z,s2d0
1878 dec hl
1879 s2d0:
1880 jp i_pushde
1881 $FORTH_END_CODE_WORD S->d
1883 $FORTH_WORD +-
1884 ;; AberSoft
1885 0< 0BRANCH pm0
1886 NEGATE
1887 pm0:
1888 ;S
1889 $FORTH_END_WORD +-
1891 $FORTH_WORD d+-
1892 ;; AberSoft
1893 0< 0BRANCH dpm0
1894 DNEGATE
1895 dpm0:
1896 ;S
1897 $FORTH_END_WORD d+-
1899 $FORTH_WORD ABS
1900 ;; AberSoft
1901 dup +- ;S
1902 $FORTH_END_WORD ABS
1904 $FORTH_WORD DABS
1905 ;; AberSoft
1906 dup d+- ;S
1907 $FORTH_END_WORD DABS
1909 $FORTH_WORD MIN
1910 ;; AberSoft
1911 2DUP > 0BRANCH min0
1912 SWAP
1913 min0:
1914 DROP
1915 ;S
1916 $FORTH_END_WORD MIN
1918 $FORTH_WORD MAX
1919 ;; AberSoft
1920 2DUP < 0BRANCH max0
1921 SWAP
1922 max0:
1923 DROP
1924 ;S
1925 $FORTH_END_WORD MAX
1928 $FORTH_WORD m*
1929 ;; AberSoft
1930 2DUP xor >R ABS SWAP ABS U* R> d+- ;S
1931 $FORTH_END_WORD m*
1933 $FORTH_WORD m/
1934 ;; AberSoft
1935 OVER >R >R DABS R@ ABS U/MOD R> R@ xor +- SWAP R> +- SWAP ;S
1936 $FORTH_END_WORD m/
1938 $FORTH_WORD *
1939 ;; AberSoft
1940 m* DROP ;S
1941 $FORTH_END_WORD *
1943 $FORTH_WORD /MOD
1944 ;; AberSoft
1945 >R S->d R> m/ ;S
1946 $FORTH_END_WORD /MOD
1948 $FORTH_WORD /
1949 ;; AberSoft
1950 /MOD SWAP DROP ;S
1951 $FORTH_END_WORD /
1953 $FORTH_WORD MOD
1954 ;; AberSoft
1955 /MOD DROP ;S
1956 $FORTH_END_WORD MOD
1958 $FORTH_WORD */MOD
1959 ;; AberSoft
1960 >R m* R> m/ ;S
1961 $FORTH_END_WORD */MOD
1963 $FORTH_WORD */
1964 ;; AberSoft
1965 */MOD SWAP DROP ;S
1966 $FORTH_END_WORD */
1968 $FORTH_WORD m/MOD
1969 ;; AberSoft
1970 >R 0 R@ U/MOD R> SWAP >R U/MOD R> ;S
1971 $FORTH_END_WORD m/MOD
1974 ;; show warning message
1975 $FORTH_WORD MESSAGE
1976 ;; AberSoft
1977 ;; ( num -- )
1978 ;; show warning text?
1979 WARNING @ 0BRANCH message1
1980 ;; message #0 is "word?" show no warning text
1981 -dup 0BRANCH message0
1982 ;; show message line
1983 4 OFFSET @ b/SCR / - .LINE SPACE
1984 message0:
1985 BRANCH message2
1986 message1:
1987 (.") ~MSG #~ . ;; "
1988 message2:
1989 ;S
1990 $FORTH_END_WORD MESSAGE
1993 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1994 ;; buffers, blocks, etc...
1995 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1996 include "trdos.zas"
1997 include "blocks.zas"
1998 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1999 ;; end of buffers, blocks, etc...
2000 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2003 $FORTH_WORD ' IMM
2004 ;; AberSoft
2005 -FIND 0= 0 ?ERROR DROP LITERAL ;S
2006 $FORTH_END_WORD '
2008 $FORTH_WORD BACK
2009 ;; AberSoft
2010 HERE - , ;S
2011 $FORTH_END_WORD BACK
2013 $FORTH_WORD BEGIN IMM
2014 ;; AberSoft
2015 ?COMP HERE 1 ;S
2016 $FORTH_END_WORD BEGIN
2018 $FORTH_WORD ENDIF IMM
2019 ;; AberSoft
2020 ?COMP 2 ?PAIRS HERE OVER - SWAP ! ;S
2021 $FORTH_END_WORD ENDIF
2023 $FORTH_WORD THEN IMM
2024 ;; AberSoft
2025 ENDIF ;S
2026 $FORTH_END_WORD THEN
2028 $FORTH_WORD DO IMM
2029 ;; AberSoft
2030 COMPILE (DO)
2031 HERE 3 ;S
2032 $FORTH_END_WORD DO
2034 $FORTH_WORD LOOP IMM
2035 ;; AberSoft
2036 3 ?PAIRS COMPILE (LOOP)
2037 BACK ;S
2038 $FORTH_END_WORD LOOP
2040 $FORTH_WORD +LOOP IMM
2041 ;; AberSoft
2042 3 ?PAIRS COMPILE (+LOOP)
2043 BACK ;S
2044 $FORTH_END_WORD +LOOP
2046 $FORTH_WORD UNTIL IMM
2047 ;; AberSoft
2048 1 ?PAIRS COMPILE 0BRANCH
2049 BACK ;S
2050 $FORTH_END_WORD UNTIL
2052 $FORTH_WORD END IMM
2053 ;; AberSoft
2054 UNTIL ;S
2055 $FORTH_END_WORD END
2057 $FORTH_WORD AGAIN IMM
2058 ;; AberSoft
2059 1 ?PAIRS COMPILE BRANCH
2060 BACK ;S
2061 $FORTH_END_WORD AGAIN
2063 $FORTH_WORD REPEAT IMM
2064 ;; AberSoft
2065 >R >R AGAIN R> R> 2- ENDIF ;S
2066 $FORTH_END_WORD REPEAT
2068 $FORTH_WORD IF IMM
2069 ;; AberSoft
2070 COMPILE 0BRANCH
2071 HERE 0 , 2 ;S
2072 $FORTH_END_WORD IF
2074 $FORTH_WORD IFNOT IMM
2075 ;; k8
2076 COMPILE TBRANCH
2077 HERE 0 , 2 ;S
2078 $FORTH_END_WORD IFNOT
2080 $FORTH_WORD ELSE IMM
2081 ;; AberSoft
2082 2 ?PAIRS COMPILE BRANCH
2083 HERE 0 , SWAP 2 ENDIF 2 ;S
2084 $FORTH_END_WORD ELSE
2086 $FORTH_WORD WHILE IMM
2087 ;; AberSoft
2088 IF 2+ ;S
2089 $FORTH_END_WORD WHILE
2091 $FORTH_WORD <#
2092 ;; AberSoft
2093 PAD HLD ! ;S
2094 $FORTH_END_WORD <#
2096 $FORTH_WORD #>
2097 ;; AberSoft
2098 DROP DROP HLD @ PAD OVER - ;S
2099 $FORTH_END_WORD #>
2101 $FORTH_WORD SIGN
2102 ;; AberSoft
2103 ROT 0< 0BRANCH sign0
2104 LIT 45 HOLD
2105 sign0:
2106 ;S
2107 $FORTH_END_WORD SIGN
2109 $FORTH_WORD #
2110 ;; AberSoft
2111 BASE @ m/MOD ROT LIT 9 OVER < 0BRANCH sharp0
2112 LIT 7 +
2113 sharp0:
2114 LIT 48 + HOLD ;S
2115 $FORTH_END_WORD #
2117 $FORTH_WORD #S
2118 ;; AberSoft
2119 ns0:
2120 # OVER OVER or 0= 0BRANCH ns0
2121 ;S
2122 $FORTH_END_WORD #S
2124 $FORTH_WORD D.R
2125 ;; AberSoft
2126 >R SWAP OVER DABS <# #S SIGN #> R> OVER - SPACES TYPE ;S
2127 $FORTH_END_WORD D.R
2129 $FORTH_WORD .R
2130 ;; AberSoft
2131 >R S->d R> D.R ;S
2132 $FORTH_END_WORD .R
2134 $FORTH_WORD D.
2135 ;; AberSoft
2136 0 D.R SPACE ;S
2137 $FORTH_END_WORD D.
2139 $FORTH_WORD .
2140 ;; AberSoft
2141 S->d D. ;S
2142 $FORTH_END_WORD .
2144 $FORTH_WORD ?
2145 ;; AberSoft
2146 @ . ;S
2147 $FORTH_END_WORD ?
2149 $FORTH_WORD U.
2150 ;; AberSoft
2151 0 D. ;S
2152 $FORTH_END_WORD U.
2155 $FORTH_WORD WORDS
2156 ;; AberSoft
2157 ;; ( -- )
2158 0 >R CONTEXT @ @
2160 vlist0:
2161 SHOW-HIDDEN @ 0= 0BRANCH vlist0_1
2162 ;; check if hidden word
2163 dup 1+ C@ LIT 40 - 0BRANCH vlist4
2165 vlist0_1:
2166 dup C@ LIT 31 and R@ SWAP - dup 0< 0BRANCH vlist1
2167 CR DROP dup C@ LIT 31 and CONWIDTH SWAP -
2168 vlist1:
2169 RDROP >R
2171 dup
2172 ;; ID.
2173 COUNT LIT 31 and -dup 0BRANCH vlistT9
2174 0 (DO)
2175 vlistT1:
2176 dup C@ LIT 127 and EMIT 1+
2177 (LOOP) vlistT1
2178 vlistT9:
2179 DROP
2181 R@ 0= 0BRANCH vlist2
2182 CR RDROP CONWIDTH BRANCH vlist3
2183 vlist2:
2184 SPACE R> 1-
2186 vlist3:
2187 >R
2188 vlist4:
2189 PFA LFA @ dup 0= ?BREAK or
2190 0BRANCH vlist0
2191 R> 2DROP ;S
2192 $FORTH_END_WORD WORDS
2195 $FORTH_WORD LIST
2196 ;; AberSoft
2197 DECIMAL CR dup SCR ! (.") ~SCR #~ . ;; "
2198 LIT 16 0 (DO)
2199 list0:
2200 CR I 3 .R SPACE I SCR @ .LINE ?BREAK 0BRANCH list1
2201 LEAVE
2202 list1:
2203 (LOOP) list0
2204 CR ;S
2205 $FORTH_END_WORD LIST
2207 ;; read next word from the input stream
2208 ;; place it at PAD as the counted string
2209 $FORTH_WORD TEXT
2210 ;; AberSoft, k8
2211 ;; ( delimeter -- )
2212 HERE c/l 1+ BLANKS
2213 WORD PAD c/l 1+ CMOVE ;S
2214 $FORTH_END_WORD TEXT
2216 $FORTH_WORD LINE
2217 ;; AberSoft
2218 dup LIT #FFF0 and LIT 23 ?ERROR SCR @ (LINE) DROP ;S
2219 $FORTH_END_WORD LINE
2221 $FORTH_WORD SIZE
2222 ;; AberSoft
2223 HERE 0 +ORIGIN - ;S
2224 $FORTH_END_WORD SIZE
2226 $FORTH_WORD FREE
2227 ;; AberSoft
2228 SP@ HERE - ;S
2229 $FORTH_END_WORD FREE
2231 $FORTH_WORD FORGET
2232 ;; AberSoft
2233 CURRENT @ CONTEXT @ - LIT 24 ?ERROR
2234 ' DUP FENCE @ U< LIT 21 ?ERROR
2235 dup NFA DP ! LFA @ CURRENT @ ! ;S
2236 $FORTH_END_WORD FORGET
2238 $FORTH_WORD U.R
2239 ;; AberSoft
2240 >R 0 R> D.R ;S
2241 $FORTH_END_WORD U.R
2243 $FORTH_WORD EXIT
2244 ;; AberSoft
2245 RDROP ;S
2246 $FORTH_END_WORD EXIT
2248 $FORTH_WORD CASE IMM
2249 ;; AberSoft
2250 ?COMP CSP @ !CSP 4 ;S
2251 $FORTH_END_WORD CASE
2253 $FORTH_WORD OF IMM
2254 ;; AberSoft
2255 4 ?PAIRS COMPILE OVER
2256 COMPILE =
2257 COMPILE 0BRANCH
2258 HERE 0 , COMPILE DROP
2259 LIT 5 ;S
2260 $FORTH_END_WORD OF
2262 $FORTH_WORD ENDOF IMM
2263 ;; AberSoft
2264 LIT 5 ?PAIRS COMPILE BRANCH
2265 HERE 0 , SWAP 2 ENDIF 4 ;S
2266 $FORTH_END_WORD ENDOF
2268 $FORTH_WORD OTHERWISE IMM
2269 ;; k8
2270 ;; part of CASE: OTHERWISE ( val ) ... ENDOF
2271 4 ?PAIRS
2272 COMPILE 0BRANCH
2273 HERE 0 ,
2274 LIT 5 ;S
2275 $FORTH_END_WORD OTHERWISE
2277 $FORTH_WORD ENDCASE IMM
2278 ;; AberSoft
2279 4 ?PAIRS
2280 COMPILE DROP
2281 endcase0:
2282 SP@ CSP @ = 0=
2283 0BRANCH endcase1
2284 2 ENDIF
2285 BRANCH endcase0
2286 endcase1:
2287 CSP !
2288 ;S
2289 $FORTH_END_WORD ENDCASE
2292 ;; FORTH vocabulary
2293 $FORTH_DOES FORTH voc_does IMM
2294 ;; k8, AberSoft
2295 defw #A081 ;; name
2296 forth_voc_latest:
2297 defw latest_word ;; prev voc latest
2298 forth_voc_link:
2299 defw 0 ;; prev voc-link
2301 $FORTH_WORD VOCABULARY
2302 ;; AberSoft
2303 <BUILDS LIT #A081 , CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES>
2304 voc_does:
2305 2+ CONTEXT ! ;S
2306 $FORTH_END_WORD VOCABULARY
2308 ;; VOCABULARY BODY:
2309 ;; "DOES>" ptr
2310 ;; name: " "
2311 ;; lfa
2312 ;; old voc-link
2315 include "textfile.zas"
2316 include "ext0.zas"
2317 include "dump.zas"
2319 ;;;;;;;;;;;;;;;;;;;; INSERT YOUR WORDS BELOW ;;;;;;;;;;;;;;;;;;;;
2320 ;;
2321 ;;
2322 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2324 ;;!!!!!! THIS LABEL SHOULD BE JUST BEFORE THE LAST DEFINED WORD
2325 latest_word:
2326 ;;!!!!!! DO NOT REMOVE THIS WORD! THE SYSTEM USES IT
2327 $FORTH_WORD NOOP
2328 ;S
2329 $FORTH_END_WORD NOOP
2331 latest_byte: defw 666