粘貼箱: vtl-2_6801_exorsim.asm

格式

Asm

Post date

2022-09-03 17:40

Publication Period

Unlimited

         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