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/vtl-2-part-3-optimizing-for-6801.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 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.)
	ORG	$80	; Move this according to your environment's needs.
PARSET	RMB	2	; Instead of SAVE0 in TERM/NXTRM
CVTSUM	RMB	2	; Instead of SAVE1 in CBLOOP
MLDVCT	EQU	CVTSUM	; Instead of SAVE1 in mul/div (1 byte only)
DIVQUO	RMB	2	; Instead of SAVE2 in DIV
MPLIER	EQU	DIVQUO	; Instead of SAVE2 in MULTIP
EVALPT	RMB	2	; Instead of SAVE3
CNVPTR	RMB	2	; Instead of SAVE4
VARADR	RMB	2	; Instead of SAVE6
OPRLIN	RMB	2	; Instead of SAVE7
EDTLIN	RMB	2	; Instead of SAVE8
INSPTR	RMB	2	; Instead of SAVE10 (maybe? Will some VTL programs want it back?)
SAVLIN	RMB	2	; Instead of SAVE11
SRC	RMB	2	; For copy routine
DST	RMB	2	; ditto
*
*	SET ASIDE FOUR BYTES FOR USER
*	DEFINED INTERUPT ROUTINE IF NEEDED
	ORG	$0200
* 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	$02F1
STACK	RMB	1
*
	ORG	$0300
MI	RMB	4	; INTERUPT VECTORS
NMI	RMB	4
PRGM	EQU	*	; PROGRAM STARTS HERE
* Must have some RAM here.
*
	ORG	$7800
*
* 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	LDS	#STACK	; S on 6800 is first free byte on stack.
	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.
PROBET	CPX	#COLD
	BLO	PROBE	; CPX on 6801 works right.
NOTRAM	DEX
	STX	STAR
START	LDS	#STACK	; re-initialize at beginning of each evaluate
	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.
	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
*
*	RECEIVER POLLING
POLCAT	LDAB	ACIACS
	ASRB
	RTS
*
*	INPUT ONE CHAR INTO B ACCUMULATOR
INCH	PSHA
	JSR	EINCH
	TAB
	PULA
	RTS
*
*	OUTPUT ONE CHAR 
OUTCH	PSHA
	TBA
	JSR	EOUTCH
	PULA
	RTS
*
	ORG COLD
*
	END