dsforth: added `[CHAR]`
[urasm.git] / dsforth / main.zas
blob9ee14e2dbf5d75e3d1d2fd96079e33f32725ba68
1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2 ;; dsFORTH v0.0.2
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 ;; set this to 0 to save ~700 bytes
16 USE_FAST_MULDIV EQU 1
17 USE_REL_BRANCH EQU 0
19 ;; those words are of little use
20 USE_EXT_BLOCK_WORDS EQU 0
22 ;; waste ~350 bytes for textual error messages?
23 USE_TEXT_ERROR_MESSAGES EQU 1
25 ;; "LAST-KEY*"
26 USE_EXT_LAST_KEY EQU 0
28 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
29 ;; word format:
30 ;; db  len_flags
31 ;;   name
32 ;; dw  lfa
33 ;; dw  cfa
34 ;; ....
35 ;; len_flags:
36 ;;   bits 0-4: length
37 ;;   bit 5: SMUDGE flag (=1: word definition isn't finished)
38 ;;   bit 6: IMMEDIATE flag (=1: true)
39 ;;   bit 7: always 1
40 ;; the last byte of the name always has bit 7 set
42 ;; for CODE words: cfa points to the body
43 ;; for FORTH words: cfa points to "_doforth"
44 ;; for CONST words: cfa points to "_doconst"
45 ;; for VAR words: cfa points to "_dovar"
46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
48 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
49 ;; tech info
50 ;; registers:
51 ;;   BC: address interpreter insrtuction pointer
52 ;;   IX: USER-var base
53 ;;   IY: used by ROM, do not change
54 ;;   all other regs are free
56 ;; stacks:
57 ;;   data stack: machine stask (PUSH/POP)
58 ;;   exec stack: address with f_curRP (last item)
59 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
62   org  #6000
63 ;; start address: #6000
64 run_cold:
65   di
66   jp    run_0        ;; DO NOT CHANGE THIS TO JR!
67 run_warm:
68   di
69   ld    bc,WARMbody
70   jr    run_1
71 run_0:
72 ;; k8: test for 128k
73   push  bc
74   ; save byte at #C000 for 48K
75   ld    a,(#C000)
76   ex    af,af'
77   ; check for 128K
78   ld    hl,#4000
79   xor   a
80   ; reset #C000
81   ld    (#C000),a
82   ld    (hl),a
83   ld    bc,#7FFD
84   ld    a,#15
85   out   (c),a        ;; now #C000 should be the screen page #5
86   ld    (#C000),a    ;; trash it
87   ld    a,#10
88   out   (c),a        ;; and go back (just in case) %-)
89   ld    a,(hl)
90   ld    (hl),0       ;; so it won't be visible
91   or    a            ;; now check if we really trashed the scrren
92   jr    z,run_ok48
93   ld    a,1
94 run_ok48:
95   ld    (f_is128K),a
96   ; restore #C000
97   ex    af,af'
98   ld    (#C000),a
99   ld    a,#08
100   ld    (#5C6A),a  ; CAPS
101   ld    a,#3F
102   ld    i,a
103   im    1
104   ld    bc,COLDbody
105 run_1:
106   ld    hl,(f_initRP)
107   ld    (f_curRP),hl
108   ld    ix,(f_userBASE)
109   ld    hl,(f_initSP)
110   ld    sp,hl
111   ei
112   jr    i_next
114 ;;;;;;;;;;;;;;; VARIABLES
116 f_is128K:   defb 0
117 f_cur7FFD:  defb #10
119 ;; current RP
120 ;; it grows to to lower addresses (to 0), just as the data stack
121 ;; currently it's address is hardcoded
122 f_curRP:    defw #D7AE  ;; ???
124 ;; address of the first "user" variable (def: run_cold-64)
125 f_userBASE: defw forth_default_user_area  ;; was:#D7B0
127 f_tib:      defs 50,0
129 f_userDEF:
130 f_initSP:
131   defw #FFE0           ;; S0: starting SP. SP grows to addr #0000; was #D600
132 f_initRP:
133   defw #F800           ;; R0: starting RP. RP grows to addr #0000; was #D7AE
134 f_tibptr:
135   defw f_tib           ;; TIB
136 ;; WARNING! keep in sync with `FORTH_USER` and `COLD`!
137   defw 31              ;; WIDTH
138   defw 1               ;; WARNING -- if we have no messages text, 1 is the same as 0
139   defw latest_byte     ;; FENCE
140   defw latest_byte     ;; DP
141   defw forth_voc_link  ;; VOC-LINK
142 f_userDEF_size equ $-f_userDEF
143 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
145 ;;; address interpreter
146 ;; AberSoft
147 i_pushde:
148   push  de
149 i_pushhl:
150   push  hl
151 i_next:
152   ld    a,(bc)
153   inc   bc
154   ld    l,a
155   ld    a,(bc)
156   inc   bc
157   ld    h,a
158 iexecx:
159   ld    e,(hl)
160   inc   hl
161   ld    d,(hl)
162   ex    de,hl
163 ; debug label
164 i_next_jmp:
165   jp    (hl)
166 ;;; end of address interpreter
169 $FORTH_CONST (.NEXT)     i_next
170 $FORTH_CONST (.PUSHHL)   i_pushhl
171 $FORTH_CONST (.PUSHDEHL) i_pushde
172 $FORTH_CONST (@CUR-RP)   f_curRP
173 $FORTH_CONST (@CUR-BASE) f_userBASE
174 $FORTH_CONST (LAST-7FFD) f_cur7FFD
177 $FORTH_CODE_WORD LIT
178 ;; AberSoft
179   ld    a,(bc)
180   inc   bc
181   ld    l,a
182   ld    a,(bc)
183   inc   bc
184   ld    h,a
185   jp    i_pushhl
186 $FORTH_END_CODE_WORD LIT
188 $FORTH_CODE_WORD EXECUTE
189 ;; AberSoft
190 ;; ( cfa )
191   pop   hl
192   jp    iexecx
193 $FORTH_END_CODE_WORD EXECUTE
195 $FORTH_CODE_WORD BRANCH  XBRANCH
196 ;; AberSoft
197 BRANCHbody:
198   ld    hl,bc
199   IF USE_REL_BRANCH
200   ;; original code for relative RBRANCH
201   ld    e,(hl)
202   inc   hl
203   ld    d,(hl)
204   dec   hl
205   add   hl,de
206   ld    bc,hl
207   ELSE
208   ld    c,(hl)
209   inc   hl
210   ld    b,(hl)
211   ENDIF
212   jp    i_next
213 $FORTH_END_CODE_WORD BRANCH
215 $FORTH_CODE_WORD 0BRANCH  XBRANCH
216 ;; AberSoft
217   pop   hl
218   ld    a,l
219   or    h
220   jr    z,BRANCHbody
221 branchskip:
222   inc   bc
223   inc   bc
224   jp    i_next
225 $FORTH_END_CODE_WORD 0BRANCH
227 $FORTH_CODE_WORD TBRANCH  XBRANCH
228 ;; k8
229   pop   hl
230   ld    a,l
231   or    h
232   jr    nz,BRANCHbody
233   jr    branchskip
234 $FORTH_END_CODE_WORD TBRANCH
236 $FORTH_CODE_WORD (LOOP)  XBRANCH
237 ;; AberSoft
238   ld    de,1
239 xloop:
240   ld    hl,(f_curRP)
241   ld    a,(hl)
242   add   a,e
243   ld    (hl),a
244   ld    e,a
245   inc   hl
246   ld    a,(hl)
247   adc   a,d
248   ld    (hl),a
249   inc   hl
250   inc   d
251   dec   d
252   ld    d,a
253   jp    m,xloop0
254   ld    a,e
255   sub   (hl)
256   ld    a,d
257   inc   hl
258   sbc   a,(hl)
259   jr    xloop1
260 xloop0:
261   ld    a,(hl)
262   sub   e
263   inc   hl
264   ld    a,(hl)
265   sbc   a,d
266 xloop1:
267   jp    m,BRANCHbody
268   inc   hl
269   ld    (f_curRP),hl
270   inc   bc
271   inc   bc
272   jp    i_next
273 $FORTH_END_CODE_WORD (LOOP)
275 $FORTH_CODE_WORD (+LOOP)  XBRANCH
276 ;; AberSoft
277   pop   de
278   jr    xloop
279 $FORTH_END_CODE_WORD (+LOOP)
281 $FORTH_CODE_WORD (DO)
282 ;; AberSoft
283 ;; ( limit start -- )
284 ;; loops from start to limit-1
285   ld    hl,(f_curRP)
286   dec   hl
287   dec   hl
288   dec   hl
289   dec   hl
290   ld    (f_curRP),hl
291   pop   de
292   ld    (hl),e
293   inc   hl
294   ld    (hl),d
295   pop   de
296   inc   hl
297   ld    (hl),e
298   inc   hl
299   ld    (hl),d
300   jp    i_next
301 $FORTH_END_CODE_WORD (DO)
303 $FORTH_CODE_WORD I
304 ;; AberSoft
305 ;; ( -- i )
306   ld    hl,(f_curRP)
307 fword_load_rp_i:
308   ld    e,(hl)
309   inc   hl
310   ld    d,(hl)
311   push  de
312   jp    i_next
313 $FORTH_END_CODE_WORD I
315 $FORTH_CODE_WORD I'
316 ;; AberSoft, k8
317 ;; ( -- i' )
318   ld    hl,(f_curRP)
319 fword_loadrp_itick:
320   inc   hl
321   inc   hl
322   jr    fword_load_rp_i
323 $FORTH_END_CODE_WORD I'
325 $FORTH_CODE_WORD J
326 ;; AberSoft
327 ;; ( -- j )
328   ld    hl,(f_curRP)
329 fword_loadrp_j:
330   inc   hl
331   inc   hl
332   jr    fword_loadrp_itick
333 $FORTH_END_CODE_WORD J
335 $FORTH_CODE_WORD J'
336 ;; k8
337 ;; ( -- j' )
338   ld    hl,(f_curRP)
339   inc   hl
340   inc   hl
341   jr    fword_loadrp_j
342 $FORTH_END_CODE_WORD J'
344 ;; DO/LOOP will stop on the next iteration
345 $FORTH_CODE_WORD LEAVE
346 ;; AberSoft
347 ;; ( -- )
348   ld    hl,(f_curRP)
349   ld    e,(hl)
350   inc   hl
351   ld    d,(hl)
352   inc   hl
353   ld    (hl),e
354   inc   hl
355   ld    (hl),d
356   jp    i_next
357 $FORTH_END_CODE_WORD LEAVE
360 $FORTH_CODE_WORD DIGIT
361 ;; AberSoft, k8
362 ;; ( c base -- n2 true )  ok case
363 ;; ( c base -- false )    error case
364   pop   hl        ;; HL: base
365   pop   de        ;; E: char
366   ld    a,e
367   ;; k8: allow lowercased chars
368   cp    'a'
369   jr    c,digitnoup
370   sub   32
371 digitnoup:
372   sub   #30
373   jp    m,digit1
374   cp    10
375   jp    m,digit0
376   sub   7
377   cp    10
378   jp    m,digit1
379 digit0:
380   cp    l
381   jp    p,digit1
382   ld    e,a
383   ld    hl,1
384   jp    i_pushde
385 digit1:
386   ld    hl,0  ;; k8: just in case of invalid base
387   jp    i_pushhl
388 $FORTH_END_CODE_WORD DIGIT
391 $FORTH_CODE_WORD (FIND)
392 ;; AberSoft
393 ;; ( addr l addr2 -- pfa b tf  ok)
394 ;; ( addr l addr2 -- ff        bad)
395   pop   de
396 xfind0:
397   pop   hl
398   push  hl
399   ld    a,(de)
400   xor   (hl)
401   and   #3F
402   jr    nz,xfind4
403 xfind1:
404   inc   hl
405   inc   de
406   ld    a,(de)
407   xor   (hl)
408   add   a,a
409   jr    nz,xfind3
410   jr    nc,xfind1
411   ld    hl,5
412   add   hl,de
413   ex    (sp),hl
414 xfind2:
415   dec   de
416   ld    a,(de)
417   or    a
418   jp    p,xfind2
419   ld    e,a
420   ld    d,0
421   ld    hl,1
422   jp    i_pushde
423 xfind3:
424   jr    c,xfind5
425 xfind4:
426   inc   de
427   ld    a,(de)
428   or    a
429   jp    p,xfind4
430 xfind5:
431   inc   de
432   ex    de,hl
433   ld    e,(hl)
434   inc   hl
435   ld    d,(hl)
436   ld    a,d
437   or    e
438   jr    nz,xfind0
439   pop   hl
440   ld    hl,0
441   jp    i_pushhl
442 $FORTH_END_CODE_WORD (FIND)
445 $FORTH_CODE_WORD ENCLOSE
446 ;; AberSoft
447 ;; ( addr delimeter -- addr w_start_ofs w_end_ofs next_scan_ofs )
448   pop   de  ;; E=delimeter
449   pop   hl  ;; HL=addr
450   push  hl
452   ld    a,e
453   ld    d,a
454   ld    e,#FF
455   dec   hl
457 ;; here: E=word len; A=delim; HL=addr
458 enclose0:
459 ;; skip delimiters
460   inc   hl
461   inc   e
462   cp    (hl)
463   jr    z,enclose0
465   ld    d,0
466   push  de        ;; store # of delimiters before the word
468   ld    d,a       ;; D=delimiter
469 ;; check for "end of buffer" (#0)
470   ld    a,(hl)
471   and   a
472   jr    nz,enclose1
474 ;; oops... no more blondies on the island
475   ld    d,0
476   inc   e
477   push  de        ;; store full length
479   dec   e
480   push  de        ;; store position of the next char to scan
481   jp    i_next
483 ;; here: E=word len; D=delim; HL=addr
484 enclose1:
485 ;; now collect the word itself
486   ld    a,d
487   inc   hl
488   inc   e
489   cp    (hl)
490   jr    z,enclose2  ;; word ends?
491 ;; no, check "end of buffer"
492   ld    a,(hl)
493   and   a
494   jr    nz,enclose1
496 ;; oops... no more blondies on the island
497   ld    d,0
498   push  de        ;; store full length
499   push  de        ;; store position of the next char to scan (???)
500   jp    i_next
502 enclose2:
503   ld    d,0
504   push  de        ;; store full length
505   inc   e
506   push  de        ;; store position of the next char to scan
507   jp    i_next
508 $FORTH_END_CODE_WORD ENCLOSE
510   include "math_bitop.zas"
511   include "math_compare.zas"
512   include "math_basic.zas"
513   include "math_misc.zas"
514   include "math_hlev.zas"
516   include "main_stackops.zas"
517   include "main_memops.zas"
519 $FORTH_CODE_WORD FORTH-WORD?
520 ;; k8
521 ;; ( pfa -- flag )
522   pop   hl
523   dec   hl
524   ld    d, (hl)
525   dec   hl
526   ld    e, (hl)
527   ld    hl,_doforth
528   sbc   hl,de
529   ld    a,h
530   or    l
531   ld    hl,1
532   jr    z,isfword0
533   dec   l
534 isfword0:
535   jp    i_pushhl
536 $FORTH_END_CODE_WORD FORTH-WORD?
538 ;; check if BREAK is pressed
539 $FORTH_CODE_WORD ?BREAK
540 ;; AberSoft, k8
541 ;; ( -- break_flag)
542   call  #1F54  ;; uses only A
543   ld    hl,0
544   jp    c,i_pushhl
545   inc   l
546   jp    i_pushhl
547 $FORTH_END_CODE_WORD ?BREAK
549   include "main_hldef.zas"
551 ;;;;;;;;;;;;;; some speedup constants
552 $FORTH_CONST 0 0
553 $FORTH_CONST 1 1
554 $FORTH_CONST 2 2
555 $FORTH_CONST 3 3
556 $FORTH_CONST 4 4
557 $FORTH_CONST -1 -1
558 $FORTH_CONST -2 -2
559 $FORTH_CONST -4 -4
560 $FORTH_CONST BL 32
561 $FORTH_CONST CHCR 13
562 $FORTH_CONST CHLF 10
564 $FORTH_CONST C/L 64
566 $FORTH_WORD +ORIGIN
567   LIT run_cold  + ;S
568 $FORTH_END_WORD +ORIGIN
570 ;; offsets to some COLD values
571 $FORTH_CONST (COLD-INIT-SP) f_initSP
572 $FORTH_CONST (COLD-INIT-RP) f_initRP
573 $FORTH_CONST (COLD-TIBPTR)  f_tibptr
575 ;; these ones will be inited by COLD with the predefined values
576 $FORTH_USER S0        #06
577 $FORTH_USER R0        #08
578 $FORTH_USER TIB       #0A
579 $FORTH_USER WIDTH     #0C
580 $FORTH_USER WARNING   #0E
581 $FORTH_USER FENCE     #10
582 $FORTH_USER DP        #12
583 $FORTH_USER VOC-LINK  #14
584 ;; these ones will not be inited by COLD
585 $FORTH_USER BLK       #16
586 $FORTH_USER IN        #18
587 fuserofs_readonly equ #1A
588 $FORTH_USER READ-ONLY #1A
589 $FORTH_USER SCR       #1C
590 ;; OFFSET is the offset for BLOCK operation
591 ;; i.e. actual block number will be n+OFFSET
592 $FORTH_USER OFFSET    #1E
593 $FORTH_USER CONTEXT   #20
594 $FORTH_USER CURRENT   #22
595 $FORTH_USER STATE     #24
596 $FORTH_USER BASE      #26
597 $FORTH_USER DPL       #28
598 $FORTH_USER FLD       #2A
599 $FORTH_USER CSP       #2C
600 $FORTH_USER R#        #2E
601 $FORTH_USER HLD       #30
602 ;; new for WORDS
603 $FORTH_USER SHOW-HIDDEN #32
604 fuserofs_showhidden equ #32
605 ;; new var for TLOAD: if not zero, we're loading from a disk file
606 ;;$FORTH_USER TLOAD-Y   #34
608 forth_default_user_size equ #40
609 forth_default_user_area defs #40,0
612 ;; 6x8 printing driver
613   include "main_emit6.zas"
614   include "main_key6.zas"
616 $FORTH_CODE_WORD (HANG)
617 forth_hang:
618   di
619   jr    $
620 $FORTH_END_CODE_WORD (HANG)
622 $FORTH_CODE_WORD BYE
623 ;; return to TR-DOS
624   jp    #3D00
625 ;;;; return to BASIC?
626 ;;  LD   A,#17
627 ;;  LD   (f_cur7FFD),A
628 ;;  LD   BC,#7FFD
629 ;;  OUT  (C),A
630 ;;  LD   HL,0
631 ;;  PUSH HL
632 ;;  JP   #3D2F
633 $FORTH_END_CODE_WORD BYE
635 $FORTH_CODE_WORD 128K?
636   ld    a,(f_is128K)
637 cw_is_128k_done:
638   ld    l,a
639   ld    h,0
640   jp    i_pushhl
641 $FORTH_END_CODE_WORD 128K?
643 $FORTH_CODE_WORD 48K?
644   ld    a,(f_is128K)
645   or    a
646   ld    a,1
647   jr    z,cw_is_128k_done
648   xor   a
649   jr    cw_is_128k_done
650 $FORTH_END_CODE_WORD 48K?
652 $FORTH_WORD .CREDITZ
653 ;; k8
654   (.") ~\n48K/128K dsFORTH v0.0.2\n~
655   (.") ~original version: \x7F Abersoft, 1983\n~
656   (.") ~modifications by Ketmar//Invisible Vector\n~
657   ;; (.") ~distribution terms: GNU GPL\n~
658   ;S
659 $FORTH_END_WORD .CREDITZ
662 ;; ;eave the address of the next available dictionary location
663 $FORTH_WORD HERE
664 ;; AberSoft
665 ;; ( -- addr )
666   DP @ ;S
667 $FORTH_END_WORD HERE
669 $FORTH_WORD ALLOT
670 ;; AberSoft,k8
671 ;; ( n -- )
672 ;; k8 checks on
673   SP@ RP@ UMIN BL - DP @ U< 0BRANCH allot0
674   (.") ~ALLOT: out of memory!\n~  ;;"
675   ABORT
676 allot0:
677 ;; k8 checks off
678   DP +! ;S
679 $FORTH_END_WORD ALLOT
681 $FORTH_WORD ,
682 ;; AberSoft
683 ;; ( n -- )
684   HERE ! 2 ALLOT ;S
685 $FORTH_END_WORD ,
687 $FORTH_WORD C,
688 ;; AberSoft
689 ;; ( n -- )
690   HERE C! 1 ALLOT ;S
691 $FORTH_END_WORD C,
694 $FORTH_WORD TRAVERSE
695 ;; AberSoft
696 ;; ( addr1 n -- addr2 )
697   SWAP
698 traverse0:
699   OVER + LIT 127 OVER C@ <
700   0BRANCH traverse0
701   SWAP DROP ;S
702 $FORTH_END_WORD TRAVERSE
705 $FORTH_WORD LATEST
706 ;; AberSoft
707 ;; ( -- addr )
708   CURRENT @ @ ;S
709 $FORTH_END_WORD LATEST
711 $FORTH_WORD LFA
712 ;; AberSoft
713 ;; ( pfa -- lfa )
714   4 - ;S
715 $FORTH_END_WORD LFA
717 $FORTH_WORD CFA
718 ;; AberSoft
719 ;; ( pfa -- cfa )
720   2- ;S
721 $FORTH_END_WORD CFA
723 $FORTH_WORD NFA
724 ;; AberSoft
725 ;; ( pfa -- nfa )
726   LIT 5 -  -1  TRAVERSE ;S
727 $FORTH_END_WORD NFA
729 $FORTH_WORD PFA
730 ;; AberSoft
731 ;; ( nfa -- pfa )
732   1 TRAVERSE LIT 5 + ;S
733 $FORTH_END_WORD PFA
736 $FORTH_WORD !CSP
737 ;; AberSoft
738 ;; ( -- )
739   SP@ CSP ! ;S
740 $FORTH_END_WORD !CSP
742 $FORTH_WORD ?ERROR
743 ;; AberSoft
744 ;; ( flag code -- )
745   SWAP 0BRANCH qerror0
746   ERROR BRANCH qerror1
747 qerror0:
748   DROP
749 qerror1:
750   ;S
751 $FORTH_END_WORD ?ERROR
753 $FORTH_WORD ?COMP
754 ;; AberSoft
755 ;; ( -- )
756   STATE @ 0= LIT 17 ?ERROR ;S
757 $FORTH_END_WORD ?COMP
759 $FORTH_WORD ?EXEC
760 ;; AberSoft
761 ;; ( -- )
762   STATE @ LIT 18 ?ERROR ;S
763 $FORTH_END_WORD ?EXEC
765 $FORTH_WORD ?PAIRS
766 ;; AberSoft
767 ;; ( n1 n2 -- )
768   - LIT 19 ?ERROR ;S
769 $FORTH_END_WORD ?PAIRS
771 $FORTH_WORD ?CSP
772 ;; AberSoft
773 ;; ( -- )
774   SP@ CSP @ - LIT 20 ?ERROR ;S
775 $FORTH_END_WORD ?CSP
777 $FORTH_WORD ?LOADING
778 ;; AberSoft
779 ;; ( -- )
780   BLK @ 0= LIT 22 ?ERROR ;S
781 $FORTH_END_WORD ?LOADING
783 $FORTH_WORD COMPILE
784 ;; AberSoft
785 ;; ( -- )
786   ?COMP R> DUP 2+ >R @ , ;S
787 $FORTH_END_WORD COMPILE
789 $FORTH_WORD [ IMM
790 ;; AberSoft
791 ;; ( -- )
792   STATE 0! ;S
793 $FORTH_END_WORD [
795 $FORTH_WORD ]
796 ;; AberSoft
797 ;; ( -- )
798   LIT #C0 STATE ! ;S
799 $FORTH_END_WORD ]
801 $FORTH_WORD SMUDGE
802 ;; AberSoft
803 ;; ( -- )
804   LATEST LIT #20 TOGGLE ;S
805 $FORTH_END_WORD SMUDGE
807 $FORTH_WORD HEX
808 ;; AberSoft
809 ;; ( -- )
810   LIT 16 BASE ! ;S
811 $FORTH_END_WORD HEX
813 $FORTH_WORD BINARY
814 ;; AberSoft
815 ;; ( -- )
816   2 BASE ! ;S
817 $FORTH_END_WORD BINARY
819 $FORTH_WORD DECIMAL
820 ;; AberSoft
821 ;; ( -- )
822   LIT 10 BASE ! ;S
823 $FORTH_END_WORD DECIMAL
825 $FORTH_WORD COUNT
826 ;; AberSoft
827 ;; ( a -- a+1 (a) )
828   DUP 1+ SWAP C@ ;S
829 $FORTH_END_WORD COUNT
831 $FORTH_WORD -TRAILING
832 ;; AberSoft
833 ;; ( addr n1 -- addr n2 )
834   DUP 0 (DO)
835 ntrailing0:
836   OVER OVER + 1- C@ BL - 0BRANCH ntrailing1
837   LEAVE BRANCH ntrailing2
838 ntrailing1:
839   1-
840 ntrailing2:
841   (LOOP)  ntrailing0
842   ;S
843 $FORTH_END_WORD -TRAILING
846 $FORTH_WORD (.")  ;;"
847 ;; AberSoft
848 ;; ( -- )
849   R@ COUNT dup 1+ R> + >R TYPE ;S
850 $FORTH_END_WORD (.")  ;;"
852 $FORTH_WORD ." IMM  ;;"
853 ;; AberSoft, k8
854 ;; ( -- )
855   LIT 34  STATE @ 0BRANCH dotq0
856   COMPILE (.")  ;;"
857   WORD C@ 1+ ALLOT BRANCH dotq1
858 dotq0:
859   WORD COUNT TYPE
860 dotq1:
861   ;S
862 $FORTH_END_WORD ."  ;;"
864 $FORTH_CODE_WORD (")  ;;"
865 ;; ( -- addr count )
866   ld    a,(bc)
867   inc   bc
868   ld    l,a
869   ld    h,0
870   push  bc     ;; addr
871   push  hl     ;; length
872   add   hl,bc
873   ld    b,h
874   ld    c,l
875   jp    i_next
876 $FORTH_END_CODE_WORD (")  ;;"
878 $FORTH_WORD " IMM  ;;"
879 ;; AberSoft, k8
880 ;; ( -- addr count )
881 ;; compile string into the current definition
882 ;; or place it at PAD (depends of current STATE)
883   LIT 34  STATE @ 0BRANCH dots0
884   COMPILE (")  ;;"
885   WORD C@ 1+ ALLOT BRANCH dots1
886 dots0:
887   TEXT PAD COUNT
888 dots1:
889   ;S
890 $FORTH_END_WORD "  ;;"
892   include "main_editstr.zas"
894 $FORTH_WORD EXPECT
895 ;; k8
896 ;; ( addr len -- )
897   1- (EDITSTR-MAXLEN) !  (EDITSTR-ADDR) !
898   (EDITSTR-LEN) 0!  (EDITSTR-cp) 0!
899   XEDITSTR  ;S
900 $FORTH_END_WORD EXPECT
902 $FORTH_WORD QUERY
903 ;; AberSoft
904 ;; ( -- )
905   TIB @  LIT 80 EXPECT  IN 0! ;S
906 $FORTH_END_WORD QUERY
908 ;; ~ will be changed to char with code 0 by ZASM
909 ;; this word will be called by INTERPRET
910 ;; when it meets the end of line marker (0x00)
911 ;; zwb: break INTERPRET
912 ;; zw2: continue INTERPRETING
913 $FORTH_WORD ~ IMM ;; #0
914 ;; AberSoft, k8
915 ;; ( -- )
916   ;;TLOAD-Y @ 0BRANCH zwx
917   FOPENED? 0BRANCH zwx
918   FREADLN 0BRANCH zwx1  ;; no more lines
919   DROP TIB ! IN 0! BRANCH zw2
920 zwx1:
921   ;;TLOAD-Y 0!
922   FCLOSE
923   LIT f_tibptr @  DUP 0! TIB !  IN 0!
924   ?EXEC RDROP
925   BRANCH zwb
926 zwx:
927   BLK @ 0BRANCH zw1
928   1 BLK +!  IN 0!  BLK @ b/SCR 1- AND 0= 0BRANCH zw0
929 zwb:
930   ?EXEC RDROP
931 zw0:
932   BRANCH zw2
933 zw1:
934   RDROP
935 zw2:
936   ;S
937 $FORTH_END_WORD ~
940 $FORTH_WORD PAD
941 ;; AberSoft
942 ;; ( -- pad )
943   HERE LIT 68 + ;S
944 $FORTH_END_WORD PAD
947 ;; read next word from the input stream
948 ;; place it at HERE as the counted string
949 $FORTH_WORD WORD
950 ;; AberSoft, k8
951 ;; ( delimeter -- here )
952   BLK @ 0BRANCH word0        ;; not LOADing?
953   BLK @ BLOCK BRANCH word1   ;; else -- load block and get its address
954 word0:
955   TIB @
956 word1:
957   IN @ + SWAP ENCLOSE
958 ;; ENCLOSE: ( addr delimeter -- addr w_start_ofs w_end_ofs next_scan_ofs )
960   HERE LIT 34 BLANKS
961   IN +!  ;; ( addr w_start_ofs w_end_ofs )
962   OVER - ;; ( addr w_start_ofs w_len )
963   DUP >R  HERE C!   ;; length stored; ( addr w_start_ofs | w_len )
964   +  HERE 1+  R>  CMOVE
965   HERE ;S
966 $FORTH_END_WORD WORD
968 $FORTH_WORD (NUMBER)
969 ;; AberSoft
970 ;; ( d1 addrl -- d2 addr2 )
971 ;; converts from (addrl+1)
972 xnumber0:
973   1+ DUP >R C@ BASE @ DIGIT 0BRANCH xnumber2
974   SWAP BASE @ U* DROP ROT BASE @ U* D+ DPL @ 1+ 0BRANCH xnumber1
975   1 DPL +!
976 xnumber1:
977   R> BRANCH xnumber0
978 xnumber2:
979   R> ;S
980 $FORTH_END_WORD (NUMBER)
982 $FORTH_WORD NUMBER
983 ;; AberSoft
984 ;; ( addr -- d )
985 ;; sets DPL if decimal point was found
986   0 0 ROT DUP 1+ C@ LIT 45 = DUP >R + -1
987 number0:
988   DPL ! (NUMBER) DUP C@ BL - 0BRANCH number1
989   DUP C@ LIT 46 - 0 ?ERROR 0
990   BRANCH number0
991 number1:
992   DROP R> 0BRANCH number2
993   DNEGATE
994 number2:
995   ;S
996 $FORTH_END_WORD NUMBER
999 ;; read next word from the input stream
1000 ;; search it in the dictionary
1001 $FORTH_WORD -FIND
1002 ;; AberSoft, k8
1003 ;; ( -- pfa b tf  ok)
1004 ;; ( -- ff        bad)
1005   BL WORD  CONTEXT @ @  (FIND)
1006   DUP 0= 0BRANCH nfind0
1007   DROP  HERE LATEST (FIND)
1008 nfind0:
1009   ;S
1010 $FORTH_END_WORD -FIND
1012 $FORTH_WORD (ABORT)
1013 ;; AberSoft
1014 ;; ( -- )
1015   ABORT
1016 $FORTH_END_WORD (ABORT)
1018 $FORTH_WORD (ERROR-STOP)
1019 ;; k8
1020 ;; ( -- )
1021   FCLOSE
1022   SP!
1023   LIT f_tibptr @ TIB !
1024   QUIT
1025 $FORTH_END_WORD (ERROR-STOP)
1027 $FORTH_WORD ERROR
1028 ;; AberSoft
1029 ;; ( n -- )
1030   ;;TLOAD-Y 0!
1031   FCLOSE
1032   WARNING @ 0< 0BRANCH error0
1033   (ABORT)
1034 error0:
1035   HERE COUNT TYPE (.")  ~? ~  ;;"
1036   MESSAGE
1037   SP!  BLK @ -DUP 0BRANCH error1
1038   IN @ SWAP
1039 error1:
1040   LIT f_tibptr @ TIB !
1041   QUIT
1042 $FORTH_END_WORD ERROR
1044 $FORTH_WORD ID.
1045 ;; AberSoft
1046 ;; ( nfa -- )
1047   PAD BL LIT 95 FILL
1048   DUP PFA LFA OVER - PAD SWAP CMOVE
1049   PAD COUNT LIT 31 AND 2DUP + 1- DUP @ LIT #FF7F AND SWAP !
1050   TYPE SPACE ;S
1051 $FORTH_END_WORD ID.
1053 $FORTH_WORD [COMPILE] IMM
1054 ;; AberSoft
1055 ;; ( -- )
1056   -FIND 0= 0 ?ERROR DROP CFA , ;S
1057 $FORTH_END_WORD [COMPILE]
1059 $FORTH_WORD LITERAL IMM
1060 ;; AberSoft
1061 ;; ( n -- )
1062   STATE @ 0BRANCH literal0
1063   COMPILE LIT ,
1064 literal0:
1065   ;S
1066 $FORTH_END_WORD LITERAL
1068 $FORTH_WORD DLITERAL IMM
1069 ;; AberSoft
1070 ;; ( lo hi -- )
1071   STATE @ 0BRANCH dliteral0
1072   SWAP LITERAL LITERAL
1073 dliteral0:
1074   ;S
1075 $FORTH_END_WORD DLITERAL
1077 $FORTH_WORD ?STACK
1078 ;; AberSoft, k8
1079 ;; ( -- )
1080   ;; check for stack underflow
1081   SP@ S0 @ SWAP U< 1 ?ERROR
1082   ;; check for stack overflow
1083   ;; SP@ HERE LIT 128 + U< LIT 7 ?ERROR
1084   SP@
1085     ;; end of words
1086     HERE LIT 128 +
1087     ;; current RP (k8)
1088     RP@ LIT 8 + UMAX
1089     ;; initial RP (k8)
1090     R0 @ LIT 8 + UMAX
1091   U< LIT 7 ?ERROR
1092   ;S
1093 $FORTH_END_WORD ?STACK
1096 $FORTH_WORD ([0pfx])
1097 ;; k8
1098 ;; ( base -- )
1099   BL WORD
1100   BASE @ >R  SWAP BASE !
1101   0 0  ROT (NUMBER)  ;; ( d2 addr2 )
1102   R> BASE !
1103   HERE COUNT  ;; (d2 addr2 here+1 count )
1104   NROT  ;; (d2 count addr2 here+1 )
1105   -  ;; (d2 count diff )
1106   != 0 ?ERROR
1107   ;; (d2)
1108   DROP
1109   LITERAL
1110   ;S
1111 $FORTH_END_WORD ([0pfx])
1113 $FORTH_WORD [0x] IMM
1114 ;; k8
1115 ;; ( -- n )
1116   LIT 16 ([0pfx])
1117   ;S
1118 $FORTH_END_WORD [0x]
1120 $FORTH_WORD [0b] IMM
1121 ;; k8
1122 ;; ( -- n )
1123   2 ([0pfx])
1124   ;S
1125 $FORTH_END_WORD [0b]
1127 $FORTH_WORD [0o] IMM
1128 ;; k8
1129 ;; ( -- n )
1130   LIT 8 ([0pfx])
1131   ;S
1132 $FORTH_END_WORD [0o]
1134 $FORTH_WORD [CHAR] IMM
1135 ;; k8
1136 ;; ( -- c )
1137   BL WORD COUNT 0= LIT 42 ?ERROR
1138   C@ LITERAL
1139   ;S
1140 $FORTH_END_WORD [CHAR]
1143 $FORTH_WORD INTERPRET
1144 ;; AberSoft
1145 interpret0:
1146   -FIND 0BRANCH interpret3
1147   STATE @ < 0BRANCH interpret1
1148   CFA , BRANCH interpret5  ;;OLD: BRANCH interpret2
1149 interpret1:
1150   CFA EXECUTE
1151 interpret2:
1152   ?STACK BRANCH interpret0  ;;OLD: BRANCH interpret6
1153 interpret3:
1154   HERE NUMBER DPL @ 1+ 0BRANCH interpret4
1155   DLITERAL BRANCH interpret5
1156 interpret4:
1157   DROP LITERAL
1158 interpret5:
1159   ?STACK
1160 interpret6:
1161   BRANCH interpret0
1162 $FORTH_END_WORD INTERPRET
1164 $FORTH_WORD IMMEDIATE
1165 ;; AberSoft
1166 ;; ( -- )
1167   LATEST LIT #40 TOGGLE ;S
1168 $FORTH_END_WORD IMMEDIATE
1170 $FORTH_WORD DEFINITIONS
1171 ;; AberSoft
1172 ;; ( -- )
1173   CONTEXT @ CURRENT ! ;S
1174 $FORTH_END_WORD DEFINITIONS
1176 $FORTH_WORD ( IMM
1177 ;; AberSoft, k8
1178 ;; ( -- )
1179   LIT 41 WORD DROP ;S
1180 $FORTH_END_WORD (
1182 ;;FIXME: NOT PROPERLY TESTED!
1183 $FORTH_WORD \ IMM
1184 ;; k8
1185 ;; ( -- )
1186   BLK @ 0BRANCH cmt_eol_tib
1187   BLK @ BLOCK BRANCH cmt_eol_main   ;; else -- load block and get its address
1188 cmt_eol_tib:
1189   TIB @
1190 cmt_eol_main:
1191   DUP
1192   IN @ +  ;; ( staddr curaddr )
1193   ;;DEBUG: CR DUP U.
1194 cmt_eol_loop:
1195   DUP C@
1196   ;;DEBUG: DUP XEMIT
1197   DUP 0BRANCH cmt_eol_done
1198   ;; non-zero
1199   DUP CHCR = TBRANCH cmt_eol_done
1200   DUP CHLF = TBRANCH cmt_eol_done
1201   DROP
1202   1+
1203   BRANCH cmt_eol_loop
1204 cmt_eol_done:
1205   DROP
1206   ;;DEBUG: SPACE DUP U. CR
1207   SWAP - IN !
1208   ;S
1209 $FORTH_END_WORD \
1212 $FORTH_WORD QUIT
1213 ;; AberSoft
1214 ;; ( -- )
1215   BLK 0!
1216   ;;TLOAD-Y 0!
1217   FCLOSE
1218   [
1219 quit0:
1220   RP! CR QUERY INTERPRET STATE @ 0= 0BRANCH quit1
1221   (.")  ~ok~  ;;"
1222 quit1:
1223   BRANCH quit0
1224 $FORTH_END_WORD QUIT
1227 $FORTH_WORD ABORT
1228 ;; AberSoft, k8
1229 ;; ( -- )
1230   SP! DECIMAL ?STACK
1231   ;;TLOAD-Y 0!
1232   FCLOSE
1233   FORTH DEFINITIONS  QUIT
1234 $FORTH_END_WORD ABORT
1236 $FORTH_WORD WARM
1237 ;; AberSoft, k8
1238 ;; ( -- )
1239 WARMbody:
1240 ;;  8 1 16384 TR-SREAD
1241   RP! EMPTY-BUFFERS
1242   CLS .CREDITZ
1243   ABORT
1244 $FORTH_END_WORD WARM
1246 $FORTH_WORD COLD
1247 ;; AberSoft, k8
1248 ;; ( -- )
1249 COLDbody:
1250   FIRST BUF-USE !  FIRST BUF-PREV !  DR0
1251   ;; the first USER is at f_userBASE+6
1252   LIT f_userDEF  LIT f_userBASE @ LIT 6 +  LIT f_userDEF_size CMOVE
1253   RP!
1254   LIT f_userBASE @ LIT fuserofs_readonly + 0!  ;; READ-ONLY
1255   LIT f_userBASE @ LIT fuserofs_showhidden + 0!  ;; SHOW-HIDDEN
1256   LIT latest_word  LIT forth_voc_latest  !
1257   LIT f_cur7FFD C@ LIT #7FFD OUTP
1258   WARM
1259 $FORTH_END_WORD COLD
1262   IF USE_TEXT_ERROR_MESSAGES
1263 forth_error_msg_table:
1264   defb 1
1265     defc "Stack empty"
1266   defb 2
1267     defc "Dictionary full"
1268   defb 3
1269     defc "Incorrect address mode"
1270   defb 4
1271     defc "Is not unique"
1272   defb 6
1273     defc "RAM disc range"
1274   defb 7
1275     defc "Stack full"
1276   defb 9
1277     defc "Load from page 0"
1278   defb 17
1279     defc "Compilation only"
1280   defb 18
1281     defc "Execution only"
1282   defb 19
1283     defc "Conditionals not paired"
1284   defb 20
1285     defc "Definition not finished"
1286   defb 21
1287     defc "In protected dictionary"
1288   defb 22
1289     defc "Use only when loading"
1290   defb 23
1291     defc "Off current editing screen"
1292   defb 24
1293     defc "Declare vocabulary"
1294   defb 42
1295     defc "Word expected"
1296   defb 0
1298 ;; show warning message
1299 $FORTH_WORD MESSAGE
1300 ;; AberSoft
1301 ;; ( num -- )
1302 ;; message #0 is "word?" show no warning text
1303   -DUP 0BRANCH message_done
1304 ;; show warning text?
1305   WARNING @ 0BRANCH message_simple
1306   ;; show message line
1307   ;; k8: nope; use built-in text instead
1308   ;; 4 OFFSET @ b/SCR / - .LINE SPACE
1309   >R
1310   LIT forth_error_msg_table
1311   ;; ( tbl | num )
1312 message_loop:
1313     COUNT -DUP 0BRANCH message_loop_done
1314     ;; ( tbl msgid | num )
1315     R@ = 0BRANCH message_loop_skip
1316     COUNT TYPE RDROP ;S
1317 message_loop_skip:
1318     COUNT +
1319   BRANCH message_loop
1320 message_loop_done:
1321   ;; ( tbl | num )
1322   DROP R>
1323 message_simple:
1324   (.")  ~MSG #~  ;;"
1325   BASE @ DECIMAL SWAP . BASE !
1326 message_done:
1327   ;S
1328 $FORTH_END_WORD MESSAGE
1330   ELSE
1332 ;; show warning message
1333 $FORTH_WORD MESSAGE
1334 ;; AberSoft
1335 ;; ( num -- )
1336 ;; message #0 is "word?" show no warning text
1337   -DUP 0BRANCH message_done
1338   (.")  ~MSG #~  ;;"
1339   BASE @ DECIMAL SWAP . BASE !
1340 message_done:
1341   ;S
1342 $FORTH_END_WORD MESSAGE
1344   ENDIF
1347 $FORTH_WORD ' IMM
1348 ;; AberSoft
1349 ;; ( -- )
1350   -FIND 0= 0 ?ERROR DROP LITERAL ;S
1351 $FORTH_END_WORD '
1353   include "main_ctrl.zas"
1355   include "main_nprint.zas"
1357 ;; $FORTH_WORD ?
1358 ;; ;; AberSoft
1359 ;;   @ . ;S
1360 ;; $FORTH_END_WORD ?
1362   include "main_vlist.zas"
1364 ;; read next word from the input stream
1365 ;; place it at PAD as the counted string
1366 $FORTH_WORD TEXT
1367 ;; AberSoft, k8
1368 ;; ( delimeter -- )
1369   HERE  C/L 1+  BLANKS
1370   WORD  PAD  C/L 1+  CMOVE ;S
1371 $FORTH_END_WORD TEXT
1373 $FORTH_WORD SIZE
1374 ;; AberSoft
1375 ;; ( -- n )
1376   HERE 0 +ORIGIN - ;S
1377 $FORTH_END_WORD SIZE
1379 $FORTH_WORD FREE
1380 ;; AberSoft
1381 ;; ( -- n )
1382   SP@ RP@ UMIN BL - HERE - ;S
1383 $FORTH_END_WORD FREE
1386 $FORTH_WORD FORGET
1387 ;; AberSoft
1388 ;; ( -- )
1389   CURRENT @ CONTEXT @ - LIT 24 ?ERROR
1390   ' DUP FENCE @ U< LIT 21 ?ERROR
1391   DUP NFA DP ! LFA @ CURRENT @ ! ;S
1392 $FORTH_END_WORD FORGET
1395 ;; FORTH vocabulary
1396 $FORTH_DOES FORTH voc_does IMM
1397 ;; k8, AberSoft
1398 ;; ( -- )
1399   defw #A081          ;; name
1400 forth_voc_latest:
1401   defw latest_word    ;; voc latest
1402 forth_voc_link:
1403   defw 0              ;; prev voc-link
1405 $FORTH_WORD VOCABULARY
1406 ;; AberSoft
1407 ;; ( -- )
1408   <BUILDS LIT #A081 , CURRENT @ CFA , HERE VOC-LINK @ , VOC-LINK ! DOES>
1409 voc_does:
1410   2+ CONTEXT ! ;S
1411 $FORTH_END_WORD VOCABULARY
1413 ;; VOCABULARY BODY:
1414 ;; "DOES>" ptr
1415 ;; name: " "
1416 ;; lfa
1417 ;; old voc-link
1420 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1421 ;; buffers, blocks, etc...
1422 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1423   include "main_trdos.zas"
1424   include "main_blocks.zas"
1425   include "ext_textfile.zas"
1426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1427 ;; end of buffers, blocks, etc...
1428 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1430   include "ext_gfxlo.zas"
1431   include "ext_gfxhi.zas"
1432   include "ext_dump.zas"
1434 ;;;;;;;;;;;;;;;;;;;; INSERT YOUR WORDS BELOW ;;;;;;;;;;;;;;;;;;;;
1437 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1439 ;;!!!!!! THIS LABEL SHOULD BE JUST BEFORE THE LAST DEFINED WORD
1440 latest_word:
1441 ;;!!!!!! DO NOT REMOVE THIS WORD! THE SYSTEM USES IT
1442 $FORTH_WORD NOOP
1443 ;; AberSoft
1444 ;; ( -- )
1445   ;S
1446 $FORTH_END_WORD NOOP
1448 latest_byte: defw 666