Deriving a new dialect of Very Tiny Language from VTL-2 6800 version
Rev. | 2458e94408dc7fef19bb5d2a436041bc9c4a915a |
---|---|
크기 | 14,135 bytes |
Time | 2022-10-14 16:06:22 |
Author | Joel Matthew Rees |
Log Message | explicitly terminate the powers of ten array.
|
OPT 6801
* VTL-2 for 6801
* V-3.6
* 9-23-76
* BY GARY SHANNON
* & FRANK MCCOY
* COPYWRIGHT 1976, THE COMPUTER STORE
*
* Modifications for 6801 fake on exorsim
* and for moving variables out of direct page
* by Joel Matthew Rees
* Copyright 2022, Joel Matthew Rees
* Starting with low-hanging fruit.
* Modifications explained at
* https://joels-programming-fun.blogspot.com/2022/08/programming-tandyradio-shacks-mc-10-in-assembly.html
*
* DEFINE LOCATIONS IN MONITOR
* INCH EQU $FF00 ; per VTL.ASM
* EINCH EQU $F012 ; exorsim mdos Input byte with echo unless AECHO is set
* INCH EQU $F015 ; exorsim mdos Input char with echo (F012 -> strip bit 7)
* POLCAT EQU $FF24 ; from VTL.ASM
* OUTCH EQU $FF81 ; from VTL.ASM
* EOUTCH EQU $F018 ; exorsim mdos Output character with NULs
* OUTS EQU $FF82 ; from VTL.ASM
* EPCRLF EQU $F021 ; Primarily for forced initialization in exorsim.
*
* FOR SBC6800:
*BREAK EQU $1B ; BREAK KEY
* For MC-10:
BREAK EQU $03
* For exorsim
*ACIACS EQU $FCF4 ; exorcisor
*ACIADA EQU $FCF5 ; exorcisor
*
* A few interpreter variables in the direct page won't hurt.
* (Yes, I can hear voices of complaint that it's not as "tight" as it could be.)
* (This allows us to save more ROM space and uses DP that would otherwise go wasted.)
* (Trade-offs.)
* (It also helps us understand the code, so we can do a better 6809 transliteration.)
* (I hope the names are meaningful.)
*
* In .c10 format, the following as ORG and RMBs will cause object code output,
* which will prevent the code from loading.
* Changed to EQU for the MC10.
* ORG $C0 ; Move this according to your environment's needs.
DPBASE EQU $C0 ; Change this to move the registers.
* PARSET RMB 2 ; Instead of SAVE0 in TERM/NXTRM
PARSET EQU DPBASE+2
* CVTSUM RMB 2 ; Instead of SAVE1 in CBLOOP
CVTSUM EQU PARSET+2
* MLDVCT EQU CVTSUM ; Instead of SAVE1 in mul/div (1 byte only)
MLDVCT EQU CVTSUM
* DIVQUO RMB 2 ; Instead of SAVE2 in DIV
DIVQUO EQU MLDVCT+2
* MPLIER EQU DIVQUO ; Instead of SAVE2 in MULTIP
MPLIER EQU DIVQUO
* EVALPT RMB 2 ; Instead of SAVE3
EVALPT EQU MPLIER+2
* CNVPTR RMB 2 ; Instead of SAVE4
CNVPTR EQU EVALPT+2
* VARADR RMB 2 ; Instead of SAVE6
VARADR EQU CNVPTR+2
* OPRLIN RMB 2 ; Instead of SAVE7
OPRLIN EQU VARADR+2
* EDTLIN RMB 2 ; Instead of SAVE8
EDTLIN EQU OPRLIN+2
* INSPTR RMB 2 ; Instead of SAVE10 (maybe? Will some VTL programs want it back?)
INSPTR EQU EDTLIN+2
* SAVLIN RMB 2 ; Instead of SAVE11
SAVLIN EQU INSPTR+2
* SRC RMB 2 ; For copy routine
SRC EQU SAVLIN+2
* DST RMB 2 ; ditto
DST EQU SRC+2
STKMRK EQU DST+2 ; to restore the stack on each pass.
DPALLOC EQU STKMRK+2 ; total storage declared in the direct page
*
* SET ASIDE FOUR BYTES FOR USER
* DEFINED INTERUPT ROUTINE IF NEEDED
ORG $4300
* ZERO must be set at even $100 boundary for address math to work.
ZERO RMB 4 ; INTERUPT VECTOR
AT RMB 2 ; CANCEL & C-R
*
* GENERAL PURPOSE STORRGE
VARS RMB 52 ; VARIABLES(A-Z)
BRAK RMB 2 ; [
* SAVE10 has me worried about implicit linkage in VTL programs. Might need to leave it here.
SAVE10 RMB 2 ; BACK SLASH
BRIK RMB 2 ; ]
UP RMB 2 ; ^
SAVE11 RMB 2 ; Need something in each SAVE to reserve space
* ; to keep the math straight.
* ; Leave the SAVEs declared as they are.
*
SAVE14 RMB 2 ; SPACE (originally unused)
EXCL RMB 2 ; !
QUOTE RMB 2 ; "
DOLR RMB 2 ; #
DOLLAR RMB 2 ; $
REMN RMB 2 ; %
AMPR RMB 2 ; &
QUITE RMB 2 ; '
PAREN RMB 2 ; (
PARIN RMB 2 ; )
STAR RMB 2 ; *
PLUS RMB 2 ; +
COMA RMB 2 ; ,
MINS RMB 2 ; -
PERD RMB 2 ; .
SLASH RMB 2 ; /
*
SAVE0 RMB 2 ; unused
SAVE1 RMB 2 ; unused
SAVE2 RMB 2 ; unused
SAVE3 RMB 2 ; unused
SAVE4 RMB 2 ; unused
SAVE5 RMB 2 ; unused (PSH/PULX)
SAVE6 RMB 2 ; unused
SAVE7 RMB 2 ; unused
SAVE8 RMB 2 ; unused
SAVE9 RMB 2 ; unused (PSH/PULX)
COLN RMB 2 ; :
SEMI RMB 2 ; ;
LESS RMB 2 ; <
EQAL RMB 2 ; =
GRRT RMB 1 ; >
DECB_1 RMB 1
*
DECBUF RMB 4
LASTD RMB 1
DELIM RMB 1
LINLEN EQU 72
LINBUF RMB LINLEN+1
BUFOFF EQU LINBUF-ZERO ; Unmagic 87. Some assemblers will cough at this.
*
ORG $43F1
STACK RMB 1
*
ORG $4400
MI RMB 4 ; INTERUPT VECTORS
NMI RMB 4
PRGM EQU * ; PROGRAM STARTS HERE
* Must have some RAM here.
*
ORG $4C00
*
* The COLD boot can be removed or ignored to restore the original behavior,
* but if you do that don't forget to set & (AMPR) and * (STAR) values
* by hand immediately after STARTing.
*
* Also, instead of PROBEing, if you know the limits for a particular ROM
* application, you can set STAR directly:
* LDX #PRGM
* STX AMPR
* LDX #RAMLIM
* STX STAR
* START ...
*
COLD STS STKMRK ; Mark the stack,
* LDS #STACK ; but use BASIC's stack. (S on 6800 points to next free byte.)
* JSR TRMINI
LDX #PRGM ; initialize program area base
STX AMPR
LDAA #$5A ; Probe RAM limit
LDAB #$A5
BRA PROBET
PROBE STAA 0,X
CMPA 0,X
BNE NOTRAM
STAB 0,X
CMPB 0,X
BNE NOTRAM
INX ; all bits seem to be R/W.
INC $401F ; DBG
PROBET CPX #COLD
BHI PROBE ; CPX on 6801 works right.
NOTRAM DEX
STX STAR
START
* LDS #STACK ; re-initialize at beginning of each evaluate
LDS STKMRK ; from mark instead of constant
DEC $401E ; DBG
CLRA ; NUL delimiter
LDX #OKM
BSR STRGT
*
LOOP CLRA
STAA DOLR
STAA DOLR+1
JSR CVTLN
BCC STMNT ; NO LINE# THEN EXEC
BSR EXEC
BEQ START
*
LOOP2 BSR FIND ; FIND LINE
EQSTRT BEQ START ; IF END THEN STOP
LDX 0,X ; LOAD REAL LINE #
STX DOLR ; SAVE IT
LDX SAVLIN ; GET LINE
INX ; BUMP PAST LINE #
INX ; BUMP PAST LINE #
INX ; BUMP PAST SPACE
BSR EXEC ; EXECUTE IT
BEQ LOOP3 ; IF ZERO, CONTINUE
LDX SAVLIN ; FIND LINE
LDX 0,X ; GET IT
CPX DOLR ; HAS IT CHANGED?
BEQ LOOP3 ; IF NOT GET NEXT
*
INX ; INCREMENT OLD LINE#
STX EXCL ; SAVE FOR RETURN
BRA LOOP2 ; CONTINUE
*
LOOP3 BSR FND3 ; FIND NEXT LINE
BRA EQSTRT ; CONTINUE
*
EXEC STX OPRLIN ; EXECUTE LINE
JSR VAR2
INX
*
SKIP LDAA 0,X ; GET FIRST TERM
BSR EVIL ; EVALUATE EXPRESSION
OUTX LDX DOLR ; GET LINE #
RTS
*
EVIL CMPA #$22 ; IF " THEN BRANCH
BNE EVALU
INX
STRGT JMP STRING ; TO PRINT IT
*
STMNT STX EDTLIN ; SAVE LINE #
STD DOLR
LDX DOLR
BNE SKP2 ; IF LINE# <> 0
*
LDX #PRGM ; LIST PROGRAM
LST2 CPX AMPR ; END OF PROGRAM
BEQ EQSTRT
STX SAVLIN ; LINE # FOR CVDEC
LDD 0,X
JSR PRNT2
LDX SAVLIN
INX
INX
JSR PNTMSG
JSR CRLF
BRA LST2
*
NXTXT LDX SAVLIN ; GET POINTER
INX ; BUMP PAST LINE#
LOOKAG INX ; FIND END OF LINE
TST 0,X
BNE LOOKAG
INX
RTS
*
FIND LDX #PRGM ; FIND LINE
FND2 STX SAVLIN
CPX AMPR
BEQ RTS1
* LDAA 1,X ; almost missed this.
* SUBA DOLR+1 ; This was necessary because no SUBD
* LDAA 0,X ; and CPX does not affect C flag on 6800
* SBCA DOLR
* PSHB ; B does not seem to be in use.
LDD 0,X ; Use D because we think we want to keep X.
SUBD DOLR
* PULB
BCC SET
FND3 BSR NXTXT
BRA FND2
*
SET LDAA #$FF ; SET NOT EQUAL
RTS1 RTS
*
EVALU JSR EVAL ; EVALUATE LINE
PSHB
PSHA
LDX OPRLIN
JSR CONVP
PULA
CMPB #'$ ; STRING?
BNE AR1
PULB
JMP OUTCH ; THEN PRINT IT
AR1 SUBB #'? ; PRINT?
BNE AR11 ; was out of range.
JMP PRNT ; THEN DO IT
* BEQ PRNT ; When we bring it back within range.
AR11 INCB ; MACHINE LANGUAGE?
PULB
BNE AR2
SWI ; THEN INTERUPT
*
AR2 STD 0,X ; STORE NEW VALUE
ADDD QUITE ; RANDOMIZER
STD QUITE
RTS
*
SKP2 BSR FIND ; FIND LINE
BEQ INSRT ; IF NOT THERE
LDX 0,X ; THEN INSERT
CPX DOLR ; NEW LINE
BNE INSRT
*
BSR NXTXT ; SETUP REGISTERS
* LDS SAVLIN ; FOR DELETE
STX SRC
LDX SAVLIN
STX DST
*
DELT LDX SRC
CPX AMPR ; DELETE OLD LINE
BEQ FITIT
LDAA 0,X
INX
STX SRC
* PSHA
* INX
* INS
* INS
LDX DST
STA 0,X
INX
STX DST
BRA DELT
*
* FITIT STS AMPR ; STORE NEW END
FITIT LDX DST
STX AMPR ; STORE NEW END
*
INSRT LDX EDTLIN ; COUNT NEW LINE LENGTH
LDAB #$03
TST 0,X
BEQ GOTIT ; IF NO LINE THEN STOP
CNTLN INCB ; count bytes
INX
TST 0,X ; Find trailing NUL
BNE CNTLN
*
OPEN CLRA ; CALCULATE NEW END
ADDD AMPR
STD INSPTR
SUBD STAR
BCC RSTRT ; IF TOO BIG THEN STOP
LDX AMPR
* LDS INSPTR ; remember that the 6800/6801 stack is postdecrement push.
* STS AMPR
LDD INSPTR ; remember that the 6800/6801 stack is postdecrement push.
STD AMPR
*
* LDS AMPR
STD DST
INX ; SLIDE OPEN GAP
SLIDE DEX ; going down
STX SRC
LDAB 0,X
* PSHB ; stack blast it
LDX DST
STAB 0,X ; mimic 6800 push
DEX
STX DST
LDX SRC
CPX SAVLIN
BHI SLIDE
*
* DON LDS DOLR ; STORE LINE #
* STS 0,X
DON LDD DOLR ; STORE LINE #
STD 0,X
STX DST ; will skip by offset store
* LDS EDTLIN ; GET NEW LINE
* DES ; pre-increment
LDD EDTLIN ; GET NEW LINE
STD SRC
*
*MOVL INX ; INSERT NEW LINE (skip over LINE # hi byte)
* PULB
* STAB 1,X ; (skips over low byte, BTW)
MOVL LDX SRC
LDAB 0,X
INX
STX SRC
LDX DST
INX ; skip over what was already stored (too tricky for words).
STX DST
STAB 1,X ; note offset store
BNE MOVL ; until NUL stored
*
GOTIT
* LDS #STACK ; Ready for a new line of input.
LDS STKMRK ; restore from mark
JMP LOOP
*
RSTRT JMP START ; warm start over
*
PRNT PULB ; PRINT DECIMAL
PRNT2 LDX #DECBUF ; CONVERT TO DECIMAL
STX CNVPTR
LDX #PWRS10
CVD1 PSHX
LDX 0,X
STX VARADR
LDX #VARADR
JSR DIVIDE
PSHA
LDX CNVPTR
LDAA DIVQUO+1
ADDA #'0
STAA 0,X
PULA
INX
STX CNVPTR
PULX
INX
INX
TST 1,X
BNE CVD1
*
LDX #DECB_1
COM 5,X ; ZERO SUPPRESS
ZRSUP INX
LDAB 0,X
CMPB #'0
BEQ ZRSUP
COM LASTD
*
PNTMSG CLRA ; ZERO FOR DELIM
STRTMS STAA DELIM ; STORE DELIMTER
*
OUTMSG LDAB 0,X ; GENERAL PURPOSE PRINT
INX
CMPB DELIM
BEQ CTLC
JSR OUTCH
BRA OUTMSG
*
CTLC JSR POLCAT ; POL FOR CHARACTER
BCC RTS2
BSR INCH2
CMPB #BREAK ; BREAK KEY?
BEQ RSTRT
*
INCH2 JMP INCH
*
STRING BSR STRTMS ; PRINT STRING LITERAL
LDAA 0,X
CMPA #';
BEQ OUTD
JMP CRLF
*
EVAL BSR GETVAL ; EVALUATE EXPRESSION
*
NXTRM PSHA
LDAA 0,X ; END OF LINE?
BEQ OUTN
CMPA #')
OUTN PULA
BEQ OUTD
BSR TERM
LDX PARSET
BRA NXTRM
*
TERM PSHA ; GET VALUE
PSHB
LDAA 0,X
PSHA
INX
BSR GETVAL
STD EVALPT
STX PARSET
LDX #EVALPT
PULA
PULB
*
CMPA #'* ; SEE IF *
BNE EVAL2
PULA ; MULTIPLY
MULTIP STD MPLIER ; 2'S COMPLEMENT
LDAB #$10
STAB MLDVCT
CLRA
CLRB
*
MULT LSR MPLIER
ROR MPLIER+1
BCC NOAD
MULTI ADDD 0,X
NOAD ASL 1,X
ROL 0,X
DEC MLDVCT
BNE MULT ; LOOP TIL DONE
RTS2 RTS
*
GETVAL JSR CVBIN ; GET VALUE
BCC OUTV
CMPB #'? ; OF LITERAL
BNE VAR
PSHX ; OR INPUT
JSR INLN
BSR EVAL
PULX
OUTD INX
OUTV RTS
*
VAR CMPB #'$ ; OR STRING
BNE VAR1
BSR INCH2
CLRA
INX
RTS
*
VAR1 CMPB #'(
BNE VAR2
INX
BRA EVAL
*
VAR2 BSR CONVP ; OR VARIABLE
LDD 0,X ; OR ARRAY ELEMENT
LDX VARADR ; LOAD OLD INDEX
RTS
*
ARRAY JSR EVAL ; LOCATE ARRAY ELEMENT
ASLD
ADDD AMPR
BRA PACK
*
CONVP LDAB 0,X ; GET LOCATION
INX
PSHB
CMPB #':
BEQ ARRAY ; OF VARIABLE OR
CLRA ; ARRAY ELEMENT
ANDB #$3F ; mask out-of-variable-range
ADDB #$02 ; bump past "interrupt vectors"
ASLB ; make into offset (would be address in DP in original)
ADDD #ZERO ; The 6801 can do this right.
*
PACK STX VARADR ; STORE OLD INDEX
STD CNVPTR
LDX CNVPTR ; LOAD NEW INDEX
PULB
RTS
*
EVAL2 CMPA #'+ ; ADDITION
BNE EVAL3
PULA
ADD ADDD 0,X
RTS
*
EVAL3 CMPA #'- ; SUBTRACTION
BNE EVAL4
PULA
SUBTR SUBD 0,X
RTS
*
EVAL4 CMPA #'/ ; SEE IF IT'S DIVIDE
BNE EVAL5
PULA
BSR DIVIDE
STD REMN
LDD DIVQUO
RTS
*
EVAL5 SUBA #'= ; SEE IF EQUAL TEST
BNE EVAL6
PULA
BSR SUBTR
BNE NOTEQ
TSTB
BEQ EQL
NOTEQ LDAB #$FF
EQL BRA COMBOUT
*
EVAL6 DECA ; SEE IF LESS THAN TEST
PULA
BEQ EVAL7
*
SUB2 BSR SUBTR
ROLB
COMOUT CLRA
ANDB #$01
RTS
*
EVAL7 BSR SUB2 ; GT TEST
COMBOUT COMB
BRA COMOUT
*
PWRS10 FCB $27 ; 10000
FCB $10
FCB $03 ; 1000
FCB $E8
FCB $00 ; 100
FCB $64
FCB $00 ; 10
FCB $0A
FCB $00 ; 1
FCB $01
*
DIVIDE CLR MLDVCT ; DEVIDE 16-BITS
GOT INC MLDVCT
ASL 1,X
ROL 0,X
BCC GOT
ROR 0,X
ROR 1,X
CLR DIVQUO
CLR DIVQUO+1
DIV2 BSR SUBTR
BCC OK
ADDD 0,X
CLC
BRA DIVNOC ; instead of the trick
* The 6801 CPX affects all relevant flags, can't use this trick.
* FCB $9C ; CPX
OK SEC ; $0D
DIVNOC ROL DIVQUO+1
ROL DIVQUO
DEC MLDVCT
BEQ DONE
LSR 0,X
ROR 1,X
BRA DIV2
*
TSTN LDAB 0,X ; TEST FOR NUMERIC
CMPB #$3A
BPL NOTDEC
CMPB #'0
BGE DONE
NOTDEC SEC
RTS
DONE CLC
DUN RTS
*
CVTLN BSR INLN
*
CVBIN BSR TSTN ; CONVERT TO BINARY
BCS DUN
CONT CLRA
CLRB
CBLOOP ADDB 0,X
ADCA #$00
SUBB #'0
SBCA #$00
STD CVTSUM
INX
PSHB
BSR TSTN
PULB
BCS DONE
ASLD
ASLD
ADDD CVTSUM
ASLD
BRA CBLOOP
*
INLN6 CMPB #'@ ; CANCEL
BEQ NEWLIN
INX ; '.'
CPX #ZERO+LINLEN+2 ; (Here's part of what we had to fix for moving the variables.)
BNE INLN2
NEWLIN BSR CRLF
*
INLN LDX #ZERO+2 ; INPUT LINE FROM TERMINAL
INLN5 DEX
CPX #ZERO ; Make this explicit to enable variables moved out of DP.
BEQ NEWLIN ; (Was implicit zero compare X from DEX, now explicit.)
INLN2 JSR INCH ; INPUT CHARACTER
STAB BUFOFF-1,X ; STORE IT
CMPB #$5F ; BACKSPACE?
BEQ INLN5
*
INLIN3 CMPB #$0D ; CARRIAGE RETURN
BMI INLN2
BNE INLN6
*
INLIN4 CLR BUFOFF-1,X ; CLEAR LAST CHAR
LDX #LINBUF
BRA LF
*
* CRLF JSR EPCRLF
CRLF LDAB #$0D ; CARR-RET
BSR OUTCH2
LF LDAB #$0A ; LINE FEED
OUTCH2 BRA OUTCH
*
OKM FCB $0D
FCB $0A
FCC 'OK'
FCB $00
*
*TRMINI LDAB #40
*TRMILP JSR EPCRLF
* DECB
* BNE TRMILP
* RTS
*
* MC-10 BASIC ROM vectors
INCHV EQU $FFDC ; Scan keyboard
OUTCHV EQU $FFDE ; Write char to screen
*
* RECEIVER POLLING
POLCAT PSHA
PSHX
LDX INCHV ; at any rate, don't wait.
JSR 0,X ;
TAB ; MC-10 ROM says NUL is not input.
SEC
BNE POLCATR ; Don't wait.
CLC
POLCATR PULX
PULA
RTS
*POLCAT LDAB ACIACS
* ASRB
* RTS
*
* INPUT ONE CHAR INTO B ACCUMULATOR
INCH BSR POLCAT
INC $400F ; DBG
BCC INCH ; Wait here.
INC $4010 ; DBG
STAB $4011 ; DBG
RTS
*
* OUTPUT ONE CHAR
OUTCH PSHA
PSHX
LDX OUTCHV
TBA
JSR 0,X
PULX
PULA
RTS
*
ORG COLD
*
END