* implementation for the 6809 -- Color Computer.
*
-*
-MEMT32 EQU $7FFF absolute end of all ram
-MEMT16 EQU $3FFF
-MEMTOP EQU MEMT16 ; tentative guess
-ACIAC EQU $FBCE the ACIA control address and
-ACIAD EQU ACIAC+1 data address for PROTO
- PAGE
* MEMORY MAP for this 16K|32K system:
* ( delineated so that systems with 4k byte write-
* protected segments can write protect FORTH )
*
* addr. contents pointer init by
* **** ******************************* ******* ******
-* 2nd through 4th per-user tables
-* 4000|7D00
-USERSZ EQU 256 ; (Addressable by DP)
+*
+* Coco has no ACIA!
+* ACIAC EQU $FBCE the ACIA control address and
+* ACIAD EQU ACIAC+1 data address for PROTO
+*
+MEMT32 EQU $7FFF ; Theoretical absolute end of all ram
+MEMT16 EQU $3FFF ; 16K is too tight until we no longer need disc emulation.
+MEMTOP EQU MEMT32
+*
+MASSHI EQU MEMTOP
+*
+* 3FFF|7FFF HI
+*
+* substitute for disc mass memory
+RAMSCR EQU 8 ; addresses calculate as 2 (Too much for 16K in RAM only.)
+SCRSZ EQU 1024
+* 3800|7800 LO
+MASSLO EQU MASSHI-RAMSCR*SCRSZ+1
+RAMDSK EQU MASSLO
+MEMEND EQU MASSLO
+*
+* 3800|7800 MEMEND
+* "end" of "usable ram" (If disc mass memory emulation is removed, actual end.)
+*
+* 37FF|77FF
+*
+* per-user tables
+USERSZ EQU 256 ; (Addressable by DP, must be 256 on even boundary)
USER16 EQU 1 ; We can change these for ROMPACK or 64K.
-USER32 EQU 4
-USERCT EQU USER16
-IUP16 EQU MEMT16+1-USER16*USERSZ
-IUP32 EQU MEMT32+1-USER32*USERSZ
-IUP EQU IUP16
+USER32 EQU 2 ; maybe?
+USERCT EQU USER32
+USERLO EQU MEMEND-USERSZ*USERCT
+IUP EQU USERLO
IUPDP EQU IUP/256
* user tables of variables
* registers & pointers for the virtual machine
-* scratch area used by various words
-* 3F00|7C00 <== UP (DICTPT)
-* 3EFF|7BFF HI
-* substitute for disc mass memory
-RAMSCR EQU 3
-SCRSZ EQU 1024
-* 3300|7000 LO,MEMEND
-RAMD16 EQU IUP16-RAMSCR*SCRSZ
-RAMD32 EQU IUP32-RAMSCR*SCRSZ
-RAMDSK EQU RAMD16
-MEME16 EQU RAMD16
-MEME32 EQU RAMD32
-MEMEND EQU MEME16
-* 32FF|6FFF
+* scratch area for potential use in something, maybe?
+*
+* 3700|7600 <== UP
+*
+* This is a really awkward place to define the disk buffer records.
+*
* 4 buffer sectors of VIRTUAL MEMORY
NBLK EQU 4 ; # of disc buffer blocks for virtual memory
* Should NBLK be SCRSZ/SECTSZ?
* each block is SECTSZ+SECTRL bytes in size,
* holding SECTSZ characters
SECTSZ EQU 256
-SECTRL EQU 8
+SECTRL EQU 2*NATWID ; Currently held sector number, etc.
BUFSZ EQU (SECTSZ+SECTRL)*NBLK
-* 2EE0|6BE0 FIRST
-BUFB16 EQU MEME16-BUFSZ
-BUFB32 EQU MEME32-BUFSZ
-BUFBAS EQU BUFB16
-* "end" of "usable ram" -- in 16K
-* 2EE0|6BE0 <== RP RINIT
-IRP16 EQU BUFB16
-IRP32 EQU BUFB32
-IRP EQU IRP16
+BUFBAS EQU USERLO-BUFSZ
+* *BUG* SECTRL is hard-wired into several definitions.
+* It will take a bit of work to ferret them out.
+* It is too small, and it should not be hard-wired.
+* SECTSZ was also hard-wired into several definitions,
+* will I find them all?
+*
+* 32E0|71E0 FIRST
+*
+ PAGE
+*
+* Don't want one return too many to destroy the disc buffers.
+RPBUMP EQU 4*NATWID
+*
+* 32D8|71D8 <== RP RINIT
+*
+IRP EQU BUFBAS-RPBUMP
* RETURN STACK
-* (64|112 levels nesting)
-RSTK16 EQU 128
-RSTK32 EQU 224
-* (2E60|6B00)
-SFTB16 EQU IRP16-RSTK16
-SFTB32 EQU IRP32-RSTK32
-SFTBND EQU SFTB16
+RSTK16 EQU $50*NATWID ; 80 max levels nesting calls
+RSTK32 EQU $90*NATWID ; 144 max
+RSTKSZ EQU RSTK32
+*
+* 3248|70B8
+*
+SFTBND EQU IRP-RSTKSZ ; (false boundary between TIB and return stack)
* INPUT LINE BUFFER
-* holds up to 256 characters
+* holds up to TIBSZ characters
* and is scanned upward by IN
* starting at TIB
TIBSZ EQU 256
-* 2D60|6A00
-ITIB16 EQU SFTB16-TIBSZ
-ITIB32 EQU SFTB32-TIBSZ
-ITIB EQU ITIB16
-* 2D60|6A00 <== IN TIB
-ISP16 EQU ITIB16
-ISP32 EQU ITIB32
-ISP EQU ISP16
-* 2D60|6A00 <== SP SP0,SINIT
+ITIB EQU SFTBND-TIBSZ
+*
+* 3148|6FB8 <== IN TIB
+*
+* Don't want terminal input and parameter underflow collisions
+SPBUMP EQU 4*NATWID
+*
+ISP EQU ITIB-SPBUMP
+*
+* 3140|6FB0 <== SP SP0,SINIT
* DATA STACK
-* | grows downward from 2A60|6A00
+* | grows downward from 3140|6FB0
* v
* - -
+* ^
* |
* I DICTIONARY grows upward
*
+* >>>>>>--------Two words to start RAMmable dictionary--------<<<<<<
+*
+* (2B00)
* ???? end of ram-dictionary. <== DICTPT DPINIT
* "TASK"
*
* 1200 lowest address used by FORTH
*
CODEBG EQU $1200
+* CODEBG EQU $3000
*
* >>>>>> memory from here down left alone <<<<<<
* >>>>>> so we can safely call ROM routines <<<<<<
W RMB 2 the instruction register points to 6800 code
* This is not exactly accurate. Points to the definiton body,
* which is native CPU machine code when it is native CPU machine code.
-IP RMB 2 the instruction pointer points to pointer to 6800 code
-RP RMB 2 the return stack pointer
-UP RMB 2 the pointer to base of current user's 'USER' table
+* IP RMB 2 the instruction pointer points to pointer to 6800 code
+* RP RMB 2 the return stack pointer
+* UP RMB 2 the pointer to base of current user's 'USER' table
* ( altered during multi-tasking )
*
*UORIG RMB 6 3 reserved variables
+ RMB 6 3 reserved variables
XSPZER RMB 2 initial top of data stack for this user
XRZERO RMB 2 initial top of return stack
XTIB RMB 2 start of terminal input buffer
** C O L D E N T R Y **
***************************
ORIG NOP
- JMP CENT
+* JMP CENT
+ LBSR CENT
***************************
** W A R M E N T R Y **
***************************
NOP
- JMP WENT warm-start code, keeps current dictionary intact
-
+* JMP WENT warm-start code, keeps current dictionary intact
+ LBSR WENT warm-start code, keeps current dictionary intact
SETDP IUPDP
*
FDB 0 initial warning mode (0 = no disc)
FENCIN FDB REND initial fence
DPINIT FDB REND cold start value for DICTPT
-VOCINT FDB FORTH+8
-COLINT FDB 132 initial terminal carriage width
+BUFINT FDB BUFBAS Start of the disk buffers area
+VOCINT FDB FORTH+4*NATWID
+COLINT FDB TIBSZ initial terminal carriage width
DELINT FDB 4 initial carriage return delay
****************************************************
*
* They're too much trouble to use with native subroutine call anyway.
* PULABX PULS A ; 24 cycles until 'NEXT'
* PULS B ;
-PULABX PULU A,B ; ?? cycles until 'NEXT'
+* PULABX PULU A,B ; ?? cycles until 'NEXT'
* STABX STA 0,X 16 cycles until 'NEXT'
* STB 1,X
-STABX STD 0,X ; ?? cycles until 'NEXT'
+* STABX STD 0,X ; ?? cycles until 'NEXT'
BRA NEXT
* GETX LDA 0,X 18 cycles until 'NEXT'
* LDB 1,X
-GETX LDD 0,X ?? cycles until 'NEXT'
+* GETX LDD 0,X ?? cycles until 'NEXT'
* PUSHBA PSHS B ; 8 cycles until 'NEXT'
* PSHS A ;
-PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
+* PUSHBA PSHU A,B ; ?? cycles until 'NEXT'
*
*
* NEXT2 LDX 0,X get W which points to CFA of word to be done
NEXT2 LDX ,Y++ get W which points to CFA of word to be done
+* BSR DBGNAM
+* BSR DBGREG
* But NEXT2 is too much trouble to use with subroutine threading anyway.
* NEXT3 STX W
NEXT3 ; W is X until you use X for something else. (TOS points back here.)
* if a TRACE routine is available: =
* =
* JMP 0,X
+
JSR [,X] ; Saving the postinc cycles,
* ; but X must be bumped NATWID to the parameters.
- NOP
+* NOP
* JMP TRACE ( an alternate for the above )
+* BSR DBGREG ( an alternate for the above )
* In other words, with the call and the NOP,
* there is room to patch the call with a JMP to your TRACE
* routine, which you have to provide.
BRA NEXT
+*
+DBGNAM PSHS CC,D,X,Y
+ TST <TRACEM
+ BEQ DBGNrt
+ LEAX -3,X
+DBGNlf LDB ,-X
+ BPL DBGNlf
+ LDY #$4C0
+ LDB ,X+
+DBGNlp LDB ,X+
+ BMI DBGNll
+ STB ,Y+
+ BRA DBGNlp
+DBGNll ANDB #$7F
+ STB ,Y+
+ LDB #$60
+ BRA DBGNlt
+DBGNlc STB ,Y+
+DBGNlt CMPY #$4E0
+ BLO DBGNlc
+DBGNrt PULS CC,D,X,Y,PC
+*
+*
+MKhxBh LSRB
+ LSRB
+ LSRB
+ LSRB
+MKhxBl ANDB #$0F
+ ADDB #$30
+ CMPB #$39
+ BLS MKhxBx
+ ADDB #$C7 ; ($40-$39)-$40
+MKhxBx RTS
+*
+OUThxA EXG A,B
+ BSR OUThxB
+ EXG A,B
+ RTS
+*
+OUThxD BSR OUThxA
+OUThxB PSHS B
+ BSR MKhxBh
+ STB ,X+
+ LDB ,S
+ BSR MKhxBl
+ STB ,X+
+ PULS B,PC
+*
+DBGREG PSHS U,Y,X,DP,B,A,CC
+ TST <TRACEM
+ LBEQ DBGRrt
+ LEAY DBGRLB,PCR
+ LDX #$4E0
+DBGRlp LDD ,Y++
+ BEQ DBGRdn
+ STD ,X++
+ BRA DBGRlp
+DBGRdn LDX #$500
+ LDA 3,S ; DP
+ LDB ,S ; CC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 3*NATWID+4,S ; PC:505
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ TFR S,D ; 509
+ ADDD #4*NATWID+4
+ BSR OUThxD
+ LDD 2*NATWID+4,S ; U:50E
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1*NATWID+4,S ; Y:513
+ BSR OUThxD
+ LDD 0*NATWID+4,S ; X at 517
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 1,S ; D at 51C
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDD [3*NATWID+4,S] ; PC
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD 4*NATWID+4,S ; S
+ BSR OUThxD
+ LDD [2*NATWID+4,S] ; U
+ BSR OUThxD
+ LDB #$60
+ STB ,X+
+ LDD [1*NATWID+4,S] ; Y
+ LBSR OUThxD
+ LDD [0*NATWID+4,S] ; X
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ STB ,X+
+ LDB #0
+ EXG B,DP
+DBGRkl JSR [$A000]
+ BEQ DBGRkl
+ STD $43E
+ EXG DP,B
+ CMPA #$55 ; 'U'
+ BEQ DBGRdU
+ CMPA #$53 ; 'S'
+ BEQ DBGRdS
+ CMPA #$49 ; 'I'
+ BNE DBGRrt
+DBGRin LDD <XTIB
+ ADDD <XIN
+ TFR D,Y
+ LBSR OUThxD
+ LDB #$3a ; ':'
+ STB ,X+
+ LDA <XCOLUM
+DBGRip LDB ,Y+
+ STB ,X+
+ BEQ DBGRrt
+DBGRit DECA
+ BNE DBGRip
+ BRA DBGRrt
+DBGRdS TFR S,Y
+ BRA DBGRst
+DBGRsp LDD ,Y++
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+DBGRst CMPY <XRZERO
+ BLO DBGRsp
+ LDB #$3a ; ':'
+ STB ,X+
+ LDB #$55
+ STB ,X+
+DBGRdU LDY 2*NATWID+4,S
+ BRA DBGRut
+DBGRup LDD ,Y++
+ LBSR OUThxD
+ LDB #$60
+ STB ,X+
+DBGRut CMPY <XSPZER
+ BLO DBGRup
+DBGRrt PULS CC,A,B,DP,X,Y,U,PC
+DBGRLB FCC 'DPCC PC S U Y X A B '
+ FDB 0,0
+
+
+*
* =
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
FCB $D4 ; 'T'|'\x80' ; character code for T, with high bit set.
FDB 0 ; link of zero to terminate dictionary scan
-LIT FDB *+NATWID ; Note also that it is meaningless in native code.
+LIT FDB *+NATWID ; Note also that LIT is meaningless in native code.
LDD ,Y++
PSHU A,B
RTS
* LDB 1,X
* JMP PUSHBA
*
+* ( n off --- n )
+* off is offset in video buffer area.
+ FCB $87
+ FCC 'SHOWTO' ; 'SHOWTOS'
+ FCB $D3 ; 'S'
+ FDB LIT8-7
+SHOTOS FDB *+NATWID
+ LDX #$400
+ LDD ,U++
+ LEAX D,X
+ LDD ,U
+ LBSR OUThxD
+ RTS
+*
+ FCB $85
+ FCC 'TROF' ; 'TROFF'
+ FCB $C6 ; 'F'|$80
+ FDB SHOTOS-10
+TROFF FDB *+NATWID
+ CLR <TRACEM
+ RTS
+*
+ FCB $84
+ FCC 'TRO' ; 'TRON'
+ FCB $CE ; 'N'|$80
+ FDB TROFF-8
+TRON FDB *+NATWID
+ INC <TRACEM
+ RTS
+*
* ======>> 3 <<
* ( adr --- )
* Jump to address on stack. Used by the "outer" interpreter to
FCB $87
FCC 'EXECUT' ; 'EXECUTE'
FCB $C5
- FDB LIT-7
+ FDB TRON-7
EXEC FDB *+NATWID
PULU X ; Gotta have W anyway, just in case.
JMP [,X] ; Tail return.
PA0 EQU NATWID ; pointer to the length byte of name being searched against
PD EQU 0 ; pointer to NFA of dict word being checked
*
+* INC <TRACEM
+* LBSR DBGREG
LDX PD,U ; Start in on the vocabulary (NFA).
PFNDLP LDY PA0,U ; Point to the name to check against.
LDB ,X+ ; get dict name length byte
TFR B,A ; Save it in case it matches.
ANDB #CTMASK
+* LBSR DBGREG
CMPB ,Y+ ; Compare lengths
+* LBSR DBGREG
BNE PFNDUN
PFNDBR LDB ,X+
TSTB ; ; Is high bit of character in dictionary entry set?
+* LBSR DBGREG
BPL PFNDCH
+* LBSR DBGREG
ANDB #$7F ; Clear high bit from dictionary.
CMPB ,Y+ ; Compare "last" characters.
+* LBSR DBGREG
BEQ FOUND ; Matches even if dictionary actual length is shorter.
PFNDLN LDX ,X++ ; Get previous link in vocabulary.
+* LBSR DBGREG
BNE PFNDLP ; Continue if link not=0
*
* not found :
LEAU NATWID,U ; Return only false flag.
LDD #0
STD ,U
+* LBSR DBGREG
+* DEC <TRACEM
PULS Y,PC
*
PFNDCH CMPB ,Y+ ; Compare characters.
+* LBSR DBGREG
BEQ PFNDBR
PFNDUN
PFNDSC LDB ,X+ ; scan forward to end of this name in dictionary
+* LBSR DBGREG
BPL PFNDSC
+* LBSR DBGREG
BRA PFNDLN
*
* found :
*
FOUND LEAX 2*NATWID,X
+* LBSR DBGREG
STX NATWID,U
TFR A,B
CLRA
STD ,U
+* LBSR DBGREG
LDB #1
PSHU A,B
+* LBSR DBGREG
+* DEC <TRACEM
PULS Y,PC
*
* 6800 model:
* Found NUL before non-delimiter, therefore there is no word
ENCNUL CLRA ; high byte -- buffer < 255 wide!
STD ,U ; offset to NUL.
- ADDD #1 ; For some reason, point after NUL.
+ ADDD #1 ; Point after NUL to allow (FIND) to match it.
PSHU A,B ;
SUBD #1 ; Next is not passed NUL.
PSHU A,B ; Stealing code will save only one byte.
RTS
* Found NUL following the word instead of delimiter.
-ENC0TR PSHU A,B ; Save offset to first after symbol (NUL)
+ENC0TR
+* INC <TRACEM
+* LBSR DBGREG
+ CLRA
+ PSHU A,B ; Save offset to first after symbol (NUL)
+* LBSR DBGREG
PSHU A,B ; and count scanned.
+* LBSR DBGREG
+* DEC <TRACEM
RTS
* NOTE :
* FC means offset (bytes) to First Character of next word
FCB $D4
FDB ENCLOS-10
EMIT FDB *+NATWID
- LBSR PEMIT ; PEMIT handles the stack.
+ PULU D
+ LBSR PEMIT ; PEMIT expects the character in D.
INC <XOUT+1
BNE EMITDN
INC <XOUT
FCB $D9
FDB EMIT-7
KEY FDB *+NATWID
- LBSR PKEY ; PKEY handles the stack.
+ LBSR PKEY ; PKEY leaves the key/break code in D.
+ PSHU D
RTS
* JSR PKEY
* PSHS A ;
FCB $CC
FDB KEY-6
QTERM FDB *+NATWID
- LBSR PQTER ; PQTER handles the stack.
+ LBSR PQTER ; PQTER leaves the flag/key in D.
+ PSHU D
RTS
* JSR PQTER
* CLRB ;
FCB $D2
FDB QTERM-12
CR FDB *+NATWID
- LBSR PCR ; PCR handles the stack.
- RTS
+ LBRA PCR ; Nothing really to do here.
* JSR PCR
* JMP NEXT
*
FCB $C5
FDB CR-5
CMOVE FDB *+NATWID
-* One way: ; takes ( 37+17*count+9*(count/256) cycles )
- PSHS Y ; #2~7 ; Gotta have our pointers.
- PULU D,X,Y ; #2~11
- PSHS A ; #2~6 ; Gotta have our pointers.
- BRA CMOVLE ; #2~3
-CMOVLP
- LDA ,Y+ ; #2~6
- STA ,X+ ; #2~6
-CMOVLE
- SUBB #1 ; #2~2
- BCC CMOVLP ; #2~3
- DEC ,S ; #2=6
- BPL CMOVLP ; #2~3
- PULS A,Y,PC ; #2~10
* Another way ; takes ( 42+17*count+9*(count/256) cycles )
-* LDD #0 ; #3~3
-* SUBD ,U++ ; #2~9 ; invert the count
-* PSHS A,Y ; #2~8
-* PULU X,Y ; #2~9
-* BEQ CMOVEX ; #2~3
-* CMOVEL
-* LDA ,Y+ ; #2~6
-* STA ,X+ ; #2~6
-* INCB ; #1~2
-* BNE CMOVEL ; #2~3
-* INC ,S ; #2~6
-* BNE CMOVEL ; #2~3
-* CMOVEX
-* PULS A,Y,PC ; #2~10
+ LDD #0 ; #3~3
+ SUBD ,U++ ; #2~9 ; invert the count
+ PSHS A,Y ; #2~8
+ PULU X,Y ; #2~9
+ BEQ CMOVEX ; #2~3
+CMOVEL
+ LDA ,Y+ ; #2~6
+ STA ,X+ ; #2~6
+ INCB ; #1~2
+ BNE CMOVEL ; #2~3
+ INC ,S ; #2~6
+ BNE CMOVEL ; #2~3
+CMOVEX PULS A,Y,PC ; #2~10
+* PSHS Y ;
+* INC <TRACEM
+* LBSR DBGREG
+* LDX 1*NATWID,U
+* LDY 2*NATWID,U
+* BRA CMOVLE ;
+* CMOVLP
+* LBSR DBGREG
+* LDA ,Y+
+* STA ,X+
+* LBSR DBGREG
+* CMOVLE
+* LDD ,U
+* SUBD #1
+* STD ,U
+* BCC CMOVLP
+* LEAU 3*NATWID,U
+* DEC <TRACEM
+* PULS Y,PC
+* One way: ; takes ( 37+17*count+9*(count/256) cycles )
+* PSHS Y ; #2~7 ; Gotta have our pointers.
+* INC <TRACEM
+* LBSR DBGREG
+* PULU D,X,Y ; #2~11
+* PSHS A ; #2~6 ; Gotta have our pointers.
+* BRA CMOVLE ; #2~3
+* CMOVLP
+* LBSR DBGREG
+* LDA ,Y+ ; #2~6
+* STA ,X+ ; #2~6
+* LBSR DBGREG
+* CMOVLE
+* SUBB #1 ; #2~2
+* BCC CMOVLP ; #2~3
+* DEC ,S ; #2=6
+* BPL CMOVLP ; #2~3 ; If this actually works, it is limited to 32k here.
+* DEC <TRACEM
+* PULS A,Y,PC ; #2~10
* Yet another way ; takes ( 37+29*count cycles )
* PSHS Y ; #2~7
* LDX NATWID,U ; #2~6
BCC USTAR4
INC ,U
USTAR4 STD 1,U
- PULS D,X
+ PULU D,X
STD ,U
STX NATWID,U
RTS
*
* ######>> screen 28 <<
* ======>> 31 <<
+* ( n --- ~n )
+* Logically invert top of stack;
+* or flag true if top is zero, otherwise false.
+ FCB $83
+ FCC 'NO' ; 'NOT'
+ FCB $D4
+ FDB R-4
+LNOT FDB *+NATWID
+ COM 1,U
+ COM ,U
+ RTS
* ( n --- n=0 )
* Logically invert top of stack;
* or flag true if top is zero, otherwise false.
FCB $82
FCC '0' ; '0='
FCB $BD
- FDB R-4
+ FDB LNOT-6
ZEQU FDB *+NATWID
LDD #0
LDX ,U
*
* ======>> 59 <<
* ( --- sectorsize )
+* The size, in bytes, of a buffer control region.
+ FCB $85
+ FCC 'B/CT' ; 'B/CTL' : (bytes/control region)
+ FCB $CC
+ FDB LIMIT-8
+BCTL FDB DOCON
+ FDB SECTRL
+*
+* ( --- sectorsize )
* The size, in bytes, of a buffer.
FCB $85
FCC 'B/BU' ; 'B/BUF' : (bytes/buffer)
FCB $C6
- FDB LIMIT-8
+ FDB BCTL-8
BBUF FDB DOCON
FDB SECTSZ
* Hardcoded in 6800 model:
STD ,U
MINX RTS
* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
-* FDB MIN2-*
+* FDB MIN2-*-NATWID
* FDB SWAP
* MIN2 FDB DROP
* FDB SEMIS
STD ,U
MAXX RTS
* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
-* FDB MAX2-*
+* FDB MAX2-*-NATWID
* FDB SWAP
* MAX2 FDB DROP
* FDB SEMIS
PSHU D
DDUPX RTS
* DDUP FDB DOCOL,DUP,ZBRAN
-* FDB DDUP2-*
+* FDB DDUP2-*-NATWID
* FDB DUP
* DDUP2 FDB SEMIS
*
* TRAV2 FDB OVER,PLUS,LIT8
* FCB $7F
* FDB OVER,CAT,LESS,ZBRAN
-* FDB TRAV2-*
+* FDB TRAV2-*-NATWID
* FDB SWAP,DROP
* FDB SEMIS
*
* RTS
** this doesn't work anyway: QERROR LBR ERROR
QERR FDB DOCOL,SWAP,ZBRAN
- FDB QERR2-*
+ FDB QERR2-*-NATWID
FDB ERROR,BRAN
- FDB QERR3-*
+ FDB QERR3-*-NATWID
QERR2 FDB DROP
QERR3 FDB SEMIS
*
FCB $C5
FDB QLOAD-11
* COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
-COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+* COMPIL FDB DOCOL,QCOMP,FROMR,NATP,DUP,TOR,AT,COMMA
+COMPIL FDB DOCOL,QCOMP,FROMR,DUP,NATP,TOR,AT,COMMA
FDB SEMIS
*
* ======>> 112 <<
FCB $C5
FDB COUNT-8
TYPE FDB DOCOL,DDUP,ZBRAN
- FDB TYPE3-*
+ FDB TYPE3-*-NATWID
FDB OVER,PLUS,SWAP,XDO
TYPE2 FDB I,CAT,EMIT,XLOOP
- FDB TYPE2-*
+ FDB TYPE2-*-NATWID
FDB BRAN
- FDB TYPE4-*
+ FDB TYPE4-*-NATWID
TYPE3 FDB DROP
TYPE4 FDB SEMIS
*
DTRAIL FDB DOCOL,DUP,ZERO,XDO
DTRAL2 FDB OVER,OVER,PLUS,ONE,SUB,CAT,BL
FDB SUB,ZBRAN
- FDB DTRAL3-*
+ FDB DTRAL3-*-NATWID
FDB LEAVE,BRAN
- FDB DTRAL4-*
+ FDB DTRAL4-*-NATWID
DTRAL3 FDB ONE,SUB
DTRAL4 FDB XLOOP
- FDB DTRAL2-*
+ FDB DTRAL2-*-NATWID
FDB SEMIS
*
* ======>> 124 <<
FCB $A9
FDB DTRAIL-12
* PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
-PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+* PDOTQ FDB DOCOL,R,NATP,COUNT,DUP,ONEP
+PDOTQ FDB DOCOL,R,COUNT,DUP,ONEP
FDB FROMR,PLUS,TOR,TYPE
FDB SEMIS
*
FDB LIT8
FCB $22 ascii quote
FDB STATE,AT,ZBRAN
- FDB DOTQ1-*
+ FDB DOTQ1-*-NATWID
FDB COMPIL,PDOTQ,WORD
FDB HERE,CAT,ONEP,ALLOT,BRAN
- FDB DOTQ2-*
+ FDB DOTQ2-*-NATWID
DOTQ1 FDB WORD,HERE,COUNT,TYPE
DOTQ2 FDB SEMIS
*
FDB HERE,LIT8
FCB $80 ; This is a rough check anyway, leave it as is.
FDB PLUS,LESS,ZBRAN
- FDB QSTAC3-*
+ FDB QSTAC3-*-NATWID
FDB TWO ; NOT the NATWID constant!
FDB QERR
* prints 'full stack'
FCB $D4
FDB QSTACK-9
EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
-EXPEC2 FDB KEY,DUP,LIT8
+* EXPEC2 FDB KEY,DUP,LIT8
+EXPEC2 FDB KEY
+* FDB LIT,$1C,SHOTOS ; DBG
+ FDB DUP,LIT8
FCB BACKSP-ORIG
FDB PORIG,AT,EQUAL,ZBRAN ; check for backspacing
- FDB EXPEC3-*
+ FDB EXPEC3-*-NATWID
FDB DROP,LIT8
FCB 8 ( backspace character to emit )
- FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back up TWO characters
+ FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS ; back I up TWO characters
FDB TOR,SUB,BRAN
- FDB EXPEC6-*
+ FDB EXPEC6-*-NATWID
EXPEC3 FDB DUP,LIT8
FCB $D ( carriage return )
FDB EQUAL,ZBRAN
- FDB EXPEC4-*
+ FDB EXPEC4-*-NATWID
FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
- FDB EXPEC5-*
+ FDB EXPEC5-*-NATWID
EXPEC4 FDB DUP
EXPEC5 FDB I,CSTORE,ZERO,I,ONEP,STORE
EXPEC6 FDB EMIT,XLOOP
- FDB EXPEC2-*
+ FDB EXPEC2-*-NATWID
FDB DROP
FDB SEMIS
*
FCB $80
FDB QUERY-8
NULL FDB DOCOL,BLK,AT,ZBRAN
- FDB NULL2-*
+ FDB NULL2-*-NATWID
FDB ONE,BLK,PSTORE
FDB ZERO,IN,STORE,BLK,AT,BSCR,MOD
FDB ZEQU
* check for end of screen
FDB ZBRAN
- FDB NULL1-*
+ FDB NULL1-*-NATWID
FDB QEXEC,FROMR,DROP
NULL1 FDB BRAN
- FDB NULL3-*
+ FDB NULL3-*-NATWID
NULL2 FDB FROMR,DROP
NULL3 FDB SEMIS
*
* ======>> 133 <<
* ( adr n b --- )
* Fill n bytes at adr with b.
+* This relies on CMOVE having a certain lack of parameter checking,
+* where overlapping regions are not properly inverted in copy.
+* And this really should be done in low-level.
+* None of the advantages of doing things in high-level apply to fill.
FCB $84
FCC 'FIL' ; 'FILL'
FCB $CC
FCB $C4
FDB PAD-6
WORD FDB DOCOL,BLK,AT,ZBRAN
- FDB WORD2-*
+ FDB WORD2-*-NATWID
FDB BLK,AT,BLOCK,BRAN
- FDB WORD3-*
+ FDB WORD3-*-NATWID
WORD2 FDB TIB,AT
WORD3 FDB IN,AT,PLUS,SWAP,ENCLOS,HERE,LIT8
FCB 34
FDB WORD-7
PNUMB FDB DOCOL
PNUMB2 FDB ONEP,DUP,TOR,CAT,BASE,AT,DIGIT,ZBRAN
- FDB PNUMB4-*
+ FDB PNUMB4-*-NATWID
FDB SWAP,BASE,AT,USTAR,DROP,ROT,BASE
FDB AT,USTAR,DPLUS,DPL,AT,ONEP,ZBRAN
- FDB PNUMB3-*
+ FDB PNUMB3-*-NATWID
FDB ONE,DPL,PSTORE
PNUMB3 FDB FROMR,BRAN
- FDB PNUMB2-*
+ FDB PNUMB2-*-NATWID
PNUMB4 FDB FROMR
FDB SEMIS
*
FDB EQUAL,DUP,TOR,PLUS,LIT,$FFFF
NUMB1 FDB DPL,STORE,PNUMB,DUP,CAT,BL,SUB
FDB ZBRAN
- FDB NUMB2-*
+ FDB NUMB2-*-NATWID
FDB DUP,CAT,LIT8
FCC "."
FDB SUB,ZERO,QERR,ZERO,BRAN
- FDB NUMB1-*
+ FDB NUMB1-*-NATWID
NUMB2 FDB DROP,FROMR,ZBRAN
- FDB NUMB3-*
+ FDB NUMB3-*-NATWID
FDB DMINUS
NUMB3 FDB SEMIS
*
FDB NUMB-9
DFIND FDB DOCOL,BL,WORD,HERE,CONTXT,AT,AT
FDB PFIND,DUP,ZEQU,ZBRAN
- FDB DFIND2-*
+ FDB DFIND2-*-NATWID
FDB DROP,HERE,LATEST,PFIND
DFIND2 FDB SEMIS
*
* First, we need to get this transliteration running.
ERROR FDB DOCOL,WARN,AT,ZLESS
FDB ZBRAN
+ FDB ERROR2-*-NATWID
* note: WARNING is
* -1 to abort,
* 0 to print error #
* and 1 to print error message from disc
- FDB ERROR2-*
FDB PABORT
ERROR2 FDB HERE,COUNT,TYPE,PDOTQ
FCB 4,7 ( bell )
FDB SEMIS
*
* ======>> 144 <<
+* ( n adr --- )
+* Mask byte at adr with n.
+* Not in FIG, don't need it for 8 bit characters after all.
+* FCB $85
+* FCC 'CMAS' ; 'CMASK'
+* FCB $CB ; 'K'
+* FDB ERROR-8
+* CMASK FDB *+NATWID
+* LDX ,U++ ; adr
+* LDD ,U++ ; mask
+* ANDB ,X
+* STB ,X
+* RTS
+*
+* ( adr --- adr )
+* Mask high bit of tail of name in PAD buffer.
+* Not in FIG, need it for 8 bit characters.
+ FCB $86
+ FCC 'IDFLA' ; 'IDFLAT'
+ FCB $D4 ; 'T'
+ FDB ERROR-8
+IDFLAT FDB *+NATWID
+ LDX ,U
+ LDB ,X ; get the count
+ ANDB #CTMASK
+ LDA B,X ; point to the tail
+ ANDA #$7F ; Clear the EndOfName flag bit.
+ STA B,X
+ RTS
+*
* ( symptr --- )
* Print definition's name from its NFA.
FCB $83
FCC 'ID' ; 'ID.'
FCB $AE
- FDB ERROR-8
+ FDB IDFLAT-9
IDDOT FDB DOCOL,PAD,LIT8
FCB 32
FDB LIT8
FCB $5F ( underline )
FDB FILL,DUP,PFA,LFA,OVER,SUB,PAD
- FDB SWAP,CMOVE,PAD,COUNT,LIT8
+* FDB SWAP,CMOVE,PAD,COUNT,LIT8
+ FDB SWAP,CMOVE,PAD
+ FDB IDFLAT
+ FDB COUNT,LIT8
FCB 31
FDB AND,TYPE,SPACE
FDB SEMIS
FCB $C5
FDB IDDOT-6
CREATE FDB DOCOL,DFIND,ZBRAN
- FDB CREAT2-*
+ FDB CREAT2-*-NATWID
FDB DROP,PDOTQ
FCB 8
FCB 7 ( bel )
FCB $CC
FDB BCOMP-12
LITER FDB DOCOL,STATE,AT,ZBRAN
- FDB LITER2-*
+ FDB LITER2-*-NATWID
FDB COMPIL,LIT,COMMA
LITER2 FDB SEMIS
*
FCB $CC
FDB LITER-10
DLITER FDB DOCOL,STATE,AT,ZBRAN
- FDB DLITE2-*
+ FDB DLITE2-*-NATWID
FDB SWAP,LITER,LITER ; Just two literals in the right order.
DLITE2 FDB SEMIS
*
FDB DLITER-11
INTERP FDB DOCOL
INTER2 FDB DFIND,ZBRAN
- FDB INTER5-*
+ FDB INTER5-*-NATWID
FDB STATE,AT,LESS
FDB ZBRAN
- FDB INTER3-*
+ FDB INTER3-*-NATWID
FDB CFA,COMMA,BRAN
- FDB INTER4-*
+ FDB INTER4-*-NATWID
INTER3 FDB CFA,EXEC
INTER4 FDB BRAN
- FDB INTER7-*
+ FDB INTER7-*-NATWID
INTER5 FDB HERE,NUMB,DPL,AT,ONEP,ZBRAN
- FDB INTER6-*
+ FDB INTER6-*-NATWID
FDB DLITER,BRAN
- FDB INTER7-*
+ FDB INTER7-*-NATWID
INTER6 FDB DROP,LITER
INTER7 FDB QSTACK,BRAN
- FDB INTER2-*
+ FDB INTER2-*-NATWID
* FDB SEMIS never executed
*
* then repeats :
QUIT2 FDB RPSTOR,CR,QUERY,INTERP,STATE,AT,ZEQU
FDB ZBRAN
- FDB QUIT3-*
+ FDB QUIT3-*-NATWID
FDB PDOTQ
FCB 3
FCC ' OK' ; ' OK'
QUIT3 FDB BRAN
- FDB QUIT2-*
+ FDB QUIT2-*-NATWID
* FDB SEMIS ( never executed )
*
* ======>> 156 <<
FCB $D4
FDB QUIT-7
ABORT FDB DOCOL,SPSTOR,DEC,QSTACK,DRZERO,CR,PDOTQ
- FCB 8
- FCC "Forth-68"
+ FCB 10
+ FCC "Forth-6809"
FDB FORTH,DEFIN
FDB QUIT
* FDB SEMIS never executed
* We'll keep this here for the time being.
* There are better ways to do this, of course.
* Re-architect, re-architect.
- LEAX RAM,PCR
+ LEAX ERAM,PCR ; end of stuff to move
STX <XFENCE ; Borrow this variable for a loop terminator.
- LEAY REND,PCR ; top of destination
- LEAX ERAM,PCR ; top of stuff to move
-COLD2 LDA ,-X
- STA ,-Y ; move TASK & FORTH to ram
+ LDY #RBEG ; bottom of open-ended destination
+ LEAX RAM,PCR ; bottom of stuff to move
+COLD2 LDA ,X+
+ STA ,Y+ ; move TASK & FORTH to ram
CMPX <XFENCE
BNE COLD2
+* Leaves USE and PREV uninitialized.
+ LDX BUFINT,PCR
+ STX <XUSE
+ STX <XPREV
+* LEAX RAM,PCR
+* STX <XFENCE ; Borrow this variable for a loop terminator.
+* LEAY REND,PCR ; top of destination (included XUSE and XPREV)
+* LEAX ERAM,PCR ; top of stuff to move (included initializers for XUSE and XPREV)
+* COLD2 LDA ,-X
+* STA ,-Y ; move TASK & FORTH to ram
+* CMPX <XFENCE
+* BNE COLD2
*
* CENT LDS #REND-1 top of destination
* LDX #ERAM top of stuff to move
PSHS X ; for loop termination
CLRB ; Yes, I'm being a little ridiculous. Only a little.
TFR D,Y
- LEAY XFENCE,Y ; top of destination
+ LEAY XFENCE-UORIG,Y ; top of destination
LEAX FENCIN,PCR ; top of stuff to move
WARM2 LDD ,--X ; All entries are 16 bit.
STD ,--Y
CMPX ,S
BNE WARM2
LEAS 2,S ; But we'll reset the return stack shortly, anyway.
+ LDU <XSPZER ; So we can clear the hole above the TOS
* WENT LDS #XFENCE-1 top of destination
* LDX #FENCIN top of stuff to move
* WARM2 LEAX -1,X ;
* UP is already there (DP).
* LDX #ABORT
* STX IP
- LEAY ABORT,PCR ; Prepare IP.
+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
*
NOP Here is a place to jump to special user
NOP initializations such as I/0 interrups
*
* For systems with TRACE:
LDX #00
+ STX ,U The hole above the parameter stack
* STX TRLIM clear trace mode
- STX <TRLIM clear trace mode
+ STX <TRLIM clear trace mode (both bytes)
LDX #0
* STX BRKPT clear breakpoint address
STX <BRKPT clear breakpoint address
* JMP RPSTOR+2 start the virtual machine running !
LBSR RPSTOR+NATWID start the virtual machine running !
- LBRA NEXT ; But we must also give RP! someplace to return.
+ LEAX WENT,PCR ; But we must also give RP! someplace to return.
+ STX ,S ; This rail might get walked on by (DO).
+ LBRA NEXT
* RP! sets up the return stack pointer, then Y references abort.
*
* Here is the stuff that gets copied to ram :
* (not * at address $140:)
* at an appropriate address:
*
-RAM FDB $3000,$3000,0,0
-
+* RAM FDB $3000,$3000,0,0
+* RAM FDB BUFBAS,BUFBAS,0,0 ; ... except the direct page has moved.
+* These initialization values for USE and PREV were here to help pack the code.
+* They don't belong here unless we move the USER table
+* back below the writable dictionary,
+* *and* move these USER variables to the end of the direct page --
+* *or* let these definitions exist in the USER table.
+RAM EQU *
+
* ======>> (152) <<
* ( --- ) P
* Makes FORTH the current interpretation vocabulary.
FDB NOOP-7 ; Note that this does not link to COLD!
RFORTH FDB DODOES,DOVOC,$81A0,TASK-7
FDB 0
- FCC "(C) Forth Interest Group, 1979"
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
FCB $84
FCC 'TAS' ; 'TASK'
FCB $CB
FDB FORTH-8
RTASK FDB DOCOL,SEMIS
-ERAM FCC "David Lion"
+ERAM EQU *
+ERAMSZ EQU *-RAM ; So we can get a look at it.
PAGE
*
* ######>> screen 57 <<
* ( dividend divisor --- remainder quotient )
* M/ in word-only form, i. e., signed division of 2nd word by top word,
* yielding signed word quotient and remainder.
+* Except *BUG* it isn't signed.
FCB $84
FCC '/MO' ; '/MOD'
FCB $C4
* ======>> 161 <<
* ( dividend divisor --- quotient )
* Signed word divide without remainder.
+* Except *BUG* it isn't signed.
FCB $81 ; /
FCB $AF
FDB SLMOD-7
FCB $D3
FDB MSMOD-8
ABS FDB DOCOL,DUP,ZLESS,ZBRAN
- FDB ABS2-*
+ FDB ABS2-*-NATWID
FDB MINUS
ABS2 FDB SEMIS
*
FCB $D3
FDB ABS-6
DABS FDB DOCOL,DUP,ZLESS,ZBRAN
- FDB DABS2-*
+ FDB DABS2-*-NATWID
FDB DMINUS
DABS2 FDB SEMIS
*
FCC '+BU' ; '+BUF'
FCB $C6
FDB PREV-7
-PBUF FDB DOCOL,LIT8
- FCB $84
- FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
- FDB PBUF2-*
+* PBUF FDB DOCOL,LIT8
+* FCB $84 ; This was a hard-wiring bug.
+PBUF FDB DOCOL,BBUF,BCTL,PLUS ; Size of the buffer record.
+* FDB PLUS,DUP,LIMIT,EQUAL,ZBRAN
+ FDB PLUS,DUP,LIMIT,LESS,ZEQU,OVER,FIRST,LESS,OR,ZBRAN
+ FDB PBUF2-*-NATWID ; Use defensive programming.
FDB DROP,FIRST
PBUF2 FDB DUP,PREV,AT,SUB
FDB SEMIS
*
* ======>> 171 <<
+* ( --- f )
+* Flag to mark a buffer dirty, in need of being written out.
+* This flag limits the max number of sectors in a disk to ((256^NATWID)/2)-1.
+* It also hard-codes an implicit test which is used elsewhere.
+ FCB $8A
+ FCC 'UPDATE-BI' ; 'UPDATE-BIT'
+ FCB $D4
+ FDB PBUF-7
+UPDBIT FDB DOCON
+ FDB $8000
+*
* ( --- )
* Mark PREVious buffer dirty, in need of being written out.
FCB $86
FCC 'UPDAT' ; 'UPDATE'
FCB $C5
- FDB PBUF-7
-UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+ FDB UPDBIT-13
+* UPDATE FDB DOCOL,PREV,AT,AT,LIT,$8000,OR,PREV,AT,STORE
+UPDATE FDB DOCOL,PREV,AT,AT,UPDBIT,OR,PREV,AT,STORE
FDB SEMIS
*
* ======>> 172 <<
+* ( adr --- )
+* Mark the buffer addressed as empty.
+* Have to add code to avoid block 0 appearing to be in a buffer from COLD.
+* Usually, there is no sector 0 (?), but the RAM buffers are too simple.
+* Note that without this block number being made illegal,
+* about 8 binaryMegabytes (256 bytes/block) of disk can be addressed total.
+* With this block number made illegal, the max is 1 block less,
+* still about 8 biMeg.
+ FCB $8B
+ FCC 'KILL-BUFFE' ; 'KILL-BUFFER'
+ FCB $D2
+ FDB UPDATE-9
+KILBUF FDB *+NATWID ; DOCOL,UPDBIT,ONE,SUB,SWAP,STORE
+ PULU X
+ LDD UPDBIT+NATWID,PCR
+ SUBD #1
+ STD ,X
+* LBSR DBGREG
+ RTS
+*
+ FCB $8C
+ FCC 'KILL-BUFFER' ; 'KILL-BUFFERS'
+ FCB $D3
+ FDB KILBUF-14
+KLBFS FDB *+NATWID
+ LDD #4
+ PSHU D
+ LDD FIRST+NATWID,PCR
+* INC <TRACEM
+* LBSR DBGREG
+ PSHU D ; DUP
+KLBFSL PSHU D
+ BSR KILBUF+NATWID
+ LDD ,U
+* LBSR DBGREG
+ ADDD BBUF+NATWID,PCR
+ ADDD BCTL+NATWID,PCR
+ STD ,U
+* LBSR DBGREG
+ DEC NATWID+1,U
+ BNE KLBFSL
+* LBSR DBGREG
+ LEAU NATWID*2,U
+* DEC <TRACEM
+ RTS
+*
* ( --- )
-* Mark all buffers empty.
+* Erase and mark all buffers empty.
* Standard method of discarding changes.
FCB $8D
FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
FCB $D3
- FDB UPDATE-9
+ FDB KLBFS-15
MTBUF FDB DOCOL,FIRST,LIMIT,OVER,SUB,ERASE
+* FDB FIRST,DUP,KILBUF,PBUF,DROP,DUP,KILBUF
+* FDB PBUF,DROP,DUP,KILBUF,PBUF,DROP,KILBUF
+ FDB KLBFS
FDB SEMIS
*
* ======>> 173 <<
FCC 'DR' ; 'DR1'
FCB $B1
FDB DRZERO-6
-DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+DRONE FDB DOCOL,LIT,$07D0,OFSET,STORE
+; **** hard-codes the size of the disc !!!!
FDB SEMIS
*
* ######>> screen 59 <<
FDB DRONE-6
BUFFER FDB DOCOL,USE,AT,DUP,TOR
BUFFR2 FDB PBUF,ZBRAN
- FDB BUFFR2-*
+ FDB BUFFR2-*-NATWID
FDB USE,STORE,R,AT,ZLESS
FDB ZBRAN
- FDB BUFFR3-*
+ FDB BUFFR3-*-NATWID
* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
- FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ FDB R,NATP,R,AT,UPDBIT,LNOT,AND,ZERO,RW
* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
FDB SEMIS
FDB BUFFER-9
BLOCK FDB DOCOL,OFSET,AT,PLUS,TOR
FDB PREV,AT,DUP,AT,R,SUB,DUP,PLUS,ZBRAN
- FDB BLOCK5-*
+ FDB BLOCK5-*-NATWID
BLOCK3 FDB PBUF,ZEQU,ZBRAN
- FDB BLOCK4-*
+ FDB BLOCK4-*-NATWID
* FDB DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
FDB DROP,R,BUFFER,DUP,R,ONE,RW,NATWC,SUB
BLOCK4 FDB DUP,AT,R,SUB,DUP,PLUS,ZEQU,ZBRAN
- FDB BLOCK3-*
+ FDB BLOCK3-*-NATWID
FDB DUP,PREV,STORE
* BLOCK5 FDB FROMR,DROP,TWOP
BLOCK5 FDB FROMR,DROP,NATP
FCB $C5
FDB DLINE-8
MESS FDB DOCOL,WARN,AT,ZBRAN
- FDB MESS3-*
+ FDB MESS3-*-NATWID
FDB DDUP,ZBRAN
- FDB MESS3-*
+ FDB MESS3-*-NATWID
FDB LIT8
FCB 4
FDB OFSET,AT,BSCR,SLASH,SUB,DLINE,BRAN
- FDB MESS4-*
+ FDB MESS4-*-NATWID
MESS3 FDB PDOTQ
FCB 6
FCC 'err # ' ; 'err # '
* called by words 13 through 16 in the dictionary.
*
* ======>> 182 << code for EMIT
-* ( c --- )
-* output using rom CHROUT: redirectable to a printer on Coco.
+* ( --- ) No parameter stack effect.
+* Interfaces directly with ROM. Expects output character in D (therefore, B).
+* Output using rom CHROUT: redirectable to a printer on Coco.
* Outputs the character on stack (low byte of 1 bit word/cell).
-PEMIT PULU D
-PEMITW TFR B,A ; Coco ROM wants it in A.
- PSHS Y,U,DP ; Save everything important!
+PEMIT PSHS Y,U,DP ; Save everything important! (For good measure, only.)
+ TFR B,A ; Coco ROM wants it in A.
CLRB
- TFR B,DP ; Give the ROM it's direct page.
+ TFR B,DP ; Give the ROM its direct page.
JSR [$A002] ; Output the character in A.
PULS Y,U,DP,PC
* PEMIT STB N save B
* PEMIT JMP $D286 for Smoke Signal DOS
*
* ======>> 183 << code for KEY
-* ( --- c )
-* wait for key from POLCAT on Coco.
+* ( --- ) No parameter stack effect.
+* Returns character or break flag in D, since this interfaces with Coco ROM.
+* Wait for key from POLCAT on Coco.
* Returns the character code for the key pressed.
-PKEY PSHS Y,U,DP
+PKEY PSHS Y,U,DP ; Must save everything important for this one.
LDA #$CF ; a cursor of sorts
CLRB
TFR B,DP
LDB ,X ; save glyph
STA ,X
PKEYLP JSR [$A000]
+* STA $41A ; DBG!
BEQ PKEYLP
- STB ,X ; restore
-PKEYR CLRB ; for the break flag
+* STD $418 ; DBG!
+ STB ,X ; restore
+PKEYR CLRB ; for the break flag, shares code with PQTER
CMPA #3 ; break key
BNE PKEYGT
COMB ; for the break flag
-PKEYGT EXG A,B
- PSHU D
- PULS Y,U,DP,PC
+PKEYGT EXG A,B ; Leave it in D for return.
+ PULS Y,U,DP,PC ; Shares exit with PQTER
SETDP IUPDP
* PKEY STB N
* STX N+1
*
* ######>> screen 64 <<
* ======>> 184 << code for ?TERMINAL
-* ( --- f )
+* ( --- f ) Should change this to no stack effect.
* check break key using POLCAT
* Returns a flag to tell whether the break key was pressed or not.
PQTER PSHS Y,U,DP
PAGE
*
* ======>> 185 << code for CR
-* ( --- )
+* ( --- ) No stack effect.
+* Interfaces directly with ROM.
* For Coco just output a CR.
* Also subject to redirection in Coco BASIC ROM.
PCR LDB #$0D
- BRA PEMITW
+ BRA PEMIT ; Just steal the code.
* PCR LDA #$D carriage return
* BSR PEMIT
* LDA #$A line feed
JMP NEXT
*
*The next 3 words are written to create a substitute for disc
-* mass memory,located between $3210 & $3FFF in ram.
+* mass memory,located between MASSLO & MASSHI in ram --
+* ($3210 and $3fff in the 6800 model).
* ======>> 190.1 <<
FCB $82
FCC 'L' ; 'LO'
FCB $D7
FDB HI-5
RW FDB DOCOL,TOR,BBUF,STAR,LO,PLUS,DUP,HI,GREAT,ZBRAN
- FDB RW2-*
+ FDB RW2-*-NATWID
FDB PDOTQ
FCB 8
FCC ' Range ?' ; ' Range ?'
FDB QUIT
RW2 FDB FROMR,ZBRAN
- FDB RW3-*
+ FDB RW3-*-NATWID
FDB SWAP
RW3 FDB BBUF,CMOVE
FDB SEMIS
FCC 'BAC' ; 'BACK'
FCB $CB
FDB FORGET-9
-BACK FDB DOCOL,HERE,SUB,COMMA
+* BACK FDB DOCOL,HERE,SUB,COMMA
+BACK FDB DOCOL,HERE,NATP,SUB,COMMA
FDB SEMIS
*
* ======>> 195 <<
FCB $C6
FDB BEGIN-8
ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
- FDB OVER,SUB,SWAP,STORE
+ FDB OVER,NATP,SUB,SWAP,STORE
FDB SEMIS
*
* ======>> 197 <<
FCB $D3
FDB WHILE-8
SPACES FDB DOCOL,ZERO,MAX,DDUP,ZBRAN
- FDB SPACE3-*
+ FDB SPACE3-*-NATWID
FDB ZERO,XDO
SPACE2 FDB SPACE,XLOOP
- FDB SPACE2-*
+ FDB SPACE2-*-NATWID
SPACE3 FDB SEMIS
*
* ======>> 209 <<
FCB $CE
FDB EDIGS-5
SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
- FDB SIGN2-*
+ FDB SIGN2-*-NATWID
FDB LIT8
FCC "-"
FDB HOLD
DIG FDB DOCOL,BASE,AT,MSMOD,ROT,LIT8
FCB 9
FDB OVER,LESS,ZBRAN
- FDB DIG2-*
+ FDB DIG2-*-NATWID
FDB LIT8
FCB 7
FDB PLUS
FDB DIG-4
DIGS FDB DOCOL
DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
- FDB DIGS2-*
+ FDB DIGS2-*-NATWID
FDB SEMIS
*
* ######>> screen 76 <<
* ( n --- )
* Print out screen n as a field of ASCII,
* with line numbers in decimal.
+* Needs a console more than 70 characters wide.
FCB $84
FCC 'LIS' ; 'LIST'
FCB $D4
FDB ZERO,XDO
LIST2 FDB CR,I,THREE
FDB DOTR,SPACE,I,SCR,AT,DLINE,XLOOP
- FDB LIST2-*
+ FDB LIST2-*-NATWID
FDB CR
FDB SEMIS
*
* ( start end --- )
* Print comment lines (line 0, and line 1 if C/L < 41) of screens
* from start to end.
+* Needs a console more than 70 characters wide.
FCB $85
FCC 'INDE' ; 'INDEX'
FCB $D8
INDEX2 FDB CR,I,THREE
FDB DOTR,SPACE,ZERO,I,DLINE
FDB QTERM,ZBRAN
- FDB INDEX3-*
+ FDB INDEX3-*-NATWID
FDB LEAVE
INDEX3 FDB XLOOP
- FDB INDEX2-*
+ FDB INDEX2-*-NATWID
FDB SEMIS
*
* ======>> 221 <<
* ( n --- )
* List a printer page full of screens.
* Line and screen number are in current base.
+* Needs a console more than 70 characters wide.
FCB $85
FCC 'TRIA' ; 'TRIAD'
FCB $C4
FDB THREE,OVER,PLUS,SWAP,XDO
TRIAD2 FDB CR,I
FDB LIST,QTERM,ZBRAN
- FDB TRIAD3-*
+ FDB TRIAD3-*-NATWID
FDB LEAVE
TRIAD3 FDB XLOOP
- FDB TRIAD2-*
+ FDB TRIAD2-*-NATWID
FDB CR,LIT8
FCB $0F
FDB MESS,CR
* ======>> 222 <<
* ( --- )
* Alphabetically list the definitions in the current vocabulary.
+* Expects to output to printer, not TRS80 Color Computer screen.
FCB $85
FCC 'VLIS' ; 'VLIST'
FCB $D4
VLIST1 FDB OUT,AT,COLUMS,AT,LIT8
FCB 32
FDB SUB,GREAT,ZBRAN
- FDB VLIST2-*
+ FDB VLIST2-*-NATWID
FDB CR,ZERO,OUT,STORE
VLIST2 FDB DUP,IDDOT,SPACE,SPACE,PFA,LFA,AT
FDB DUP,ZEQU,QTERM,OR,ZBRAN
- FDB VLIST1-*
+ FDB VLIST1-*-NATWID
FDB DROP
FDB SEMIS
*
+* Need some utility stuff that isn't in the fig FORTH:
+* ( c --- )
+* Emit dot if c is less than blank, else emit c
+ FCB $85
+ FCC 'BEMI' ; 'BEMIT'
+ FCB $D4 ; 'T'
+ FDB VLIST-8
+BEMIT FDB DOCOL
+ FDB DUP,BL,LESS,ZBRAN
+ FDB BEMITO-*-NATWID
+ FDB DROP,LIT8
+ FCB $2e ; '.'
+BEMITO FDB EMIT
+ FDB SEMIS
+*
+* ( n width --- )
+* Output n in hexadecimal field width.
+ FCB $83
+ FCC 'X.' ; 'X.R'
+ FCB $D2 ; 'R'
+ FDB BEMIT-8
+XDOTR FDB DOCOL
+ FDB BASE,AT,TOR,HEX,DOTR,FROMR,BASE,STORE
+ FDB SEMIS
+*
+* ( adr --- )
+* Dump a line of 4 bytes in memory, in hex and as characters.
+ FCB $85
+ FCC 'BLIN' ; 'BLINE'
+ FCB $C5 ; 'E'
+ FDB XDOTR-6
+BLINE FDB DOCOL
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,OVER,XDO
+BLINEX FDB I,CAT,THREE,XDOTR,XLOOP
+ FDB BLINEX-*-NATWID
+ FDB SPACE,SPACE
+ FDB DUP,LIT8
+ FCB 4
+ FDB PLUS,SWAP,XDO
+BLINEC FDB I,CAT,BEMIT,XLOOP
+ FDB BLINEC-*-NATWID
+ FDB SEMIS
+*
+* ( start end --- )
+* Dump 4 byte lines from start to end.
+ FCB $85
+ FCC 'BDUM' ; 'BDUMP'
+ FCB $D0 ; '5'
+ FDB BLINE-8
+BDUMP FDB DOCOL
+ FDB CR,XDO
+BDUMPL FDB I,LIT8
+ FCB 4
+ FDB XDOTR,LIT8
+ FCB $3A
+ FDB EMIT,SPACE
+ FDB I,BLINE,CR,LIT8
+ FCB 4
+ FDB XPLOOP
+ FDB BDUMPL-*-NATWID
+ FDB SEMIS
+*
* ======>> XX <<
* ( --- )
-* Mostly for place holding.
+* Mostly for place holding (fig Forth).
FCB $84
FCC 'NOO' ; 'NOOP'
FCB $D0
- FDB VLIST-8
-NOOP FDB NEXT a useful no-op
+ FDB BDUMP-8
+NOOP FDB *+NATWID
+ RTS
+* Without the RTS, would misalign the stack.
+* NOOP NEXT a useful no-op
ZZZZ FDB 0,0,0,0,0,0,0,0 end of rom program
PAGE
* This can be moved whereever the bottom of the
* user's dictionary is going to be put.
*
+RBEG EQU *
FCB $C5 immediate
FCC 'FORT' ; 'FORTH'
FCB $C8
FORTH FDB DODOES,DOVOC,$81A0,TASK-7
FDB 0
*
- FCC "(C) Forth Interest Group, 1979"
-
+ FCC "Copyright 1979 Forth Interest Group, David Lion,"
+ FCB $0D
+ FCC "Parts Copyright 2019 Joel Matthew Rees"
+ FCB $0D
+*
FCB $84
FCC 'TAS' ; 'TASK'
FCB $CB
TASK FDB DOCOL,SEMIS
*
REND EQU * ( first empty location in dictionary )
+RSIZE EQU *-RBEG ; So we can look at it.
+ PAGE
-
-
-
-
+ ORG RAMDSK
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " 0) Index page " ; 0
+ FCC " 1) empty line on line 1 of screen 0 block 0 " ; 1
+ FCC " 2) Title and copyright " ; 2
+ FCC " 3) empty line on line 3 of screen 0 block 0 " ; 3
+ FCC " 4) Error messages 1st screen " ; 4
+ FCC " 5) Error messages 2nd screen " ; 5
+ FCC " 6) empty line 3 screen 0 block 1 " ; 6
+ FCC " 7) empty line 4 " ; 7
+ FCC " 8) and line 1 of block 2 " ; 8
+ FCC " 9) line 2 of block 2 screen 0 is pretty much empty too " ; 9
+ FCC " 10) listen to this. Line three of block two is too " ; 10
+ FCC " 11) and so is line 4 4 4 4 4 4 4 4 4 4 b2s0 " ; 11
+ FCC " 12) screen zero block three first line " ; 12
+ FCC " 13) second line fourth block (block three) screen 0 " ; 13
+ FCC " 14) block three screen zero line 3 3 3 3 3 3 3 3 3 " ; 14
+ FCC " 15) fourth line block three screen 0 0 0 0 0 0 0 0 0 0 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " test 10 b0s1 aaaa " ; 0
+ FCC " test 11 b0s1 ee ee ee ee " ; 1
+ FCC " test 12 b0s1 oo oo oo oo oo " ; 2
+ FCC " test 13 b0s1 eh ehe he eh eh " ; 3
+ FCC " ( block 1 ) b1s1 oh ohoo oh oh oh " ; 4
+ FCC " 15 test b1s1 " ; 5
+ FCC " 16 test b1s1 " ; 6
+ FCC " 17 test b1s1 " ; 7
+ FCC " 18 test b2s1 " ; 8
+ FCC " 19 test b2s1 " ; 9
+ FCC " 1A test b2s1 " ; 10
+ FCC " 1B test b2ws1 " ; 11
+ FCC " 1C test b3s1 " ; 12
+ FCC " 1D test b3s1 " ; 13
+ FCC " 1e this completes our second screen b3s1 " ; 14
+ FCC " 1F test b3s1 " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " fig Forth High Level Model Code " ; 1
+ FCC " " ; 2
+ FCC " Copyright 2018 Joel Matthew Rees " ; 3
+ FCC " ( block 2 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 3 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " " ; 0
+ FCC " " ; 1
+ FCC " " ; 2
+ FCC " " ; 3
+ FCC " ( block 4 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " ( ERROR MESSAGES ) " ; 0
+ FCC " DATA STACK UNDERFLOW " ; 1
+ FCC " DICTIONARY FULL " ; 2
+ FCC " ADDRESS RESOLUTION ERROR " ; 3
+ FCC " HIDES DEFINITION IN " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " " ; 15
+* "0 1 2 3 4 5 6 " ;
+* "0123456789012345678901234567890123456789012345678901234567890123" ;
+ FCC " more test data 2 3 4 5 6 " ; 0
+ FCC "0123456789012345678901234567890123456789012345678901234567890123" ; 1
+ FCC "Test data for the RAM disc emulator buffers. " ; 2
+ FCC " " ; 3
+ FCC " ( block 6 ) " ; 4
+ FCC " " ; 5
+ FCC " " ; 6
+ FCC " " ; 7
+ FCC " " ; 8
+ FCC " " ; 9
+ FCC " " ; 10
+ FCC " " ; 11
+ FCC " " ; 12
+ FCC " " ; 13
+ FCC " " ; 14
+ FCC " end" ; 15
+RAMDND EQU *
PAGE
OSDN Git Service
