* 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 $6809,0000 cpu & revision
FDB 0 topmost word in FORTH vocabulary
-BACKSP FDB $7F backspace character for editing
+* BACKSP FDB $7F backspace character for editing
+BACKSP FDB $08 backspace character for editing
UPINIT FDB UORIG initial user area
* UPINIT FDB UORIG initial user area
SINIT FDB ISP ; initial top of data stack
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
+
+
+*
* =
* = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = = =
*
FCB $83
FCC 'LI' ; 'LIT' : NOTE: this is different from LITERAL
- FCB $D4
+ 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.
FDB ZBRAN-10
XLOOP FDB *+NATWID
LDD #1 ; Borrowing from BIF-6809.
-XLOOPA ADDD 2,S ; Dodge the return address.
- STD 2,S
- SUBD 4,S
+XLOOPA ADDD NATWID,S ; Dodge the return address.
+ STD NATWID,S
+ SUBD 2*NATWID,S
BLT ZBYES ; signed
-XLOOPN LEAY 2,Y
+XLOOPN LEAY NATWID,Y
LDX ,S ; synthetic return
- LEAS 6,S ; Clean up the index and limit.
+ LEAS 3*NATWID,S ; Clean up the index and limit.
JMP ,X
* CLRA ;
* LDB #1 get set to increment counter by 1 (Clears N.)
XPLOOP FDB *+NATWID ; Borrowing from BIF-6809.
LDD ,U++ ; inc val
BPL XLOOPA ; Steal plain loop code for forward count.
- ADDD 2,S ; Dodge the return address
- STD 2,S
- SUBD 4,S
+ ADDD NATWID,S ; Dodge the return address
+ STD NATWID,S
+ SUBD 2*NATWID,S
BGT ZBYES ; signed
BRA XLOOPN ; This path is less time-sensitive.
*
FCB $D4
FDB I-4
DIGIT FDB *+NATWID NOTE: legal input range is 0-9, A-Z
- LDD 2,U ; Check the whole thing.
+ LDD NATWID,U ; Check the whole thing.
SUBD #$30 ; ascii zero
BMI DIGIT2 IF LESS THAN '0', ILLEGAL
CMPD #$A
SUBD #7 translate 'A' thru 'F'
DIGIT0 CMPD ,U ; Check the base.
BPL DIGIT2 if not less than the base
- STD 2,U ; Store converted digit. (High byte known zero.)
+ STD NATWID,U ; Store converted digit. (High byte known zero.)
LDD #1 ; set valid flag
DIGIT1 STD ,U ; store the flag
RTS NEXT
DIGIT2 LDD #0 ; set not valid flag
- LEAU 2,U ; pop base
+ LEAU NATWID,U ; pop base
BRA DIGIT1
* TFR S,X ; TSX :
* LDA 3,X
FIMMED EQU $40 ; Immediate word flag.
FSMUDG EQU $20 ; Smudged => definition not ready.
CTMASK EQU ($FF&(^($80|FIMMED))) ; For unmasking the length byte.
+* Note that the SMUDGE bit is not masked out.
*
-* But we really want more:
+* But we really want more (Thinking for a new model, need one more byte):
* FCOMPI EQU $10 ; Compile-time-only.
* FASSEM EQU $08 ; Assembly-language code only.
* F4THLV EQU $04 ; Must not be called from assembly language code.
* name is a pointer to a high-bit bracket string with length head.
* vocptr is a pointer to the NFA of the tail-end (LATEST) definition
* in the vocabulary to be searched.
-* HIDDEN (smudged) definitions are lexically less than their name strings.
+* Hidden (SMUDGEd) definitions are lexically not equal to their name strings.
FCB $86
FCC '(FIND' ; '(FIND)'
FCB $A9
PFIND FDB *+NATWID
PSHS Y ; Have to track two pointers.
* Use the stack and registers instead of temp area N.
-PA0 EQU 2 ; pointer to the length byte of name being searched against
+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 2,U ; Return only false flag.
+ 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 4,X
- STX 2,U
+FOUND LEAX 2*NATWID,X
+* LBSR DBGREG
+ STX NATWID,U
TFR A,B
CLRA
STD ,U
- LDB #1
+* LBSR DBGREG
+ LDB #1
PSHU A,B
+* LBSR DBGREG
+* DEC <TRACEM
PULS Y,PC
*
+* 6800 model:
* NOP ; Probably leftovers from a debugging session.
* NOP
* PD EQU N ptr to dict word being checked
FDB PFIND-9
ENCLOS FDB *+NATWID
LDA 1,U ; Delimiter character to match against in A.
- LDX 2,U ; Buffer to scan in.
+ LDX NATWID,U ; Buffer to scan in.
CLRB ; Initialize offset. (Buffer < 256 wide!)
* Scan to a non-delimiter or a NUL
ENCDEL TST B,X ; NUL ?
* 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
+ PSHS Y ;
+* INC <TRACEM
+* LBSR DBGREG
+ LDX 1*NATWID,U
+ LDY 2*NATWID,U
+ BRA CMOVLE ;
CMOVLP
- LDA ,Y+ ; #2~6
- STA ,X+ ; #2~6
+* LBSR DBGREG
+ LDA ,Y+
+ STA ,X+
+* LBSR DBGREG
CMOVLE
- SUBB #1 ; #2~2
- BCC CMOVLP ; #2~3
- DEC ,S ; #2=6
- BPL CMOVLP ; #2~3
- PULS A,Y,PC ; #2~10
+ 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
+* DEC <TRACEM
+* 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
* PULS A,Y,PC ; #2~10
* Yet another way ; takes ( 37+29*count cycles )
* PSHS Y ; #2~7
-* LDX 2,U ; #2~6
-* LDY 4,U ; #3~7
+* LDX NATWID,U ; #2~6
+* LDY NATWID,U ; #3~7
* BRA CMOVLE ; #2~3
* CMOVLP
* LDA ,Y+ ; #2~6
* SUBD #1 ; #3~4
* STD ,U ; #2~5
* BPL CMOVLP ; #2~3
-* LEAU 6,U ; #2~5
+* LEAU 3*NATWID,U ; #2~5
* PULS Y,PC ; #2~9
* Yet another way ; takes ( 44+24*odd+33*count/2 cycles )
* PSHS Y ; #2~7
-* LDX 2,U ; #2~6
-* LDY 4,U ; #3~7
+* LDX NATWID,U ; #2~6
+* LDY 2*NATWID,U ; #3~7
* LDD ,U ; #2~5
* BITB #1 ; #2~2
* BEQ CMOVLE ; #2~3
* SUBD #2 ; #3~4
* STD ,U ; #2~5
* BPL CMOVLP ; #2~3
-* LEAU 6,U ; #2~5
+* LEAU 3*NATWID,U ; #2~5
* PULS Y,PC ; #2~9
* From the 6800 model:
* CMOVE FDB *+2 takes ( 43+47*count cycles ) on 6800
FCB $AA
FDB CMOVE-8
USTAR FDB *+NATWID
- LEAU -4,U
- LDA 5,U ; least
- LDB 7,U
+ LEAU -2*NATWID,U
+ LDA 2*NATWID+1,U ; least
+ LDB 3*NATWID+1,U
MUL
- STD 2,U
- LDA 4,U ; most
- LDB 6,U
+ STD NATWID,U
+ LDA 2*NATWID,U ; most
+ LDB 3*NATWID,U
MUL
STD ,U
- LDD 5,U ; first inner (u2 lo, u1 hi)
+ LDD 2*NATWID+1,U ; first inner (u2 lo, u1 hi)
MUL
ADDD 1,U
BCC USTAR3
INC ,U
USTAR3 STD 1,U
- LDA 4,U ; second inner (u2 hi)
- LDB 7,U ; (u1 lo)
+ LDA 2*NATWID,U ; second inner (u2 hi)
+ LDB 3*NATWID,U ; (u1 lo)
MUL
ADDD 1,U
BCC USTAR4
INC ,U
USTAR4 STD 1,U
- PULS D,X
+ PULU D,X
STD ,U
- STX 2,U
+ STX NATWID,U
RTS
+*
+* from 6800 model:
* BSR USTARS
* LEAS 1,S ;
* LEAS 1,S ;
* as unsigned integers.
*
* The smaller the divisor, the more likely dropping the high word
-* of the quotient loses significant bits.
+* of the quotient loses significant bits. See M/MOD .
*
FCB $82
FCC 'U' ; 'U/'
USLASH FDB *+NATWID
LDA #17 ; bit ct
PSHS A
- LDD 2,U ; dividend
+ LDD NATWID,U ; dividend
USLDIV CMPD ,U ; divisor
BHS USLSUB
ANDCC #~1 ; carry clear
BRA USLBIT
USLSUB SUBD ,U
ORCC #1 ; quotient, (carry set)
-USLBIT ROL 5,U ; save it
- ROL 4,U
+USLBIT ROL 2*NATWID+1,U ; save it
+ ROL 2*NATWID,U
DEC ,S ; more bits?
BEQ USLR
ROLB ; remainder
ROLA
BCC USLDIV
BRA USLSUB
-USLR LEAU 2,U
- LDX 2,U
- STD 2,U
+USLR LEAU NATWID,U
+ LDX NATWID,U
+ STD NATWID,U
STX ,U
PULS A,PC ; Avoiding a LEAS 1,S by discarding A.
+*
+* from 6800 model:
* LDA #17
* PSHS A ;
* TFR S,X ; TSX :
FCB $D3
FDB RPSTOR-6
SEMIS FDB *+NATWID
- PULS D,X
- TFR D,PC ; and discard X.
+ PULS D,Y ; return address in D, and saved IP in Y.
+ TFR D,PC ; Synthetic return.
+*
+* Form 6800 model:
* LDX RP
* LEAX 1,X ;
* LEAX 1,X ;
FCB $C5
FDB SEMIS-5
LEAVE FDB *+NATWID
- LDD 2,S ; Dodge the return address.
- STD 4,S
+ LDD NATWID,S ; Dodge the return address.
+ STD 2*NATWID,S
RTS
* LDX RP
* LDA 2,X
FCB $AB
FDB PLUS-4
DPLUS FDB *+NATWID
- LDD 6,U
- ADDD 2,U
- STD 6,U
- LDD 4,U
+ LDD 3*NATWID,U
+ ADDD NATWID,U
+ STD 3*NATWID,U
+ LDD 2*NATWID,U
ADCB 1,U
ADCA ,U
- LEAU 4,U
+ LEAU 2*NATWID,U
STD ,U
RTS
* TFR S,X ; TSX :
SUBD ,U ; #2~5
STD ,U ; #2~5
RTS ; #1~5 = #8~18
+*
+* from 6800 model code:
* TFR S,X ; TSX :
* NEG 1,X
* BCC MINUS2
FDB MINUS-8
DMINUS FDB *+NATWID
LDD #0 ; #3~3
- SUBD 2,U ; #2~7
- STD 2,U ; #2~7
+ SUBD NATWID,U ; #2~7
+ STD NATWID,U ; #2~7
LDD #0 ; #3~3
SBCB 1,U ; #2~5
SBCA ,U ; #2~4
FCB $D2
FDB DMINUS-9
OVER FDB *+NATWID
- LDD 2,U
+ LDD NATWID,U
PSHU D
RTS
* TFR S,X ; TSX :
FCB $D0
FDB OVER-7
DROP FDB *+NATWID
- LEAU 2,U
+ LEAU NATWID,U
RTS
* LEAS 1,S ;
* LEAS 1,S ;
FCB $A1
FDB CAT-5
STORE FDB *+NATWID
- LDD 2,U
+ LDD NATWID,U
STD [,U]
- LEAU 4,U
+ LEAU 2*NATWID,U
RTS
* TFR S,X ; TSX :
* LDX 0,X get address
CSTORE FDB *+NATWID
LDB 3,U
STB [,U]
- LEAU 4,U
+ LEAU 2*NATWID,U
RTS
* TFR S,X ; TSX :
* LDX 0,X get address
* CREATE a header,
* set state to compile,
* and compile the call to the trailing native CPU machine code DOCOL.
-* *** This would not be hard to flatten to native code. Maybe later.
+*
+* This would not be hard to flatten to native code.
+* But that's not the purpose of a model.
FCB $C1 : immediate
FCB $BA
FDB CSTORE-5
* called it into the IP.
DOCOL LDD ,S ; Save the return address.
STY ,S ; Nest the old IP.
- LEAX 2,X ; W still in X, bump to parameter field.
- TFR X,Y ; Load the new IP.
+ LEAY NATWID,X ; W still in X, bump to parameters, load as new IP.
TFR D,PC ; synthetic return to interpret.
* DOCOL LDX RP make room in the stack
* Characteristic of a CONSTANT.
* A CONSTANT simply loads its value from its parameter field
* and pushes it on the stack.
-DOCON LDD 2,X ; Get the first natural width word of the parameter field.
+DOCON LDD NATWID,X ; Get the first natural width word of the parameter field.
PSHU D
RTS
* DOCON LDX W
* LDB 3,X A & B now contain the constant
* JMP PUSHBA
*
+* Not in model, needed for abstraction:
+* ( --- NATWID )
+* The byte width of objects on stack.
+ FCB $86
+ FCC 'NATWI' ; 'NATWID'
+ FCB $C4
+ FDB CON-11
+NATWC FDB DOCON
+NATWCV FDB NATWID
+*
+* Not in model, needed for abstraction:
+* Note that this is not defined as an INCREMENTER!
+* Coded to increment by the exact constant returned by NATWID
+* ( n --- n+NATWID )
+ FCB $84
+ FCC 'NAT' ; 'NAT+'
+ FCB $AB
+ FDB NATWC-9
+NATP FDB *+NATWID
+ LDD ,U
+ ADDD NATWCV,PCR ; Looking ahead, does not have to be PCRelative.
+ STD ,U
+ RTS
+* How this might have been done for 6800 model:
+* CLRA ; We know the natural width is less than 255, LOL.
+* LDAB NATWCV+1
+* TSX
+* ADDB 1,X
+* ADCA ,X
+* JMP STABX
+*
* ======>> 50 <<
* ( init --- )
* { init VARIABLE name } typical input
-* CREATE a header and compile the initial value, init, using CONSTANT,
-* overwrite the characteristic to point to DOVAR.
+* Use CONSTANT to CREATE a header and compile the initial value, init,
+* then overwrite the characteristic to point to DOVAR.
FCB $88
FCC 'VARIABL' ; 'VARIABLE'
FCB $C5
- FDB CON-11
+ FDB NATP-7
VAR FDB DOCOL,CON,PSCODE
* ( --- vadr )
* Characteristic of a VARIABLE.
* and immediately ALLOTting the remaining needed space.
* VARIABLES are global to all users,
* and thus should be hidden in resource monitors, but aren't.
-DOVAR LEAX 2,X ; Point to the first natural width word of the parameters.
+DOVAR LEAX NATWID,X ; Point to the first natural width word of the parameters.
PSHU X
RTS
* DOVAR LDA W
* A USER variable's parameter field contains its offset in the per-user table.
DOUSER TFR DP,A ; Make a pointer to the direct page.
CLRB
- ADDD 2,X ; Add the offset to the per-user variable.
+* See Alternative -- alternatives start from this point.
+ ADDD NATWID,X ; Add it to the offset to the per-user variable.
PSHU D
+ TFR D,X ; Cache the pointer in X for the caller.
RTS
* Hey, the per-user table could actually be larger than 256 bytes!
* But we knew that. It's just not as esthetic to calculate it this way.
-*
+* Alternative A:
+* LDX NATWID,X ; Keep the offset
+* EXG D,X ; Prepare for EA
+* LEAX D,X
+* PSHU X
+* RTS
+* Alternative B:
+* PSHS Y ; Get Y free for calculations.
+* TFR D,Y ; Y points to the UP base
+* LDD NATWID,X ; Get the offset
+* LEAX D,Y ; Leave the pointer cached in X.
+* PSHU X
+* PULS Y,PC
+*
+* From the 6800 model:
* DOUSER LDX W get offset into user's table
* LDA 2,X
* LDB 3,X
FCB $B1 1
FDB ZERO-4
ONE FDB DOCON
- FDB 1
+ONEV FDB 1
*
* ======>> 54 <<
* ( --- 2 )
FCB $B2 2
FDB ONE-4
TWO FDB DOCON
- FDB 2
+TWOV FDB 2
*
* ======>> 55 <<
* ( --- 3 )
FDB FIRST-8
LIMIT FDB DOCON
FDB BUFBAS+BUFSZ
+* In 6800 model, was
* FDB MEMEND
*
* ======>> 59 <<
* ( --- sectorsize )
+* The size, in bytes, of a buffer control region.
+ FCB $85
+ FCC 'B/CTL' ; '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:
* FDB 128
*
* ======>> 60 <<
FDB BBUF-8
BSCR FDB DOCON
FDB SCRSZ/SECTSZ
+* Hardcoded in 6800 model as:
* FDB 8
* blocks/screen = 1024 / "B/BUF" = 8, if sectors are 128 bytes.
*
* ( --- vadr ) ******* Need to check what this is!
* Used in maintaining vocabularies.
* I think it points to the "parent" vocabulary, but I'm not sure.
+* Or maybe this is the CONTEXT vocabulary. I'll have to come back here. *****
FCB $88
FCC 'VOC-LIN' ; 'VOC-LINK'
FCB $CB
* ( --- vadr )
* Disk block being interpreted.
* Zero refers to terminal.
-* ******** Should be made a 32 bit variable! ********
+* ******** Should be made a 32 bit user variable! ********
* But the base system needs to have full 32 bit support, div and mul, etc.
+* before we can do that.
FCB $83
FCC 'BL' ; 'BLK'
FCB $CB
FDB XCOLUM-UORIG
*
* ######>> screen 38 <<
-** Could make an incrementer compiling word:
+**
+** An INCREMENTER probably should not be defined without a defined CONSTANT?
+**
+** Make an INCREMENTER compiling word (not in model):
** ( n --- )
** { n INCREMENTER name } typical input
** CREATE a header and compile the increment constant,
** then overwrite the header with a call to DOINC.
-* FCB $84
-* FCC 'INCREMENTE' ; INCREMENTER'
+* FCB $8B
+* FCC 'INCREMENTE' ; 'INCREMENTER'
* FCB $D2
-* FDB COLUMS-9
+* FDB COLUMS-10
* INCR FDB DOCOL,CON,PSCODE
** ( n --- ninc )
** Characteristic of an INCREMENTER.
+** This is too naive:
* DOINC LDD ,U
-* ADDD 2,X ; Add the increment.
+* ADDD NATWID,X ; Add the increment.
* STD ,U
* RTS
+* Compiling word should check that it is compiling a CONSTANT.
*
* ======>> 83 <<
* ( n --- n+1 )
FCC '1' ; '1+'
FCB $AB
FDB COLUMS-10
-ONEP FDB *+NATWID
- LDD ,U
- ADDD #1
- STD ,U
- RTS
-* ONEP FDB DOCOL,ONE,PLUS
-* FDB SEMIS
+* Using the model keeps things semantically connected for other processors:
+ONEP FDB DOCOL,ONE,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD ONEV,PCR
+* STD ,U
+* RTS
+* Naive alternative:
+* ONEP FDB DOINC
+* FDB 1
+* Naive alternative:
+* ONEP FDB *+NATWID
+* LDD ,U
+* ADDD #1 ; It's hard to imagine 1+ being other than 1.
+* STD ,U
+* RTS
*
* ======>> 84 <<
* ( n --- n+2 )
FCC '2' ; '2+'
FCB $AB
FDB ONEP-5
-TWOP FDB *+NATWID
- LDD ,U
- ADDD #2
- STD ,U
- RTS
-* TWOP FDB DOCOL,TWO,PLUS
-* FDB SEMIS
+* Using the model keeps things semantically connected for other processors:
+TWOP FDB DOCOL,TWO,PLUS
+ FDB SEMIS
+** Greedy alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD TWOV,PCR ; See NAT+ (NATP)
+* STD ,U
+* RTS
+* Naive alternative:
+* TWOP FDB DOINC
+* FDB 2
+* Naive alternative:
+* TWOP FDB *+NATWID
+* LDD ,U
+* ADDD #2 ; See NAT+ (NATP)
+* STD ,U
+* RTS
*
* ======>> 85 <<
+* ( --- adr )
+* Get the DICTPT allocation, like a USER constant.
+* Should check the stack and heap for collision.
FCB $84
FCC 'HER' ; 'HERE'
FCB $C5
FDB SEMIS
*
* ======>> 86 <<
+* ( n --- )
+* Increase/decrease heap (add n to DP),
+* Should ERROR check stack/heap.
FCB $85
FCC 'ALLO' ; 'ALLOT'
FCB $D4
FDB SEMIS
*
* ======>> 87 <<
+* ( n --- )
+* Store word n at DP++,
+* Should ERROR check stack/heap.
FCB $81 ; , (COMMA)
FCB $AC
FDB ALLOT-8
-COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+COMMA FDB DOCOL,HERE,STORE,NATWC,ALLOT
FDB SEMIS
+* COMMA FDB DOCOL,HERE,STORE,TWO,ALLOT
+* FDB SEMIS
*
* ======>> 88 <<
+* ( b --- )
+* Store byte b at DP+,
+* Should ERROR check stack/heap.
FCB $82
FCC 'C' ; 'C,'
FCB $AC
FCB $AD
FDB CCOMM-5
SUB FDB *+NATWID
- LDD 2,U ; #2~6
+ LDD NATWID,U ; #2~6
SUBD ,U++ ; #2~9
STD ,U ; #2~5
RTS ; #1~5 = #7~25
* FDB SEMIS ; Costs 6 bytes and lots of cycles.
*
* ======>> 90 <<
+* ( n1 n2 --- n1==n2 )
+* Return flag true if n1 and n2 are equal, otherwise false.
FCB $81 =
FCB $BD
FDB SUB-4
FDB SEMIS
*
* ======>> 91 <<
+* ( n1 n2 --- n1<n2 )
+* Return flag true if n1 is less than n2, otherwise false.
FCB $81 <
FCB $BC
FDB EQUAL-4
LESS FDB *+NATWID
- PULS A ;
- PULS B ;
- TFR S,X ; TSX :
- CMPA 0,X
- LEAS 1,S ;
- BGT LESST
- BNE LESSF
- CMPB 1,X
- BHI LESST
-LESSF CLRB ;
- BRA LESSX
-LESST LDB #1
-LESSX CLRA ;
- LEAS 1,S ;
- JMP PUSHBA
+ LDD NATWID,U
+ SUBD ,U++
+ BGE FALSE
+TRUE LDD #1
+ STD ,U
+ RTS
+FALSE LDD #0
+ STD ,U
+ RTS
+* PULS A ;
+* PULS B ;
+* TFR S,X ; TSX :
+* CMPA 0,X
+* LEAS 1,S ;
+* BGT LESST
+* BNE LESSF
+* CMPB 1,X ; Why not sub, sbc, bge?
+* BHI LESST
+* LESSF CLRB ;
+* BRA LESSX
+* LESST LDB #1
+* LESSX CLRA ;
+* LEAS 1,S ;
+* JMP PUSHBA
*
* ======>> 92 <<
+* ( n1 n2 --- n1>n2 )
+* Return flag true if n1 is greater than n2, false otherwise.
FCB $81 >
FCB $BE
FDB LESS-4
FDB SEMIS
*
* ======>> 93 <<
+* ( n1 n2 n3 --- n2 n3 n1 )
+* Rotate the top three words on stack,
+* bringing the third word to the top.
FCB $83
FCC 'RO' ; 'ROT'
FCB $D4
FDB GREAT-4
-ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
- FDB SEMIS
+ROT FDB *+NATWID
+ PSHS Y
+ PULU D,X,Y
+ PSHU D,X
+ PSHU Y
+ PULS Y,PC
+* ROT FDB DOCOL,TOR,SWAP,FROMR,SWAP
+* FDB SEMIS
*
* ======>> 94 <<
+* ( --- )
+* EMIT a SPACE.
FCB $85
FCC 'SPAC' ; 'SPACE'
FCB $C5
FDB SEMIS
*
* ======>> 95 <<
+* ( n0 n1 --- min(n0,n1) )
+* Leave the minimum of the top two integers.
+* Being too greedy here, but, whatever.
FCB $83
FCC 'MI' ; 'MIN'
FCB $CE
FDB SPACE-8
-MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
- FDB MIN2-*
- FDB SWAP
-MIN2 FDB DROP
- FDB SEMIS
+MIN FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MINX
+ STD ,U
+MINX RTS
+* MIN FDB DOCOL,OVER,OVER,GREAT,ZBRAN
+* FDB MIN2-*-NATWID
+* FDB SWAP
+* MIN2 FDB DROP
+* FDB SEMIS
*
* ======>> 96 <<
+* ( n0 n1 --- max(n0,n1) )
+* Leave the maximum of the top two integers.
+* Really should leave this as in the model.
FCB $83
FCC 'MA' ; 'MAX'
FCB $D8
FDB MIN-6
-MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
- FDB MAX2-*
- FDB SWAP
-MAX2 FDB DROP
- FDB SEMIS
+MAX FDB *+NATWID
+ PULU D
+ CMPD ,U
+ BLE MAXX
+ STD ,U
+MAXX RTS
+* MAX FDB DOCOL,OVER,OVER,LESS,ZBRAN
+* FDB MAX2-*-NATWID
+* FDB SWAP
+* MAX2 FDB DROP
+* FDB SEMIS
*
* ======>> 97 <<
+* ( 0 --- 0 )
+* ( n --- n n )
+* DUP if non-zero.
FCB $84
FCC '-DU' ; '-DUP'
FCB $D0
FDB MAX-6
-DDUP FDB DOCOL,DUP,ZBRAN
- FDB DDUP2-*
- FDB DUP
-DDUP2 FDB SEMIS
+DDUP FDB *+NATWID
+ LDD ,U
+ BEQ DDUPX
+ PSHU D
+DDUPX RTS
+* DDUP FDB DOCOL,DUP,ZBRAN
+* FDB DDUP2-*-NATWID
+* FDB DUP
+* DDUP2 FDB SEMIS
*
* ######>> screen 39 <<
+* ======>> 98.1 <<
+* Supplemental:
+* ( n<0 --- -1 )
+* ( n>=~ --- 1 )
+* Change top integer to its sign.
+ FCB $86
+ FCC 'SIGNU' ; 'SIGNUM'
+ FCB $CD
+ FDB DDUP-7
+SIGNUM FDB *+NATWID
+SIGNUE LDB #1
+ LDA ,U
+ BPL SIGNUP
+ NEGB
+SIGNUP SEX ; Couldn't they have called SignEXtend EXT instead?
+ STD ,U ; Am I too much of a prude?
+ RTS
+* 6800 model version should be something like this:
+* LDB #1
+* CLRA
+* TSX
+* TST ,X
+* BPL SIGNUP
+* NEGB
+* COMA
+* SIGNUP JMP STABX
+*
* ======>> 98 <<
+* ( adr1 direction --- adr2 )
+* TRAVERSE the symbol name.
+* If direction is 1, find the end.
+* If direction is -1, find the beginning.
FCB $88
FCC 'TRAVERS' ; 'TRAVERSE'
FCB $C5
- FDB DDUP-7
-TRAV FDB DOCOL,SWAP
-TRAV2 FDB OVER,PLUS,LIT8
- FCB $7F
- FDB OVER,CAT,LESS,ZBRAN
- FDB TRAV2-*
- FDB SWAP,DROP
- FDB SEMIS
+ FDB SIGNUM-9
+TRAV FDB *+NATWID
+ BSR SIGNUE ; Convert negative to -, zero or positive to 1.
+ LDD ,U++ ; Still in D, but we have to pop it anyway.
+ LDX ,U ; If D is 1 or -1, so is B.
+ LDA #$7F
+TRAVLP LEAX B,X ; Don't look at the one we start at.
+ CMPA ,X ; Not sure why we aren't just doing LDA ,X ; BPL.
+ BCC TRAVLP
+TRAVDN STX ,U
+ RTS
+* Doing this in 6809 just because it can be done may be getting too greedy.
+* TRAV FDB DOCOL,SWAP
+* TRAV2 FDB OVER,PLUS,LIT8
+* FCB $7F
+* FDB OVER,CAT,LESS,ZBRAN
+* FDB TRAV2-*-NATWID
+* FDB SWAP,DROP
+* FDB SEMIS
*
* ======>> 99 <<
+* ( --- symptr )
+* Fetch CURRENT as a per-USER constant.
FCB $86
FCC 'LATES' ; 'LATEST'
FCB $D4
FDB TRAV-11
LATEST FDB DOCOL,CURENT,AT,AT
FDB SEMIS
+* LATEST FDB *+NATWID
+* Getting too greedy:
+* Version 1:
+* TFR DP,A
+* CLRB
+* TFR D,X
+* LDD CURENT+NATWID,PCR
+* LDX [D,X]
+* PSHU X ; Leave the address in X.
+* RTS
+* Version 2:
+* LEAX CURENT,PCR
+* JSR [,X]
+* PULU X
+* LDX [,X]
+* PSHU X
+* RTS
+* Too greedy, too many smantic holes to fall through.
+* If the address at the CFA is made relative,
+* this is part of the code that would be affected
+* if it is in native CPU code.
*
* ======>> 100 <<
+* Wanted to do these as INCREMENTERs,
+* but I need to stick with the model as much as possible,
+* (mostly, LOL) adding code only to make the model more clear.
+* ( pfa --- lfa )
+* Convert PFA to LFA, unchecked. (Bump back from contents to allocation link.)
FCB $83
FCC 'LF' ; 'LFA'
FCB $C1
FDB LATEST-9
LFA FDB DOCOL,LIT8
- FCB 4
+* FCB 4
+ FCB 2*NATWID
FDB SUB
FDB SEMIS
*
* ======>> 101 <<
+* ( pfa --- cfa )
+* Convert PFA to CFA, unchecked. (Bump back from contents to characterist code link.)
FCB $83
FCC 'CF' ; 'CFA'
FCB $C1
FDB LFA-6
-CFA FDB DOCOL,TWO,SUB
+* CFA FDB DOCOL,TWO,SUB
+CFA FDB DOCOL,NATWC,SUB
FDB SEMIS
*
* ======>> 102 <<
+* ( pfa --- nfa )
+* Convert PFA to NFA. (Bump back from contents to beginning of symbol name.)
FCB $83
FCC 'NF' ; 'NFA'
FCB $C1
FDB CFA-6
NFA FDB DOCOL,LIT8
- FCB 5
+* FCB 5
+ FCB NATWID*2+1
FDB SUB,ONE,MINUS,TRAV
FDB SEMIS
*
* ======>> 103 <<
+* ( nfa --- pfa )
+* Convert NFA to PFA. (Bump up from beginning of symbol name to contents.)
FCB $83
FCC 'PF' ; 'PFA'
FCB $C1
FDB NFA-6
PFA FDB DOCOL,ONE,TRAV,LIT8
- FCB 5
+* FCB 5
+ FCB NATWID*2+1
FDB PLUS
FDB SEMIS
*
* ######>> screen 40 <<
* ======>> 104 <<
+* ( --- )
+* Save the parameter stack pointer in CSP for compiler checks.
FCB $84
FCC '!CS' ; '!CSP'
FCB $D0
FDB SEMIS
*
* ======>> 105 <<
+* ( 0 n --- ) ( *** )
+* ( true n --- IN BLK ) ( anything *** nothing )
+* If flag is false, do nothing.
+* If flag is true, issue error MESSAGE and QUIT or ABORT, via ERROR.
+* Leaves cursor position (IN)
+* and currently loading block number (BLK) on stack, for analysis.
+*
+* This one is too important to be high-level Forth codes.
+* When we have an error, we want to disturb as little as possible.
+* But fixing that cascades through ERROR and MESSAGE
+* into the disk block system.
+* And we aren't ready for that yet.
FCB $86
FCC '?ERRO' ; '?ERROR'
FCB $D2
FDB SCSP-7
+* QERR FDB *+NATWID
+* LDD NATWID,U
+* BNE QERROR
+* LEAU 2*NATWID,U
+* 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
*
* ======>> 106 <<
+* STATE is compiling:
+* ( --- ) ( *** )
+* STATE is compiling:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not compiling.
FCB $85
FCC '?COM' ; '?COMP'
FCB $D0
FDB SEMIS
*
* ======>> 107 <<
+* STATE is executing:
+* ( --- ) ( *** )
+* STATE is executing:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not executing.
FCB $85
FCC '?EXE' ; '?EXEC'
FCB $C3
FDB SEMIS
*
* ======>> 108 <<
+* ( n1 n1 --- ) ( *** )
+* ( n1 n2 --- IN BLK ) ( anything *** nothing )
+* ERROR if top two are unequal.
+* MESSAGE says compiled conditionals do not match.
FCB $86
FCC '?PAIR' ; '?PAIRS'
FCB $D3
FDB SEMIS
*
* ======>> 109 <<
+* CSP and parameter stack are balanced (equal):
+* ( --- ) ( *** )
+* CSP and parameter stack are not balanced (unequal):
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if return/control stack is not at same level as last !CSP.
+* Usually indicates that a definition has been left incomplete.
FCB $84
FCC '?CS' ; '?CSP'
FCB $D0
FDB SEMIS
*
* ======>> 110 <<
+* Active BLK input:
+* ( --- ) ( *** )
+* No active BLK input:
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if not loading, i. e., if BLK is zero.
FCB $88
FCC '?LOADIN' ; '?LOADING'
FCB $C7
*
* ######>> screen 41 <<
* ======>> 111 <<
+* ( --- )
+* Compile an in-line literal value from the instruction stream.
FCB $87
FCC 'COMPIL' ; 'COMPILE'
FCB $C5
FDB QLOAD-11
-COMPIL FDB DOCOL,QCOMP,FROMR,TWOP,DUP,TOR,AT,COMMA
+* 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,DUP,NATP,TOR,AT,COMMA
FDB SEMIS
*
* ======>> 112 <<
+* ( --- ) P
+* Clear the compile state bit(s) (shift to interpret).
FCB $C1 [ immediate
FCB $DB
FDB COMPIL-10
FDB SEMIS
*
* ======>> 113 <<
+*
+STCOMP EQU $C0
+* ( --- )
+* Set the compile state bit(s) (shift to compile).
FCB $81 ]
FCB $DD
FDB LBRAK-4
RBRAK FDB DOCOL,LIT8
- FCB $C0
+ FCB STCOMP
FDB STATE,STORE
FDB SEMIS
*
* ======>> 114 <<
+* ( --- )
+* Toggle SMUDGE bit of LATEST definition header,
+* to hide it until defined or reveal it after definition.
FCB $86
FCC 'SMUDG' ; 'SMUDGE'
FCB $C5
FDB RBRAK-4
SMUDGE FDB DOCOL,LATEST,LIT8
- FCB $20
+ FCB FSMUDG
FDB TOGGLE
FDB SEMIS
*
* ======>> 115 <<
+* ( --- )
+* Set the conversion base to sixteen (b00010000).
FCB $83
FCC 'HE' ; 'HEX'
FCB $D8
FDB SMUDGE-9
HEX FDB DOCOL
FDB LIT8
- FCB 16
+ FCB 16 ; decimal sixteen
FDB BASE,STORE
FDB SEMIS
*
* ======>> 116 <<
+* ( --- )
+* Set the conversion base to ten (b00001010).
FCB $87
FCC 'DECIMA' ; 'DECIMAL'
FCB $CC
FDB HEX-6
DEC FDB DOCOL
FDB LIT8
- FCB 10 note: hex "A"
+ FCB 10 ; decimal ten
FDB BASE,STORE
FDB SEMIS
*
* ######>> screen 42 <<
* ======>> 117 <<
+* ( --- ) ( IP *** )
+* Pop the saved IP and use it to
+* compile the latest symbol as a reference to a ;CODE definition;
+* overwrite the code field of the symbol found by LATEST
+* with the address of the low-level characteristic code
+* provided in the defining definition.
+* Look closely at where things return, consider the operation of R> and >R .
+*
+* The machine-level code which follows (;CODE) in the instruction stream
+* is not executed by the defining symbol,
+* but becomes the characteristic of the defined symbol.
+* This is the usual way to generate the characteristics of VARIABLEs,
+* CONSTANTs, COLON definitions, etc., when FORTH compiles itself.
+*
+* Finally, note that, if code shifts from low level back to high
+* (native CPU machine code calling into a list of FORTH codes),
+* the low level code can't just call a high-level definition.
+* Leaf definitions can directly call other leaf definitions,
+* but not non-leafs.
+* It will need an anonymous list, probably embedded in the low-level code,
+* and Y and X will have to be set appropriately before entering the list.
FCB $87
FCC '(;CODE' ; '(;CODE)'
FCB $A9
FDB DEC-10
-PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+* PSCODE FDB DOCOL,FROMR,TWOP,LATEST,PFA,CFA,STORE
+PSCODE FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,CFA,STORE
FDB SEMIS
*
* ======>> 118 <<
+* ( --- ) P
+* ?CSP to see if there are loose ends in the defining definition
+* before shifting to the assembler,
+* compile (;CODE) in the defining definition's instruction stream,
+* shift to interpreting,
+* make the ASSEMBLER vocabulary current,
+* and !CSP to mark the stack
+* in preparation for assembling low-level code.
+* Note that ;CODE, unlike DOES>, is IMMEDIATE,
+* and compiles (;CODE),
+* which will do the actual work of changing
+* the LATEST definition's characteristic when the defining word runs.
+* Assembly is done by the interpreter, rather than the compiler.
+* I could have avoided the anomalous three-byte code fields by
+*
+* Note that the ASSEMBLER is not part of the model (at this time).
+* That means that, until the assembler is ready,
+* if you want to define low-level words,
+* you have to poke (comma) in hand-assembled stuff.
+*
FCB $C5 immediate
FCC ';COD' ; ';CODE'
FCB $C5
*
* ######>> screen 43 <<
* ======>> 119 <<
+* ( --- ) C
+* Make the word currently being defined
+* build a header for DOES> definitions.
+* Actually just compiles a CONSTANT zero
+* which can be overwritten later by DOES>.
+* Since the fig models were established, this technique has been deprecated.
+*
+* Note that <BUILDS is not IMMEDIATE,
+* and therefore executes during a definition's run-time,
+* rather than its compile-time.
+* It is not intended to be used directly,
+* but rather so that one definition word can build another.
+* Also, note that nothing particularly special happens
+* in the defining definition until DOES> executes.
+* The name <BUILDS is intended to be a reminder of what is about to occur.
+*
+* <BUILDS probably should have compiled an ERROR instead of a ZERO CONSTANT.
FCB $87
FCC '<BUILD' ; '<BUILDS'
FCB $D3
FDB SEMIS
*
* ======>> 120 <<
+* ( --- ) ( IP *** ) C
+* Define run-time behavior of definitions compiled/defined
+* by a high-level defining definition --
+* the FORTH equivalent of a compiler-compiler.
+* DOES> assumes that the LATEST symbol table entry
+* has at least one word of parameter field,
+* which <BUILDS provides.
+* Note that DOES> is also not IMMEDIATE.
+*
+* When the defining word containing DOES> executes the DOES> icode,
+* it overwrites the LATEST symbol's CFA with jsr <XDOES,
+* overwrites the first word of that symbol's parameter field with its own IP,
+* and pops the previous IP from the return stack.
+* The icodes which follow DOES> in the stream
+* do not execute at the defining word's run-time.
+*
+* Examining XDOES in the virtual machine shows
+* that the defined word will execute those icodes
+* which follow DOES> at its own run-time.
+*
+* The advantage of this kind of behaviour,
+* which you will also note in ;CODE,
+* is that the defined word can contain
+* both operations and data to be operated on.
+* This is how FORTH data objects define their own behavior.
+*
+* Finally, note that the effective parameter field for DOES> definitions
+* starts two NATWID words after the CFA, instead of just one
+* (four bytes instead of two in a sixteen-bit addressing Forth).
+*
+* VOCABULARYs will use this. See definition of word FORTH.
FCB $85
FCC 'DOES' ; 'DOES>'
FCB $BE
FDB BUILDS-10
-DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+* DOES FDB DOCOL,FROMR,TWOP,LATEST,PFA,STORE
+DOES FDB DOCOL,FROMR ; Y/IP is post-inc, needs no adjustment.
+ FDB LATEST,PFA,STORE
FDB PSCODE
-DODOES LDA IP
- LDB IP+1
- LDX RP make room on return stack
- LEAX -1,X ;
- LEAX -1,X ;
- STX RP
- STA 2,X push return address
- STB 3,X
- LDX W get addr of pointer to run-time code
- LEAX 1,X ;
- LEAX 1,X ;
- STX N stash it in scratch area
- LDX 0,X get new IP
- STX IP
- CLRA ; get address of parameter
- LDB #2
- ADDB N+1
- ADCA N
- PSHS B ; and push it on data stack
- PSHS A ;
- JMP NEXT2
+*
+* ( --- PFA+NATWID ) ( *** IP )
+* Characteristic of a DOES> defined word.
+* The characteristics of DOES> definitions are written in high-level
+* Forth codes rather than native CPU machine level code.
+* The first parameter word points to the high-level characteristic.
+* This routine's job is to push the IP,
+* load the high level characteristic pointer in IP,
+* and leave the address following the characteristic pointer on the stack
+* so the parameter field can be accessed.
+DODOES LDD ,S ; Keep the return address.
+ STY ,S ; Save/nest the current IP on the return stack.
+ LDY NATWID,X ; First parameter is new IP.
+ LEAX 2*NATWID,X ; Address of second parameter.
+ PSHU X
+ TFR D,PC ; Synthetic return.
+*
+* From the 6800 model:
+* DODOES LDA IP
+* LDB IP+1
+* LDX RP make room on return stack
+* LEAX -1,X ;
+* LEAX -1,X ;
+* STX RP
+* STA 2,X push return address
+* STB 3,X
+* LDX W get addr of pointer to run-time code
+* LEAX 1,X ;
+* LEAX 1,X ;
+* STX N stash it in scratch area
+* LDX 0,X get new IP
+* STX IP
+* CLRA ; get address of parameter
+* LDB #2
+* ADDB N+1
+* ADCA N
+* PSHS B ; and push it on data stack
+* PSHS A ;
+* JMP NEXT2
*
* ######>> screen 44 <<
* ======>> 121 <<
+* ( strptr --- strptr+1 count )
+* Convert counted string to string and count.
+* (Fetch the byte at strptr, post-increment.)
FCB $85
FCC 'COUN' ; 'COUNT'
FCB $D4
FDB SEMIS
*
* ======>> 122 <<
+* ( strptr count --- )
+* EMIT count characters at strptr.
FCB $84
FCC 'TYP' ; 'TYPE'
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
*
* ======>> 123 <<
+* ( strptr count1 --- strptr count2 )
+* Supress trailing blanks (subtract count of trailing blanks from strptr).
FCB $89
FCC '-TRAILIN' ; '-TRAILING'
FCB $C7
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 <<
+* ( --- )
+* TYPE counted string out of instruction stream (updating IP).
FCB $84
FCC '(."' ; '(.")'
FCB $A9
FDB DTRAIL-12
-PDOTQ FDB DOCOL,R,TWOP,COUNT,DUP,ONEP
+* PDOTQ FDB DOCOL,R,TWOP,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
*
* ======>> 125 <<
+* ( --- ) P
+* { ." something-to-be-printed " } typical input
+* Use WORD to parse to trailing quote;
+* if compiling, compile XDOTQ and string parsed,
+* otherwise, TYPE string.
FCB $C2 immediate
FCC '.' ; '."'
FCB $A2
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
*
* ######>> screen 45 <<
* ======>> 126 <<== MACHINE DEPENDENT
+* ( --- ) ( *** )
+* ( --- IN BLK ) ( anything *** nothing )
+* ERROR if parameter stack out of bounds.
+*
+* But checking whether the stack is in bounds or not
+* really should not use the stack.
+* And there really should be a ?RSTACK, as well.
FCB $86
FCC '?STAC' ; '?STACK'
FCB $CB
FDB DOTQ-5
QSTACK FDB DOCOL,LIT8
- FCB $12
- FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+* FCB $12
+ FCB SINIT-ORIG
+* But why use that instead of XSPZER (S0)?
+* Multi-user or multi-tasking would not want that.
+* CMPU <XSPZER
+* FDB PORIG,AT,TWO,SUB,SPAT,LESS,ONE
+ FDB PORIG,AT,SPAT,LESS,ONE ; Not post-decrement push.
FDB QERR
* prints 'empty stack'
*
* Here, we compare with a value at least 128
* higher than dict. ptr. (DICTPT)
FDB HERE,LIT8
- FCB $80
+ FCB $80 ; This is a rough check anyway, leave it as is.
FDB PLUS,LESS,ZBRAN
- FDB QSTAC3-*
- FDB TWO
+ FDB QSTAC3-*-NATWID
+ FDB TWO ; NOT the NATWID constant!
FDB QERR
* prints 'full stack'
*
* FDB QSTACK-9
*QFREE FDB DOCOL,SPAT,HERE,LIT8
* FCB $80
-* FDB PLUS,LESS,TWO,QERR,SEMIS
+* FDB PLUS,LESS,TWO,QERR,SEMIS ; This TWO is not NATWID!
*
* ######>> screen 46 <<
* ======>> 128 <<
+* ( buffer n --- )
+* ***** Check that this is how it works here:
+* Get up to n-1 characters from the keyboard,
+* storing at buffer and echoing, with backspace editing,
+* quitting when a CR is read.
+* Terminate it with a NUL.
FCB $86
FCC 'EXPEC' ; 'EXPECT'
FCB $D4
FDB QSTACK-9
-EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO
-EXPEC2 FDB KEY,DUP,LIT8
- FCB $0E
- FDB PORIG,AT,EQUAL,ZBRAN
- FDB EXPEC3-*
+EXPECT FDB DOCOL,OVER,PLUS,OVER,XDO ; brace the buffer area
+* 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-*-NATWID
FDB DROP,LIT8
FCB 8 ( backspace character to emit )
- FDB OVER,I,EQUAL,DUP,FROMR,TWO,SUB,PLUS
+ 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 LEAVE,DROP,BL,ZERO,BRAN
- FDB EXPEC5-*
+ FDB EXPEC4-*-NATWID
+ FDB LEAVE,DROP,BL,ZERO,BRAN ; I think this is the NUL terminator.
+ 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
*
* ======>> 129 <<
+* ( --- )
+* EXPECT 128 (TWID) characters to TIB.
FCB $85
FCC 'QUER' ; 'QUERY'
FCB $D9
FDB SEMIS
*
* ======>> 130 <<
+* ( --- ) P
+* End interpretation of a line or screen, and/or prepare for a new block.
+* Note that the name of this definition is an empty string,
+* so it matches on the terminating NUL in the terminal or block buffer.
FCB $C1 immediate < carriage return >
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
*
* ######>> screen 47 <<
* ======>> 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
FDB SEMIS
*
* ======>> 134 <<
+* ( adr n --- )
+* Fill n bytes with 0.
FCB $85
FCC 'ERAS' ; 'ERASE'
FCB $C5
FDB SEMIS
*
* ======>> 135 <<
+* ( adr n --- )
+* Fill n bytes with ASCII SPACE.
FCB $86
FCC 'BLANK' ; 'BLANKS'
FCB $D3
FDB SEMIS
*
* ======>> 136 <<
+* ( c --- )
+* Format a character at the left of the HLD output buffer.
FCB $84
FCC 'HOL' ; 'HOLD'
FCB $C4
FDB SEMIS
*
* ======>> 137 <<
+* ( --- adr )
+* Give the address of the output PAD buffer.
+* PAD points to the end of a 68 byte buffer for numeric conversion.
FCB $83
FCC 'PA' ; 'PAD'
FCB $C4
*
* ######>> screen 48 <<
* ======>> 138 <<
+* ( c --- )
+* Scan a string terminated by the character c or ASCII NUL out of input;
+* store symbol at WORDPAD with leading count byte and trailing ASCII NUL.
+* Leading c are passed over, per ENCLOSE.
+* Scans from BLK, or from TIB if BLK is zero.
+* May overwrite the numeric conversion pad,
+* if really long (length > 31) symbols are scanned.
FCB $84
FCC 'WOR' ; 'WORD'
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
*
* ######>> screen 49 <<
* ======>> 139 <<
+* ( d1 string --- d2 adr )
+* Convert the text at string into a number, accumulating the result into d1,
+* leaving adr pointing to the first character not converted.
+* If DPL is non-negative at entry,
+* accumulates the number of characters converted into DPL.
FCB $88
FCC '(NUMBER' ; '(NUMBER)'
FCB $A9
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
*
* ======>> 140 <<
+* ( ctstr --- d )
+* Convert text at ctstr to a double integer,
+* taking the 0 ERROR if the conversion is not valid.
+* If a decimal point is present,
+* accumulate the count of digits to the decimal point's right into DPL
+* (negative DPL at exit indicates single precision).
+* ctstr is a counted string
+* -- the first byte at ctstr is the length of the string,
+* but NUMBER ignores the count and expects a NUL terminator instead.
FCB $86
FCC 'NUMBE' ; 'NUMBER'
FCB $D2
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
*
* ======>> 141 <<
+* ( --- locptr length true ) { -FIND name } typical input
+* ( --- false )
+* Parse a word, then FIND,
+* first in the definition vocabulary,
+* then in the CONTEXT (interpretation) vocabulary, if necessary.
+* Returns what (FIND) returns, flag and optional location and length.
FCB $85
FCC '-FIN' ; '-FIND'
FCB $C4
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
*
* ######>> screen 50 <<
* ======>> 142 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* An indirection for ABORT, for ERROR,
+* which may be modified carefully.
FCB $87
FCC '(ABORT' ; '(ABORT)'
FCB $A9
FCC 'ERRO' ; 'ERROR'
FCB $D2
FDB PABORT-10
+* This really should not be high level, according to best practices.
+* But fixing that cascades through MESSAGE,
+* requiring re-architecting the disk block system.
+* First, we need to get this transliteration running.
ERROR FDB DOCOL,WARN,AT,ZLESS
FDB ZBRAN
-* note: WARNING is -1 to abort, 0 to print error #
+ 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
*
* ######>> screen 51 <<
* ======>> 145 <<
+* ( --- ) { CREATE name } input
+* Parse a name (length < 32 characters) and create a header,
+* reporting first duplicate found in either the defining vocabulary
+* or the context (interpreting) vocabulary.
+* Install the header in the defining vocabulary
+* with CFA dangerously pointing to the parameter field.
+* Leave the name SMUDGEd.
FCB $86
FCC 'CREAT' ; 'CREATE'
FCB $C5
FDB IDDOT-6
CREATE FDB DOCOL,DFIND,ZBRAN
- FDB CREAT2-*
+ FDB CREAT2-*-NATWID
FDB DROP,PDOTQ
FCB 8
FCB 7 ( bel )
FDB MESS,SPACE
CREAT2 FDB HERE,DUP,CAT,WIDTH,AT,MIN
FDB ONEP,ALLOT,DUP,LIT8
- FCB $A0
+ FCB ($80|FSMUDG) ; Bracket the name.
FDB TOGGLE,HERE,ONE,SUB,LIT8
FCB $80
FDB TOGGLE,LATEST,COMMA,CURENT,AT,STORE
- FDB HERE,TWOP,COMMA
+* FDB HERE,TWOP,COMMA
+ FDB HERE,NATP,COMMA
FDB SEMIS
*
* ######>> screen 52 <<
* ======>> 146 <<
+* ( --- ) P
+* { [COMPILE] name } typical use
+* -DFIND next WORD and COMPILE it, literally;
+* used to compile immediate definitions into words.
FCB $C9 immediate
FCC '[COMPILE' ; '[COMPILE]'
FCB $DD
FDB SEMIS
*
* ======>> 147 <<
+* ( n --- ) if compiling. P
+* ( n --- n ) if interpreting.
+* Compile n as a literal, if compiling.
FCB $C7 immediate
FCC 'LITERA' ; 'LITERAL'
FCB $CC
FDB BCOMP-12
LITER FDB DOCOL,STATE,AT,ZBRAN
- FDB LITER2-*
+ FDB LITER2-*-NATWID
FDB COMPIL,LIT,COMMA
LITER2 FDB SEMIS
*
* ======>> 148 <<
+* ( d --- ) if compiling. P
+* ( d --- d ) if interpreting.
+* Compile d as a double literal, if compiling.
FCB $C8 immediate
FCC 'DLITERA' ; 'DLITERAL'
FCB $CC
FDB LITER-10
DLITER FDB DOCOL,STATE,AT,ZBRAN
- FDB DLITE2-*
- FDB SWAP,LITER,LITER
+ FDB DLITE2-*-NATWID
+ FDB SWAP,LITER,LITER ; Just two literals in the right order.
DLITE2 FDB SEMIS
*
* ######>> screen 53 <<
* ======>> 149 <<
+* ( --- )
+* Interpret or compile, according to STATE.
+* Searches words parsed in dictionary first, via -FIND,
+* then checks for valid NUMBER.
+* Pushes or COMPILEs double literal if NUMBER leaves DPL non-negative.
+* ERROR checks the stack via ?STACK before returning to its caller.
FCB $89
FCC 'INTERPRE' ; 'INTERPRET'
FCB $D4
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
*
* ######>> screen 54 <<
* ======>> 150 <<
+* ( --- )
+* Toggle precedence bit of LATEST definition header.
+* During compiling, most symbols scanned are compiled.
+* IMMEDIATE definitions execute whenever the outer INTERPRETer scans them,
+* but may be compiled via ' (TICK).
FCB $89
FCC 'IMMEDIAT' ; 'IMMEDIATE'
FCB $C5
FDB INTERP-12
IMMED FDB DOCOL,LATEST,LIT8
- FCB $40
+ FCB FIMMED
FDB TOGGLE
FDB SEMIS
*
* ======>> 151 <<
+* ( --- ) { VOCABULARY name } input
+* Create a vocabulary entry with a flag for terminating vocabulary searches.
+* Store the current search context in it for linking.
+* At run-time, VOCABULARY makes itself the CONTEXT vocabulary.
FCB $8A
FCC 'VOCABULAR' ; 'VOCABULARY'
FCB $D9
FDB IMMED-12
VOCAB FDB DOCOL,BUILDS,LIT,$81A0,COMMA,CURENT,AT,CFA
FDB COMMA,HERE,VOCLIN,AT,COMMA,VOCLIN,STORE,DOES
-DOVOC FDB TWOP,CONTXT,STORE
+* DOVOC FDB TWOP,CONTXT,STORE
+DOVOC FDB NATP,CONTXT,STORE
FDB SEMIS
*
* ======>> 152 <<
* Note: FORTH does not go here in the rom-able dictionary,
* since FORTH is a type of variable.
*
+* (Should make a proper architecture for this at some point.)
+*
*
* ======>> 153 <<
+* ( --- )
+* Makes the current interpretation CONTEXT vocabulary
+* also the CURRENT defining vocabulary.
FCB $8B
FCC 'DEFINITION' ; 'DEFINITIONS'
FCB $D3
FDB SEMIS
*
* ======>> 154 <<
+* ( --- )
+* Parse out a comment and toss it away.
+* Leaves the first 32 characters in WORDPAD, which may or may not be useful.
FCB $C1 immediate (
FCB $A8
FDB DEFIN-14
*
* ######>> screen 55 <<
* ======>> 155 <<
+* ( anything *** nothing )
+* Clear return stack.
+* Then INTERPRET and, if not compiling, prompt with OK,
+* in infinite loop.
FCB $84
FCC 'QUI' ; 'QUIT'
FCB $D4
* 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 <<
+* ( anything --- nothing ) ( anything *** nothing )
+* Clear parameter stack,
+* set STATE to interpret and BASE to DECIMAL,
+* return to input from terminal,
+* restore DRIVE OFFSET to 0,
+* print out "Forth-68",
+* set interpret and define vocabularies to FORTH,
+* and finally, QUIT.
+* Used to force the system to a known state
+* and return control to the initial INTERPRETer.
FCB $85
FCC 'ABOR' ; 'ABORT'
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
FCB $C4
FDB ABORT-8
COLD FDB *+NATWID
-CENT LDS #REND-1 top of destination
- LDX #ERAM top of stuff to move
-COLD2 LEAX -1,X ;
- LDA 0,X
- PSHS A ; move TASK & FORTH to ram
- CMPX #RAM
+* Ultimately, we want position indepence,
+* so I'm using PCR where it seems reasonable.
+CENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+* We'll keep this here for the time being.
+* There are better ways to do this, of course.
+* Re-architect, re-architect.
+ LEAX ERAM,PCR ; end of stuff to move
+ STX <XFENCE ; Borrow this variable for a loop terminator.
+ 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
-*
- LDS #XFENCE-1 put stack at a safe place for now
- LDX COLINT
- STX XCOLUM
- LDX DELINT
- STX XDELAY
- LDX VOCINT
- STX XVOCL
- LDX DPINIT
- STX XDICTP
- LDX FENCIN
- STX XFENCE
-
-
-WENT LDS #XFENCE-1 top of destination
- LDX #FENCIN top of stuff to move
-WARM2 LEAX -1,X ;
- LDA 0,X
- PSHS A ;
- CMPX #SINIT
+* 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
+* COLD2 LEAX -1,X ;
+* LDA 0,X
+* PSHS A ; move TASK & FORTH to ram
+* CMPX #RAM
+* BNE COLD2
+*
+* LDS #XFENCE-1 put stack at a safe place for now
+* But that is taken care of.
+* LDX COLINT
+* STX XCOLUM
+ LDX COLINT,PCR
+ STX <XCOLUM
+* LDX DELINT
+* STX XDELAY
+ LDX DELINT,PCR
+ STX <XDELAY
+* LDX VOCINT
+* STX XVOCL
+ LDX VOCINT,PCR
+ STX <XVOCL
+* LDX DPINIT
+* STX XDICTP
+ LDX DPINIT,PCR
+ STX <XDICTP
+* LDX FENCIN
+* STX XFENCE
+ LDX FENCIN,PCR
+ STX <XFENCE
+*
+WENT LDS SINIT,PCR ; Get a useable return stack, at least.
+ LDA #IUPDP ; This is not relative to PC.
+ TFR A,DP ; And a useable direct page, too.
+ SETDP IUPDP ; (For good measure.)
+*
+ LEAX SINIT,PCR
+ PSHS X ; for loop termination
+ CLRB ; Yes, I'm being a little ridiculous. Only a little.
+ TFR D,Y
+ 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 ;
+* LDA 0,X
+* PSHS A ;
+* CMPX #SINIT
+* BNE WARM2
+*
+* LDS SINIT
+* S is already there.
+* LDX UPINIT
+* STX UP init user ram pointer
+* UP is already there (DP).
+* LDX #ABORT
+* STX IP
+ LEAY ABORT+NATWID,PCR ; IP never points to DOCOL!
*
- LDS SINIT
- LDX UPINIT
- STX UP init user ram pointer
- LDX #ABORT
- STX IP
NOP Here is a place to jump to special user
NOP initializations such as I/0 interrups
NOP
*
* For systems with TRACE:
LDX #00
- STX TRLIM clear trace mode
+ STX ,U The hole above the parameter stack
+* STX TRLIM clear trace mode
+ STX <TRLIM clear trace mode (both bytes)
LDX #0
- STX BRKPT clear breakpoint address
- JMP RPSTOR+2 start the virtual machine running !
+* 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 !
+ 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 :
-* at address $140:
-*
-RAM FDB $3000,$3000,0,0
-
+* (not * at address $140:)
+* at an appropriate address:
+*
+* 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.
+* In order to make this ROMmable, this entry is set up as the tail-end,
+* and copied to RAM in the start-up code.
+* We want a more elegant solution to this, too. Greedy, maybe.
FCB $C5 immediate
FCC 'FORT' ; 'FORTH'
FCB $C8
- FDB NOOP-7
+ 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 <<
* ======>> 158 <<
+* ( n0 --- d0 )
+* Sign extend n0 to a double integer.
FCB $84
FCC 'S->' ; 'S->D'
FCB $C4
- FDB COLD-7
+ FDB COLD-7 ; Note that this does not link to FORTH (RFORTH)!
STOD FDB DOCOL,DUP,ZLESS,MINUS
FDB SEMIS
*
* ======>> 159 <<
+* ( multiplier multiplicand --- product )
+* Signed word multiply.
FCB $81 ; *
FCB $AA
FDB STOD-7
STAR FDB *+NATWID
- JSR [USTAR]
- LEAU 2,U ;
+ LBSR USTAR+NATWID ; or [USTAR,PCR]?
+ LEAU NATWID,U ; Drop high word.
RTS
* JSR USTARS
* LEAS 1,S ;
* JMP NEXT
*
* ======>> 160 <<
+* ( 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
FDB SEMIS
*
* ======>> 161 <<
+* ( dividend divisor --- quotient )
+* Signed word divide without remainder.
+* Except *BUG* it isn't signed.
FCB $81 ; /
FCB $AF
FDB SLMOD-7
FDB SEMIS
*
* ======>> 162 <<
+* ( dividend divisor --- remainder )
+* Remainder function, result takes sign of dividend.
FCB $83
FCC 'MO' ; 'MOD'
FCB $C4
FDB SEMIS
*
* ======>> 163 <<
+* ( multiplier multiplicand divisor --- remainder quotient )
+* Signed precise division of product:
+* multiply 2nd and 3rd words on stack
+* and divide the 31-bit product by the top word,
+* leaving both quotient and remainder.
+* Remainder takes sign of product.
+* Guaranteed not to lose significant bits in 16 bit integer math.
FCB $85
FCC '*/MO' ; '*/MOD'
FCB $C4
FDB SEMIS
*
* ======>> 164 <<
+* ( multiplier multiplicand divisor --- quotient )
+* */MOD without remainder.
FCB $82
FCC '*' ; '*/'
FCB $AF
FDB SEMIS
*
* ======>> 165 <<
+* ( ud1 u1 --- u2 ud2 )
+* U/ with an (unsigned) double quotient.
+* Guaranteed not to lose significant bits in 32 bit / 16 bit bit integer math,
+* if you are prepared to deal with the extra 16 bits of result.
FCB $85
FCC 'M/MO' ; 'M/MOD'
FCB $C4
FDB SEMIS
*
* ======>> 166 <<
+* ( n>=0 --- n )
+* ( n<0 --- -n )
+* Convert the top of stack to its absolute value.
FCB $83
FCC 'AB' ; 'ABS'
FCB $D3
FDB MSMOD-8
ABS FDB DOCOL,DUP,ZLESS,ZBRAN
- FDB ABS2-*
+ FDB ABS2-*-NATWID
FDB MINUS
ABS2 FDB SEMIS
*
* ======>> 167 <<
+* ( d>=0 --- d )
+* ( d<0 --- -d )
+* Convert the top double to its absolute value.
FCB $84
FCC 'DAB' ; 'DABS'
FCB $D3
FDB ABS-6
DABS FDB DOCOL,DUP,ZLESS,ZBRAN
- FDB DABS2-*
+ FDB DABS2-*-NATWID
FDB DMINUS
DABS2 FDB SEMIS
*
* ######>> screen 58 <<
-* Disc primatives :
+* Disc primitives :
* ======>> 168 <<
+* ( --- vadr )
+* Least Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
FCB $83
FCC 'US' ; 'USE'
FCB $C5
USE FDB DOCON
FDB XUSE
* ======>> 169 <<
+* ( --- vadr )
+* Most Recently Used buffer.
+* Really should be with FIRST and LIMIT in the per-task table.
FCB $84
FCC 'PRE' ; 'PREV'
FCB $D6
PREV FDB DOCON
FDB XPREV
* ======>> 170 <<
+* ( buffer1 --- buffer2 f )
+* Bump to next buffer,
+* flag false if result is PREVious buffer,
+* otherwise flag true.
+* Used in the LRU allocation routines.
FCB $84
FCC '+BU' ; '+BUF'
FCB $C6
FDB PREV-7
-PBUF FDB DOCOL,LIT8
- FCB $84
+* 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 PBUF2-*
+ FDB PBUF2-*-NATWID
FDB DROP,FIRST
PBUF2 FDB DUP,PREV,AT,SUB
FDB SEMIS
*
* ======>> 171 <<
+* ( --- )
+* Mark PREVious buffer dirty, in need of being written out.
FCB $86
FCC 'UPDAT' ; 'UPDATE'
FCB $C5
FDB SEMIS
*
* ======>> 172 <<
+* ( --- )
+* Mark all buffers empty.
+* Standard method of discarding changes.
FCB $8D
FCC 'EMPTY-BUFFER' ; 'EMPTY-BUFFERS'
FCB $D3
FDB SEMIS
*
* ======>> 173 <<
+* ( --- )
+* Clear the current offset to the block numbers in the drive interface.
+* The drives need to be re-architected.
+* Would be cool to have RAM and ROM drives supported
+* in addition to regular physical persistent store.
FCB $83
FCC 'DR' ; 'DR0'
FCB $B0
FDB SEMIS
*
* ======>> 174 <<== system dependant word
+* ( --- )
+* Set the current offset in the drive interface to reference the second drive.
+* The hard-coded number in there needs to be in a table.
FCB $83
FCC 'DR' ; 'DR1'
FCB $B1
*
* ######>> screen 59 <<
* ======>> 175 <<
+* ( n --- buffer )
+* Get a free buffer,
+* assign it to block n,
+* return buffer address.
+* Will free a buffer by writing it, if necessary.
+* Does not actually read the block.
+* A bug in the fig LRU algorithm, which I have not fixed,
+* gives the PREVious buffer if USE gets set to PREVious.
+* (The bug is that USE sometimes gets set to PREVious.)
+* This bug sometimes causes sector moves to become sector fills.
FCB $86
FCC 'BUFFE' ; 'BUFFER'
FCB $D2
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 R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
-BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+ FDB BUFFR3-*-NATWID
+* FDB R,TWOP,R,AT,LIT,$7FFF,AND,ZERO,RW
+ FDB R,NATP,R,AT,LIT,$7FFF,AND,ZERO,RW
+* BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,TWOP
+BUFFR3 FDB R,STORE,R,PREV,STORE,FROMR,NATP
FDB SEMIS
*
* ######>> screen 60 <<
* ======>> 176 <<
+* ( n --- buffer )
+* Get BUFFER containing block n, relative to OFFSET.
+* If block n is not in a buffer, bring it in.
+* Returns buffer address.
FCB $85
FCC 'BLOC' ; 'BLOCK'
FCB $CB
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 DROP,R,BUFFER,DUP,R,ONE,RW,TWO,SUB
+ 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,TWOP
+BLOCK5 FDB FROMR,DROP,NATP
FDB SEMIS
*
* ######>> screen 61 <<
* ======>> 177 <<
+* ( line screen --- buffer C/L)
+* Bring in the sector containing the specified line of the specified screen.
+* Returns the buffer address and the width of the screen.
+* Screen number is relative to OFFSET.
+* The line number may be beyond screen 4,
+* (LINE) will get the appropriate screen.
FCB $86
FCC '(LINE' ; '(LINE)'
FCB $A9
FDB SEMIS
*
* ======>> 178 <<
+* ( line screen --- )
+* Print the line of the screen as found by (LINE), suppress trailing BLANKS.
FCB $85
FCC '.LIN' ; '.LINE'
FCB $C5
FDB SEMIS
*
* ======>> 179 <<
+* ( n --- )
+* If WARNING is 0, print "MESSAGE #n";
+* otherwise, print line n relative to screen 4,
+* the line number may be negative.
+* Uses .LINE, but counter-adjusts to be relative to the real drive 0.
FCB $87
FCC 'MESSAG' ; 'MESSAGE'
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 # '
MESS4 FDB SEMIS
*
* ======>> 180 <<
+* ( n --- )
+* Begin interpretation of screen (block) n.
+* See also ARROW, SEMIS, and NULL.
FCB $84
FCC 'LOA' ; 'LOAD' : input:scr #
FCB $C4
FDB SEMIS
*
* ======>> 181 <<
+* ( --- ) P
+* Continue interpreting source code on the next screen.
FCB $C3
FCC '--' ; '-->'
FCB $BE
* called by words 13 through 16 in the dictionary.
*
* ======>> 182 << code for EMIT
-* output using rom CHROUT: redirectable to printer
-PEMIT PULU D
-PEMITW TFR B,A ; Coco ROM wants it in A.
- PSHS Y,U,DP ; Save everything important!
+* ( --- ) 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 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
-* wait for key from POLCAT
-PKEY PSHS Y,U,DP
+* ( --- ) 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 ; 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
- SETDP IUPDP ******** Check this when I get here again. *********
+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
* LDB ACIAC
*
* ######>> screen 64 <<
* ======>> 184 << code for ?TERMINAL
+* ( --- 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
CLRB
TFR B,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
*
* ######>> screen 66 <<
* ======>> 187 <<
- FCB $85
+* ( ??? )
+* Query the disk, I suppose.
+* Not sure what the model had in mind for this stub.
+ FCB $85
FCC '?DIS' ; '?DISC'
FCB $C3
FDB ARROW-6
*
* ######>> screen 67 <<
* ======>> 189 <<
+* ( ??? )
+* Write one block of data to disk.
+* Parameters unspecified in model. Stub in model.
FCB $8B
FCC 'BLOCK-WRIT' ; 'BLOCK-WRITE'
FCB $C5
*
* ######>> screen 68 <<
* ======>> 190 <<
+* ( ??? )
+* Read one block of data from disk.
+* Parameters unspecified in model. Stub in model.
FCB $8A
FCC 'BLOCK-REA' ; 'BLOCK-READ'
FCB $C4
FCB $C9
FDB LO-5
HI FDB DOCON
- FDB MEMTOP ( $3FFF in this version )
+ FDB MEMTOP ( $3FFF or $7FFF in this version )
*
* ######>> screen 69 <<
* ======>> 191 <<
+* ( buffer sector f --- )
+* Read or Write the specified (absolute -- ignores OFFSET) sector
+* from or to the specified buffer.
+* A zero flag specifies write,
+* non-zero specifies read.
+* Sector is an unsigned integer,
+* buffer is the buffer's address.
+* Will need to use the CoCo ROM disk routines.
+* For now, provides a virtual disk in RAM.
FCB $83
FCC 'R/' ; 'R/W'
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
*
+* From BIF-6809:
+* RW PSHS Y,U,DP
+* LDY $C006 control table
+* LDX #DROFFS+7 ; This is BIF's table of drive sizes.
+* LDD 2,U
+* RWD SUBD ,X++ sectors
+* BHS RWD
+* BVC RWR table end?
+* LDD #6
+* PSHU D
+* JMP ERROR
+* RWR ADDD ,--X back one
+* PSHS X
+* PSHU D
+* LDD #18 sectors/track
+* PSHU D
+* DOCOL
+* FDB SLAMOD
+* FDB XMACH
+* PULU D
+* STB 2,Y track
+* PULU D
+* INCB
+* STB 3,Y sector
+* PULS D table entry
+* SUBD #DROFFS+7
+* ASRB drive #
+* STB 1,Y
+* LDD 4,U buffer
+* STD 4,Y
+* LDB #2 coco READ
+* LDX ,U 0?
+* BNE *+3
+* INCB coco WRITE
+* STB ,Y op code
+* CLRA
+* TFR A,DP
+* JSR [$C004] ROM handles timeout
+* PULS Y,U,DP if IRQ enabled
+* LEAU 6,U
+* LDX $C006
+* LDB 6,X coco status
+* BEQ RWE
+* LDX <UP
+* LDD #0 no disc
+* STD UWARN,X
+* LDD #8
+* PSHU D
+* JMP ERROR
+* RWE NEXT
+*
* ######>> screen 72 <<
* ======>> 192 <<
+* ( --- ) compiling P
+* ( --- adr ) interpreting
+* { ' name } input
+* Parse a symbol name from input and search the dictionary for it, per -FIND;
+* compile the address as a literal if compiling,
+* otherwise just push it.
FCB $C1 immediate
FCB $A7 ' ( tick )
FDB RW-6
FDB SEMIS
*
* ======>> 193 <<
+* ( --- ) { FORGET name } input
+* Parse out name of definition to FORGET to, -DFIND it,
+* then lop it and everything that follows out of the dictionary.
+* In fig Forth, CURRENT and CONTEXT have to be the same to FORGET.
FCB $86
FCC 'FORGE' ; 'FORGET'
FCB $D4
*
* ######>> screen 73 <<
* ======>> 194 <<
+* ( adr --- ) C
+* Calculate a back reference from HERE and compile it.
FCB $84
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 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* typical use: BEGIN code-loop AGAIN
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* ( --- adr n ) compile time P,C
+* Push HERE for BACK reference for general (non-counting) loops,
+* with BEGIN construct flag.
+* A better flag: $4245 (ASCII for 'BE').
FCB $C5
FCC 'BEGI' ; 'BEGIN'
FCB $CE
FDB BACK-7
-BEGIN FDB DOCOL,QCOMP,HERE,ONE
+BEGIN FDB DOCOL,QCOMP,HERE,ONE ; ONE is a flag for BEGIN loops.
FDB SEMIS
*
* ======>> 196 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ENDIF is just a sort of intersection piece,
+* marking where execution resumes after both branches.
+* ( adr n --- ) compile time
+* Check the mark and resolve the IF.
+* A better flag: $4846 (ASCII for 'IF').
FCB $C5
FCC 'ENDI' ; 'ENDIF'
FCB $C6
FDB BEGIN-8
-ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE
- FDB OVER,SUB,SWAP,STORE
+ENDIF FDB DOCOL,QCOMP,TWO,QPAIRS,HERE ; This TWO is a flag for IF.
+ FDB OVER,NATP,SUB,SWAP,STORE
FDB SEMIS
*
* ======>> 197 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ( adr n --- )
+* Alias for ENDIF .
FCB $C4
FCC 'THE' ; 'THEN'
FCB $CE
FDB SEMIS
*
* ======>> 198 <<
+* ( limit index --- ) runtime
+* typical use: DO code-loop LOOP
+* typical use: DO code-loop increment +LOOP
+* Counted loop, index is initial value of index.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( --- adr n ) compile time P,C
+* Compile (DO), push HERE for BACK reference,
+* and push DO control construct flag.
+* A better flag: $444F (ASCII for 'DO').
FCB $C2
FCC 'D' ; 'DO'
FCB $CF
FDB THEN-7
-DO FDB DOCOL,COMPIL,XDO,HERE,THREE
+DO FDB DOCOL,COMPIL,XDO,HERE,THREE ; THREE is a flag for DO loops.
FDB SEMIS
*
* ======>> 199 <<
+* ( --- ) runtime
+* typical use: DO code-loop LOOP
+* Increments the index by one and branches back to beginning of loop.
+* Will loop until index equals limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
FCB $C4
FCC 'LOO' ; 'LOOP'
FCB $D0
FDB DO-5
-LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK
+LOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XLOOP,BACK ; THREE for DO loops.
FDB SEMIS
*
* ======>> 200 <<
+* ( n --- ) runtime
+* typical use: DO code-loop increment +LOOP
+* Increments the index by n and branches back to beginning of loop.
+* Will loop until index equals (positive going)
+* or passes (negative going) limit.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (+LOOP), fill in BACK reference.
+* A better flag: $444F (ASCII for 'DO').
FCB $C5
FCC '+LOO' ; '+LOOP'
FCB $D0
FDB LOOP-7
-PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK
+PLOOP FDB DOCOL,THREE,QPAIRS,COMPIL,XPLOOP,BACK ; THREE for DO loops.
FDB SEMIS
*
* ======>> 201 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test UNTIL
+* Will loop until UNTIL tests true.
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
FCB $C5
FCC 'UNTI' ; 'UNTIL' : ( same as END )
FCB $CC
FDB PLOOP-8
-UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK
+UNTIL FDB DOCOL,ONE,QPAIRS,COMPIL,ZBRAN,BACK ; ONE for BEGIN loops.
FDB SEMIS
*
* ######>> screen 74 <<
* ======>> 202 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test END
+* ( adr n --- )
+* Alias for UNTIL .
FCB $C3
FCC 'EN' ; 'END'
FCB $C4
FDB SEMIS
*
* ======>> 203 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop AGAIN
+* Will loop forever
+* (or until something uses R> DROP to force the current definition to die,
+* or perhaps ABORT or ERROR or some such other drastic means stops things).
+* ( adr n --- ) compile time P,C
+* Check the mark and compile (0BRANCH), fill in BACK reference.
+* A better flag: $4245 (ASCII for 'BE').
FCB $C5
FCC 'AGAI' ; 'AGAIN'
FCB $CE
FDB END-6
-AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK
+AGAIN FDB DOCOL,ONE,QPAIRS,COMPIL,BRAN,BACK ; ONE for BEGIN loops.
FDB SEMIS
*
* ======>> 204 <<
+* ( --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* REPEAT marks where execution resumes after the WHILE find a false flag.
+* ( aadr1 n1 adr2 n2 --- ) compile time P,C
+* Check the marks for WHILE and BEGIN,
+* compile BRANCH and BACK fill adr1 reference,
+* FILL-IN 0BRANCH reference at adr2.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
FCB $C6
FCC 'REPEA' ; 'REPEAT'
FCB $D4
FDB AGAIN-8
-REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR
- FDB TWO,SUB,ENDIF
+REPEAT FDB DOCOL,TOR,TOR,AGAIN,FROMR,FROMR ; ONE for BEGIN loops.
+ FDB TWO,SUB,ENDIF ; TWO is for IF, 4 is for WHILE.
FDB SEMIS
*
* ======>> 205 <<
+* ( n --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* Will pass execution to the true part on a true flag
+* and to the false part on a false flag.
+* ( --- adr n ) compile time P,C
+* Compile a 0BRANCH and dummy offset
+* and push IF reference to fill in and
+* IF control construct flag.
+* A better flag: $4946 (ASCII for 'IF').
FCB $C2
FCC 'I' ; 'IF'
FCB $C6
FDB REPEAT-9
-IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO
+IF FDB DOCOL,COMPIL,ZBRAN,HERE,ZERO,COMMA,TWO ; TWO is a flag for IF.
FDB SEMIS
*
* ======>> 206 <<
+* ( --- ) runtime
+* typical use: test IF code-true ELSE code-false ENDIF
+* ELSE is just a sort of intersection piece,
+* marking where execution resumes on a false branch.
+* ( adr1 n --- adr2 n ) compile time P,C
+* Check the marks,
+* compile BRANCH with dummy offset,
+* resolve IF reference,
+* and leave reference to BRANCH for ELSE.
+* A better flag: $4946 (ASCII for 'IF').
FCB $C4
FCC 'ELS' ; 'ELSE'
FCB $C5
FDB IF-5
ELSE FDB DOCOL,TWO,QPAIRS,COMPIL,BRAN,HERE
- FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO
+ FDB ZERO,COMMA,SWAP,TWO,ENDIF,TWO ; TWO is a flag for IF.
FDB SEMIS
*
* ======>> 207 <<
+* ( n --- ) runtime
+* typical use: BEGIN code-loop test WHILE code-true REPEAT
+* Will loop until WHILE tests false, skipping code-true on end.
+* ( --- adr n ) compile time P,C
+* Compile 0BRANCH with dummy offset (using IF),
+* push WHILE reference.
+* BEGIN flag will sit underneath this.
+* Better flags: $4245 (ASCII for 'BE') and $5747 (ASCII for 'WH').
FCB $C5
FCC 'WHIL' ; 'WHILE'
FCB $C5
FDB ELSE-7
-WHILE FDB DOCOL,IF,TWOP
+WHILE FDB DOCOL,IF,TWOP ; TWO is a flag for IF, 4 is for WHILE.
FDB SEMIS
*
* ######>> screen 75 <<
* ======>> 208 <<
+* ( count --- )
+* EMIT count spaces, for non-zero, non-negative counts.
FCB $86
FCC 'SPACE' ; 'SPACES'
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 <<
+* ( --- )
+* Initialize HLD for converting a double integer.
+* Stores the PAD address in HLD.
FCB $82
FCC '<' ; '<#'
FCB $A3
FDB SEMIS
*
* ======>> 210 <<
+* ( d --- string length )
+* Terminate numeric conversion,
+* drop the number being converted,
+* leave the address of the conversion string and the length, ready for TYPE.
FCB $82
FCC '#' ; '#>'
FCB $BE
FDB SEMIS
*
* ======>> 211 <<
+* ( n d --- d )
+* Put sign of n (as a flag) at the head of the conversion string.
+* Drop the sign flag.
FCB $84
FCC 'SIG' ; 'SIGN'
FCB $CE
FDB EDIGS-5
SIGN FDB DOCOL,ROT,ZLESS,ZBRAN
- FDB SIGN2-*
+ FDB SIGN2-*-NATWID
FDB LIT8
FCC "-"
FDB HOLD
SIGN2 FDB SEMIS
*
* ======>> 212 <<
+* ( d --- d/base )
+* Generate next most significant digit in the conversion BASE,
+* putting the digit at the head of the conversion string.
FCB $81 #
FCB $A3
FDB SIGN-7
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 SEMIS
*
* ======>> 213 <<
+* ( d --- dzero )
+* Convert d to a numeric string using # until the result is zero.
+* Leave the double result on the stack for #> to drop.
FCB $82
FCC '#' ; '#S'
FCB $D3
FDB DIG-4
DIGS FDB DOCOL
DIGS2 FDB DIG,OVER,OVER,OR,ZEQU,ZBRAN
- FDB DIGS2-*
+ FDB DIGS2-*-NATWID
FDB SEMIS
*
* ######>> screen 76 <<
* ======>> 214 <<
+* ( n width --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
FCB $82
FCC '.' ; '.R'
FCB $D2
FDB SEMIS
*
* ======>> 215 <<
+* ( d width --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* right aligned in a field at least width wide.
FCB $83
FCC 'D.' ; 'D.R'
FCB $D2
FDB SEMIS
*
* ======>> 216 <<
+* D. ( d --- )
+* Print d on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
FCB $82
FCC 'D' ; 'D.'
FCB $AE
FDB SEMIS
*
* ======>> 217 <<
+* ( n --- )
+* Print n on the output device in the current conversion base,
+* with sign,
+* in free format with trailing space.
FCB $81 .
FCB $AE
FDB DDOT-5
FDB SEMIS
*
* ======>> 218 <<
+* ( adr --- )
+* Print signed word at adr, per DOT.
FCB $81 ?
FCB $BF
FDB DOT-4
*
* ######>> screen 77 <<
* ======>> 219 <<
+* ( 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
*
* ======>> 220 <<
+* ( 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
*
* ######>> screen 78 <<
* ======>> 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 (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
* at time of cold load and should have the same contents
* as shown here:
*
+* 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 "HEX ( THIS IS SOME TEST STUFF. ) " ; 0
+ FCC ": STAR 42 EMIT ; ( With some randome comments. ) " ; 1
+ FCC ": STARS 0 DO I EMIT LOOP ; ;S " ; 2
+ FCC " " ; 3
+ FCC " " ; 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 " " ; 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
