mirror of
https://github.com/flowenol/applesoft-lite.git
synced 2024-09-15 11:55:13 +00:00
5564 lines
158 KiB
ArmAsm
5564 lines
158 KiB
ArmAsm
; Applesoft Lite
|
|
;
|
|
; Disassembled from the Apple II+ ROMs with da65 V2.12.0
|
|
;
|
|
; Most comments and label names from the S-C DocuMentor
|
|
; by Bob Sander-Cederlof
|
|
;
|
|
; Adapted for the Replica-1 by Tom Greene
|
|
; 7-May-2008
|
|
;
|
|
; Changed to support LOAD & SAVE via Apple-1 Serial Interface by Piotr Jaczewski
|
|
; 15-Jan-2021
|
|
;
|
|
|
|
.setcpu "6502"
|
|
.segment "BASIC"
|
|
|
|
.export FIX_LINKS, ERROR, INPUTBUFFER
|
|
.exportzp ERR_SYNTAX, ERR_NOSERIAL
|
|
|
|
.import CLS, OUTDO, CRDO, OUTSP, OUTQUES ; Imports from io.s
|
|
.import KEYBOARD, GETLN, RDKEY
|
|
|
|
.import SerialLoad, SerialSave, SerialMenu ; Imports from apple1serial.s
|
|
|
|
.include "macros.s"
|
|
.include "zeropage.s"
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
STACK := $0100
|
|
INPUTBUFFER := $0200
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; Applesoft Tokens
|
|
; ----------------------------------------------------------------------------
|
|
TOKEN_FOR = $81
|
|
TOKEN_DATA = $83
|
|
TOKEN_POP = $88
|
|
TOKEN_GOTO = $8E
|
|
TOKEN_GOSUB = $92
|
|
TOKEN_REM = $94
|
|
TOKEN_PRINT = $98
|
|
TOKEN_TO = $A2
|
|
TOKEN_SPC = $A3
|
|
TOKEN_THEN = $A4
|
|
TOKEN_NOT = $A5
|
|
TOKEN_STEP = $A6
|
|
TOKEN_PLUS = $A7
|
|
TOKEN_MINUS = $A8
|
|
TOKEN_GREATER = $AE
|
|
TOKEN_EQUAL = $AF
|
|
TOKEN_SGN = $B1
|
|
TOKEN_LEFTSTR = $BF
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; Cold and warm entry points at $E000 and E003
|
|
; ----------------------------------------------------------------------------
|
|
jmp COLDSTART
|
|
jmp RESTART
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; Branch Table for Tokens
|
|
; ----------------------------------------------------------------------------
|
|
TOKEN_ADDRESS_TABLE:
|
|
.addr END - 1 ; $80... 128... END
|
|
.addr FOR - 1 ; $81... 129... FOR
|
|
.addr NEXT - 1 ; $82... 130... NEXT
|
|
.addr DATA - 1 ; $83... 131... DATA
|
|
.addr INPUT - 1 ; $84... 132... INPUT
|
|
.addr DIM - 1 ; $85... 133... DIM
|
|
.addr READ - 1 ; $86... 134... READ
|
|
.addr CALL - 1 ; $87... 135... CALL
|
|
.addr POP - 1 ; $88... 136... POP
|
|
.addr HIMEM - 1 ; $89... 136... HIMEM:
|
|
.addr LOMEM - 1 ; $8A... 137... LOMEM:
|
|
.addr ONERR - 1 ; $8B... 138... ONERR
|
|
.addr RESUME - 1 ; $8C... 139... RESUME
|
|
.addr LET - 1 ; $8D... 140... LET
|
|
.addr GOTO - 1 ; $8E... 141... GOTO
|
|
.addr RUN - 1 ; $8F... 142... RUN
|
|
.addr IF - 1 ; $90... 143... IF
|
|
.addr RESTORE - 1 ; $91... 144... RESTORE
|
|
.addr GOSUB - 1 ; $92... 145... GOSUB
|
|
.addr POP - 1 ; $93... 146... RETURN
|
|
.addr REM - 1 ; $94... 147... REM
|
|
.addr STOP - 1 ; $95... 148... STOP
|
|
.addr ONGOTO - 1 ; $96... 149... ON
|
|
.addr POKE - 1 ; $97... 150... POKE
|
|
.addr PRINT - 1 ; $98... 151... PRINT
|
|
.addr CONT - 1 ; $99... 152... CONT
|
|
.addr LIST - 1 ; $9A... 153... LIST
|
|
.addr CLEAR - 1 ; $9B... 154... CLEAR
|
|
.addr GET - 1 ; $9C... 155... GET
|
|
.addr NEW - 1 ; $9D... 156... NEW
|
|
.addr SerialMenu - 1 ; $9E... 157... MENU
|
|
.addr SerialSave - 1 ; $9F... 158... SAVE
|
|
.addr SerialLoad - 1 ; $A0... 160... LOAD
|
|
.addr CLS - 1 ; $A1... 161... CLS
|
|
; ----------------------------------------------------------------------------
|
|
UNFNC: .addr SGN ; $B1... 177... SGN
|
|
.addr INT ; $B2... 178... INT
|
|
.addr ABS ; $B3... 179... ABS
|
|
.addr FRE ; $B4... 180... FRE
|
|
.addr SQR ; $B5... 181... SQR
|
|
.addr RND ; $B6... 182... RND
|
|
.addr LOG ; $B7... 183... LOG
|
|
.addr EXP ; $B8... 184... EXP
|
|
.addr PEEK ; $B9... 185... PEEK
|
|
.addr LEN ; $BA... 186... LEN
|
|
.addr STR ; $BB... 187... STR$
|
|
.addr VAL ; $BC... 188... VAL
|
|
.addr ASC ; $BD... 189... ASC
|
|
.addr CHRSTR ; $BE... 190... CHR$
|
|
.addr LEFTSTR ; $BF... 191... LEFT$
|
|
.addr RIGHTSTR ; $C0... 192... RIGHT$
|
|
.addr MIDSTR ; $C1... 193... MID$
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; Math Operator Branch Table
|
|
;
|
|
; one-byte precedence code
|
|
; two-byte address
|
|
; ----------------------------------------------------------------------------
|
|
POR = $46 ; "OR" is lowest precedence
|
|
PAND = $50
|
|
PREL = $64 ; Relational operators
|
|
PADD = $79 ; binary + and -
|
|
PMUL = $7B ; * and /
|
|
PPWR = $7D ; exponentiation
|
|
PNEQ = $7F ; unary - and comparison =
|
|
; ----------------------------------------------------------------------------
|
|
MATHTBL:.byte PADD
|
|
.addr FADDT - 1 ; $A7... 167... +
|
|
.byte PADD
|
|
.addr FSUBT - 1 ; $A8... 168... -
|
|
.byte PMUL
|
|
.addr FMULTT - 1 ; $A9... 169... *
|
|
.byte PMUL
|
|
.addr FDIVT - 1 ; $AA... 170... /
|
|
.byte PPWR
|
|
.addr FPWRT - 1 ; $AB... 171... ^
|
|
.byte PAND
|
|
.addr TAND - 1 ; $AC... 172... AND
|
|
.byte POR
|
|
.addr OR - 1 ; $AD... 173... OR
|
|
M_NEG: .byte PNEQ
|
|
.addr NEGOP - 1 ; $AE... 174... >
|
|
M_EQU: .byte PNEQ
|
|
.addr EQUOP - 1 ; $AF... 175... =
|
|
M_REL: .byte PREL
|
|
.addr RELOPS - 1 ; $B0... 176... <
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; Token Name Table
|
|
; ----------------------------------------------------------------------------
|
|
TOKEN_NAME_TABLE:
|
|
htasc "END" ; $80... 128
|
|
htasc "FOR" ; $81... 129
|
|
htasc "NEXT" ; $82... 130
|
|
htasc "DATA" ; $83... 131
|
|
htasc "INPUT" ; $84... 132
|
|
htasc "DIM" ; $85... 133
|
|
htasc "READ" ; $86... 134
|
|
htasc "CALL" ; $87... 135
|
|
htasc "POP" ; $88... 136
|
|
htasc "HIMEM:" ; $89... 137
|
|
htasc "LOMEM:" ; $8A... 138
|
|
htasc "ONERR" ; $8B... 139
|
|
htasc "RESUME" ; $8C... 140
|
|
htasc "LET" ; $8D... 141
|
|
htasc "GOTO" ; $8E... 142
|
|
htasc "RUN" ; $8F... 143
|
|
htasc "IF" ; $90... 144
|
|
htasc "RESTORE" ; $91... 145
|
|
htasc "GOSUB" ; $92... 146
|
|
htasc "RETURN" ; $93... 147
|
|
htasc "REM" ; $94... 148
|
|
htasc "STOP" ; $95... 149
|
|
htasc "ON" ; $96... 150
|
|
htasc "POKE" ; $97... 151
|
|
htasc "PRINT" ; $98... 152
|
|
htasc "CONT" ; $99... 153
|
|
htasc "LIST" ; $9A... 154
|
|
htasc "CLEAR" ; $9B... 155
|
|
htasc "GET" ; $9C... 156
|
|
htasc "NEW" ; $9D... 157
|
|
htasc "MENU" ; $9E... 158 New tokens
|
|
htasc "SAVE" ; $9F... 159 for
|
|
htasc "LOAD" ; $A0... 160 Apple-1 Serial I/O
|
|
htasc "CLS" ; $A1... 161 New token to clear screen
|
|
htasc "TO" ; $A2... 162
|
|
htasc "SPC(" ; $A3... 163
|
|
htasc "THEN" ; $A4... 164
|
|
htasc "NOT" ; $A5... 165
|
|
htasc "STEP" ; $A6... 166
|
|
htasc "+" ; $A7... 167
|
|
htasc "-" ; $A8... 168
|
|
htasc "*" ; $A9... 169
|
|
htasc "/" ; $AA... 170
|
|
htasc "^" ; $AB... 171
|
|
htasc "AND" ; $AC... 172
|
|
htasc "OR" ; $AD... 173
|
|
htasc ">" ; $AE... 174
|
|
htasc "=" ; $AF... 175
|
|
htasc "<" ; $B0... 176
|
|
htasc "SGN" ; $B1... 177
|
|
htasc "INT" ; $B2... 178
|
|
htasc "ABS" ; $B3... 179
|
|
htasc "FRE" ; $B4... 180
|
|
htasc "SQR" ; $B5... 181
|
|
htasc "RND" ; $B6... 182
|
|
htasc "LOG" ; $B7... 183
|
|
htasc "EXP" ; $B8... 184
|
|
htasc "PEEK" ; $B9... 185
|
|
htasc "LEN" ; $BA... 186
|
|
htasc "STR$" ; $BB... 187
|
|
htasc "VAL" ; $BC... 188
|
|
htasc "ASC" ; $BD... 189
|
|
htasc "CHR$" ; $BE... 190
|
|
htasc "LEFT$" ; $BF... 191
|
|
htasc "RIGHT$" ; $C0... 192
|
|
htasc "MID$" ; $C1... 193
|
|
.byte $00 ; END OF TOKEN NAME TABLE
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; Error Messages
|
|
; ----------------------------------------------------------------------------
|
|
ERROR_MESSAGES:
|
|
|
|
ERR_NOFOR := <(*-ERROR_MESSAGES)
|
|
htasc "NO FOR"
|
|
|
|
ERR_SYNTAX := <(*-ERROR_MESSAGES)
|
|
htasc "SYNTAX"
|
|
|
|
ERR_NOGOSUB := <(*-ERROR_MESSAGES)
|
|
htasc "NO GOSUB"
|
|
|
|
ERR_NODATA := <(*-ERROR_MESSAGES)
|
|
htasc "OUT OF DATA"
|
|
|
|
ERR_ILLQTY := <(*-ERROR_MESSAGES)
|
|
htasc "ILLEG QTY"
|
|
|
|
ERR_OVERFLOW := <(*-ERROR_MESSAGES)
|
|
htasc "OVERFLOW"
|
|
|
|
ERR_MEMFULL := <(*-ERROR_MESSAGES)
|
|
htasc "OUT OF MEM"
|
|
|
|
ERR_UNDEFSTAT := <(*-ERROR_MESSAGES)
|
|
htasc "UNDEF LINE"
|
|
|
|
ERR_BADSUBS := <(*-ERROR_MESSAGES)
|
|
htasc "BAD SUBSCR"
|
|
|
|
ERR_REDIMD := <(*-ERROR_MESSAGES)
|
|
htasc "REDIM"
|
|
|
|
ERR_ZERODIV := <(*-ERROR_MESSAGES)
|
|
htasc "DIV BY 0"
|
|
|
|
ERR_ILLDIR := <(*-ERROR_MESSAGES)
|
|
htasc "NOT DIRECT"
|
|
|
|
ERR_BADTYPE := <(*-ERROR_MESSAGES)
|
|
htasc "WRONG TYP"
|
|
|
|
ERR_STRLONG := <(*-ERROR_MESSAGES)
|
|
htasc "LONG STR"
|
|
|
|
ERR_FRMCPX := <(*-ERROR_MESSAGES)
|
|
htasc "LONG FORMULA"
|
|
|
|
ERR_CANTCONT := <(*-ERROR_MESSAGES)
|
|
htasc "CAN'T CONT"
|
|
|
|
ERR_NOSERIAL := <(*-ERROR_MESSAGES) ; New error message for Apple 1 Serial IO
|
|
htasc "NO SERIAL"
|
|
; ----------------------------------------------------------------------------
|
|
QT_ERROR:
|
|
.byte " ERR"
|
|
.byte $00
|
|
QT_IN: .byte " IN "
|
|
.byte $00
|
|
QT_BREAK:
|
|
.byte $0D
|
|
.byte "BREAK"
|
|
.byte $00
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CALLED BY "NEXT" AND "FOR" TO SCAN THROUGH
|
|
; THE STACK FOR A FRAME WITH THE SAME VARIABLE.
|
|
;
|
|
; (FORPNT) = ADDRESS OF VARIABLE IF "FOR" OR "NEXT"
|
|
; = $XXFF IF CALLED FROM "RETURN"
|
|
; <<< BUG: SHOULD BE $FFXX >>>
|
|
;
|
|
; RETURNS .NE. IF VARIABLE NOT FOUND,
|
|
; (X) = STACK PNTR AFTER SKIPPING ALL FRAMES
|
|
;
|
|
; .EQ. IF FOUND
|
|
; (X) = STACK PNTR OF FRAME FOUND
|
|
; ----------------------------------------------------------------------------
|
|
GTFORPNT:
|
|
tsx
|
|
inx
|
|
inx
|
|
inx
|
|
inx
|
|
@1: lda STACK+1,x ; "FOR" FRAME HERE?
|
|
cmp #TOKEN_FOR
|
|
bne @4 ; NO
|
|
lda FORPNT+1 ; YES -- "NEXT" WITH NO VARIABLE?
|
|
bne @2 ; NO, VARIABLE SPECIFIED
|
|
lda STACK+2,x ; YES, SO USE THIS FRAME
|
|
sta FORPNT
|
|
lda STACK+3,x
|
|
sta FORPNT+1
|
|
@2: cmp STACK+3,x ; IS VARIABLE IN THIS FRAME?
|
|
bne @3 ; NO
|
|
lda FORPNT ; LOOK AT 2ND BYTE TOO
|
|
cmp STACK+2,x ; SAME VARIABLE?
|
|
beq @4 ; YES
|
|
@3: txa ; NO, SO TRY NEXT FRAME (IF ANY)
|
|
clc ; 18 BYTES PER FRAME
|
|
adc #18
|
|
tax
|
|
bne @1 ; ...ALWAYS?
|
|
@4: rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; MOVE BLOCK OF MEMORY UP
|
|
;
|
|
; ON ENTRY:
|
|
; (Y,A) = (HIGHDS) = DESTINATION END+1
|
|
; (LOWTR) = LOWEST ADDRESS OF SOURCE
|
|
; (HIGHTR) = HIGHEST SOURCE ADDRESS+1
|
|
; ----------------------------------------------------------------------------
|
|
BLTU: jsr REASON ; BE SURE (Y,A) < FRETOP
|
|
sta STREND ; NEW TOP OF ARRAY STORAGE
|
|
sty STREND+1
|
|
BLTU2: sec
|
|
lda HIGHTR ; COMPUTE # OF BYTES TO BE MOVED
|
|
sbc LOWTR ; (FROM LOWTR THRU HIGHTR-1)
|
|
sta INDEX ; PARTIAL PAGE AMOUNT
|
|
tay
|
|
lda HIGHTR+1
|
|
sbc LOWTR+1
|
|
tax ; # OF WHOLE PAGES IN X-REG
|
|
inx
|
|
tya ; # BYTES IN PARTIAL PAGE
|
|
beq @4 ; NO PARTIAL PAGE
|
|
lda HIGHTR ; BACK UP HIGHTR # BYTES IN PARTIAL PAGE
|
|
sec
|
|
sbc INDEX
|
|
sta HIGHTR
|
|
bcs @1
|
|
dec HIGHTR+1
|
|
sec
|
|
@1: lda HIGHDS ; BACK UP HIGHDS # BYTES IN PARTIAL PAGE
|
|
sbc INDEX
|
|
sta HIGHDS
|
|
bcs @3
|
|
dec HIGHDS+1
|
|
bcc @3 ; ...ALWAYS
|
|
@2: lda (HIGHTR),y ; MOVE THE BYTES
|
|
sta (HIGHDS),y
|
|
@3: dey
|
|
bne @2 ; LOOP TO END OF THIS 256 BYTES
|
|
lda (HIGHTR),y ; MOVE ONE MORE BYTE
|
|
sta (HIGHDS),y
|
|
@4: dec HIGHTR+1 ; DOWN TO NEXT BLOCK OF 256
|
|
dec HIGHDS+1
|
|
dex ; ANOTHER BLOCK OF 256 TO MOVE?
|
|
bne @3 ; YES
|
|
rts ; NO, FINISHED
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CHECK IF ENOUGH ROOM LEFT ON STACK
|
|
; FOR "FOR", "GOSUB", OR EXPRESSION EVALUATION
|
|
; ----------------------------------------------------------------------------
|
|
CHKMEM: asl a
|
|
adc #54
|
|
bcs MEMERR ; ...MEM FULL ERR
|
|
sta INDEX
|
|
tsx
|
|
cpx INDEX
|
|
bcc MEMERR ; ...MEM FULL ERR
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CHECK IF ENOUGH ROOM BETWEEN ARRAYS AND STRINGS
|
|
; (Y,A) = ADDR ARRAYS NEED TO GROW TO
|
|
; ----------------------------------------------------------------------------
|
|
REASON: cpy FRETOP+1 ; HIGH BYTE
|
|
bcc @4 ; PLENTY OF ROOM
|
|
bne @1 ; NOT ENOUGH, TRY GARBAGE COLLECTION
|
|
cmp FRETOP ; LOW BYTE
|
|
bcc @4 ; ENOUGH ROOM
|
|
@1: pha ; SAVE (Y,A), TEMP1, AND TEMP2
|
|
ldx #FAC-TEMP1-1
|
|
tya
|
|
@2: pha
|
|
lda TEMP1,x
|
|
dex
|
|
bpl @2
|
|
jsr GARBAG ; MAKE AS MUCH ROOM AS POSSIBLE
|
|
ldx #TEMP1-FAC+1+256 ; RESTORE TEMP1 AND TEMP2
|
|
@3: pla ; AND (Y,A)
|
|
sta FAC,x
|
|
inx
|
|
bmi @3
|
|
pla
|
|
tay
|
|
pla ; DID WE FIND ENOUGH ROOM?
|
|
cpy FRETOP+1 ; HIGH BYTE
|
|
bcc @4 ; YES, AT LEAST A PAGE
|
|
bne MEMERR ; NO, MEM FULL ERR
|
|
cmp FRETOP ; LOW BYTE
|
|
bcs MEMERR ; NO, MEM FULL ERR
|
|
@4: rts ; YES, RETURN
|
|
|
|
; ----------------------------------------------------------------------------
|
|
MEMERR: ldx #ERR_MEMFULL
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; HANDLE AN ERROR
|
|
;
|
|
; (X)=OFFSET IN ERROR MESSAGE TABLE
|
|
; (ERRFLG) > 128 IF "ON ERR" TURNED ON
|
|
; (CURLIN+1) = $FF IF IN DIRECT MODE
|
|
; ----------------------------------------------------------------------------
|
|
ERROR: bit ERRFLG ; "ON ERR" TURNED ON?
|
|
bpl @1 ; NO
|
|
jmp HANDLERR ; YES
|
|
@1: jsr CRDO ; PRINT <RETURN>
|
|
jsr OUTQUES ; PRINT "?"
|
|
@2: lda ERROR_MESSAGES,x
|
|
pha ; PRINT MESSAGE
|
|
jsr OUTDO
|
|
inx
|
|
pla
|
|
bpl @2
|
|
jsr STKINI ; FIX STACK, ET AL
|
|
lda #<QT_ERROR ; PRINT " ERROR" AND BELL
|
|
ldy #>QT_ERROR
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PRINT STRING AT (Y,A)
|
|
; PRINT CURRENT LINE # UNLESS IN DIRECT MODE
|
|
; FALL INTO WARM RESTART
|
|
; ----------------------------------------------------------------------------
|
|
PRINT_ERROR_LINNUM:
|
|
jsr STROUT ; PRINT STRING AT (Y,A)
|
|
ldy CURLIN+1 ; RUNNING, OR DIRECT?
|
|
iny
|
|
beq RESTART ; WAS $FF, SO DIRECT MODE
|
|
jsr INPRT ; RUNNING, SO PRINT LINE NUMBER
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; WARM RESTART ENTRY
|
|
;
|
|
; COME HERE FROM MONITOR BY CTL-C, 0G, 3D0G, OR E003G
|
|
; ----------------------------------------------------------------------------
|
|
RESTART:
|
|
jsr CRDO ; PRINT <RETURN>
|
|
ldx #']' + $80 ; PROMPT CHARACTER
|
|
jsr INLIN2 ; READ A LINE
|
|
stx TXTPTR ; SET UP CHRGET TO SCAN THE LINE
|
|
sty TXTPTR+1
|
|
lsr ERRFLG ; CLEAR FLAG
|
|
jsr CHRGET
|
|
tax
|
|
beq RESTART ; EMPTY LINE
|
|
ldx #$FF ; $FF IN HI-BYTE OF CURLIN MEANS
|
|
stx CURLIN+1 ; WE ARE IN DIRECT MODE
|
|
bcc NUMBERED_LINE ; CHRGET SAW DIGIT, NUMBERED LINE
|
|
jsr PARSE_INPUT_LINE ; NO NUMBER, SO PARSE IT
|
|
jmp NEWSTT2 ; AND TRY EXECUTING IT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; HANDLE NUMBERED LINE
|
|
; ----------------------------------------------------------------------------
|
|
NUMBERED_LINE:
|
|
ldx PRGEND ; SQUASH VARIABLE TABLE
|
|
stx VARTAB
|
|
ldx PRGEND+1
|
|
stx VARTAB+1
|
|
jsr LINGET ; GET LINE #
|
|
jsr PARSE_INPUT_LINE ; AND PARSE THE INPUT LINE
|
|
sty EOLPNTR ; SAVE INDEX TO INPUT BUFFER
|
|
jsr FNDLIN ; IS THIS LINE # ALREADY IN PROGRAM?
|
|
bcc PUT_NEW_LINE ; NO
|
|
ldy #1 ; YES, SO DELETE IT
|
|
lda (LOWTR),y ; LOWTR POINTS AT LINE
|
|
sta INDEX+1 ; GET HIGH BYTE OF FORWARD PNTR
|
|
lda VARTAB
|
|
sta INDEX
|
|
lda LOWTR+1
|
|
sta DEST+1
|
|
lda LOWTR
|
|
dey
|
|
sbc (LOWTR),y
|
|
clc
|
|
adc VARTAB
|
|
sta VARTAB
|
|
sta DEST
|
|
lda VARTAB+1
|
|
adc #$FF
|
|
sta VARTAB+1
|
|
sbc LOWTR+1
|
|
tax
|
|
sec
|
|
lda LOWTR
|
|
sbc VARTAB
|
|
tay
|
|
bcs @1
|
|
inx
|
|
dec DEST+1
|
|
@1: clc
|
|
adc INDEX
|
|
bcc @2
|
|
dec INDEX+1
|
|
clc
|
|
; ----------------------------------------------------------------------------
|
|
@2: lda (INDEX),y ; MOVE HIGHER LINES OF PROGRAM
|
|
sta (DEST),y ; DOWN OVER THE DELETED LINE.
|
|
iny
|
|
bne @2
|
|
inc INDEX+1
|
|
inc DEST+1
|
|
dex
|
|
bne @2
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
PUT_NEW_LINE:
|
|
lda INPUTBUFFER ; ANY CHARACTERS AFTER LINE #?
|
|
beq FIX_LINKS ; NO, SO NOTHING TO INSERT.
|
|
lda MEMSIZ ; YES, SO MAKE ROOM AND INSERT LINE
|
|
ldy MEMSIZ+1 ; WIPE STRING AREA CLEAN
|
|
sta FRETOP
|
|
sty FRETOP+1
|
|
lda VARTAB ; SET UP BLTU SUBROUTINE
|
|
sta HIGHTR ; INSERT NEW LINE.
|
|
adc EOLPNTR
|
|
sta HIGHDS
|
|
ldy VARTAB+1
|
|
sty HIGHTR+1
|
|
bcc @1
|
|
iny
|
|
@1: sty HIGHDS+1
|
|
jsr BLTU ; MAKE ROOM FOR THE LINE
|
|
lda LINNUM ; PUT LINE NUMBER IN LINE IMAGE
|
|
ldy LINNUM+1
|
|
sta INPUTBUFFER-2
|
|
sty INPUTBUFFER-1
|
|
lda STREND
|
|
ldy STREND+1
|
|
sta VARTAB
|
|
sty VARTAB+1
|
|
ldy EOLPNTR
|
|
; ---COPY LINE INTO PROGRAM-------
|
|
@2: lda INPUTBUFFER-5,y
|
|
dey
|
|
sta (LOWTR),y
|
|
bne @2
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CLEAR ALL VARIABLES
|
|
; RE-ESTABLISH ALL FORWARD LINKS
|
|
; ----------------------------------------------------------------------------
|
|
FIX_LINKS:
|
|
jsr SETPTRS ; CLEAR ALL VARIABLES
|
|
lda TXTTAB ; POINT INDEX AT START OF PROGRAM
|
|
ldy TXTTAB+1
|
|
sta INDEX
|
|
sty INDEX+1
|
|
clc
|
|
@1: ldy #1 ; HI-BYTE OF NEXT FORWARD PNTR
|
|
lda (INDEX),y ; END OF PROGRAM YET?
|
|
bne @2 ; NO, KEEP GOING
|
|
lda VARTAB ; YES
|
|
sta PRGEND
|
|
lda VARTAB+1
|
|
sta PRGEND+1
|
|
jmp RESTART
|
|
@2: ldy #4 ; FIND END OF THIS LINE
|
|
@3: iny ; (NOTE MAXIMUM LENGTH < 256)
|
|
;lda #'C'
|
|
;jsr OUTDO
|
|
lda (INDEX),y
|
|
bne @3
|
|
iny ; COMPUTE ADDRESS OF NEXT LINE
|
|
tya
|
|
adc INDEX
|
|
tax
|
|
ldy #0 ; STORE FORWARD PNTR IN THIS LINE
|
|
sta (INDEX),y
|
|
lda INDEX+1
|
|
adc #0 ; (NOTE: THIS CLEARS CARRY)
|
|
iny
|
|
sta (INDEX),y
|
|
stx INDEX
|
|
sta INDEX+1
|
|
bcc @1 ; ...ALWAYS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; READ A LINE, AND STRIP OFF SIGN BITS
|
|
; ----------------------------------------------------------------------------
|
|
INLIN: ldx #$80 ; NULL PROMPT
|
|
INLIN2: stx PROMPT
|
|
jsr GETLN
|
|
cpx #239 ; MAXIMUM LINE LENGTH
|
|
bcc @1
|
|
ldx #239 ; TRUNCATE AT 239 CHARS
|
|
@1: lda #0 ; MARK END OF LINE WITH $00 BYTE
|
|
sta INPUTBUFFER,x
|
|
; txa
|
|
; beq @3 ; NULL INPUT LINE
|
|
;@2: lda INPUTBUFFER-1,x ; DROP SIGN BITS
|
|
; and #$7F ; already cleared by GETLN
|
|
; sta INPUTBUFFER-1,x
|
|
; dex
|
|
; bne @2
|
|
;@3: lda #0 ; (Y,X) POINTS AT BUFFER-1
|
|
ldx #<INPUTBUFFER-1+256
|
|
ldy #>INPUTBUFFER-1
|
|
rts
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; TOKENIZE THE INPUT LINE
|
|
; ----------------------------------------------------------------------------
|
|
PARSE_INPUT_LINE:
|
|
ldx TXTPTR ; INDEX INTO UNPARSED LINE
|
|
dex ; PREPARE FOR INX AT "PARSE"
|
|
ldy #4 ; INDEX TO PARSED OUTPUT LINE
|
|
sty DATAFLG ; CLEAR SIGN-BIT OF DATAFLG
|
|
bit LOCK ; IS THIS PROGRAM LOCKED?
|
|
bpl PARSE ; NO, GO AHEAD AND PARSE THE LINE
|
|
pla ; YES, IGNORE INPUT AND "RUN"
|
|
pla ; THE PROGRAM
|
|
jsr SETPTRS ; CLEAR ALL VARIABLES
|
|
jmp NEWSTT ; START RUNNING
|
|
; ----------------------------------------------------------------------------
|
|
PARSE: inx ; NEXT INPUT CHARACTER
|
|
@1: lda INPUTBUFFER,x
|
|
bit DATAFLG ; IN A "DATA" STATEMENT?
|
|
bvs @2 ; YES (DATAFLG = $49)
|
|
cmp #' ' ; IGNORE BLANKS
|
|
beq PARSE
|
|
@2: sta ENDCHR
|
|
cmp #'"' ; START OF QUOTATION?
|
|
beq @13
|
|
bvs @9 ; BRANCH IF IN "DATA" STATEMENT
|
|
cmp #'?' ; SHORTHAND FOR "PRINT"?
|
|
bne @3 ; NO
|
|
lda #TOKEN_PRINT ; YES, REPLACE WITH "PRINT" TOKEN
|
|
bne @9 ; ...ALWAYS
|
|
@3: cmp #'0' ; IS IT A DIGIT, COLON, OR SEMI-COLON?
|
|
bcc @4 ; NO, PUNCTUATION !"#$%&'()*+,-./
|
|
cmp #';'+1
|
|
bcc @9 ; YES, NOT A TOKEN
|
|
; ----------------------------------------------------------------------------
|
|
; SEARCH TOKEN NAME TABLE FOR MATCH STARTING
|
|
; WITH CURRENT CHAR FROM INPUT LINE
|
|
; ----------------------------------------------------------------------------
|
|
@4: sty STRNG2 ; SAVE INDEX TO OUTPUT LINE
|
|
lda #<(TOKEN_NAME_TABLE-$100)
|
|
sta FAC ; MAKE PNTR FOR SEARCH
|
|
lda #>(TOKEN_NAME_TABLE-$100)
|
|
sta FAC+1
|
|
ldy #0 ; USE Y-REG WITH (FAC) TO ADDRESS TABLE
|
|
sty TKNCNTR ; HOLDS CURRENT TOKEN-$80
|
|
dey ; PREPARE FOR "INY" A FEW LINES DOWN
|
|
stx TXTPTR ; SAVE POSITION IN INPUT LINE
|
|
dex ; PREPARE FOR "INX" A FEW LINES DOWN
|
|
@5: iny ; ADVANCE POINTER TO TOKEN TABLE
|
|
bne @6 ; Y=Y+1 IS ENOUGH
|
|
inc FAC+1 ; ALSO NEED TO BUMP THE PAGE
|
|
@6: inx ; ADVANCE POINTER TO INPUT LINE
|
|
@7: lda INPUTBUFFER,x ; NEXT CHAR FROM INPUT LINE
|
|
cmp #' ' ; THIS CHAR A BLANK?
|
|
beq @6 ; YES, IGNORE ALL BLANKS
|
|
sec ; NO, COMPARE TO CHAR IN TABLE
|
|
sbc (FAC),y ; SAME AS NEXT CHAR OF TOKEN NAME?
|
|
beq @5 ; YES, CONTINUE MATCHING
|
|
cmp #$80 ; MAYBE; WAS IT SAME EXCEPT FOR BIT 7?
|
|
bne @14 ; NO, SKIP TO NEXT TOKEN
|
|
ora TKNCNTR ; YES, END OF TOKEN; GET TOKEN #
|
|
; ----------------------------------------------------------------------------
|
|
; STORE CHARACTER OR TOKEN IN OUTPUT LINE
|
|
; ----------------------------------------------------------------------------
|
|
@8: ldy STRNG2 ; GET INDEX TO OUTPUT LINE IN Y-REG
|
|
@9: inx ; ADVANCE INPUT INDEX
|
|
iny ; ADVANCE OUTPUT INDEX
|
|
sta INPUTBUFFER-5,y ; STORE CHAR OR TOKEN
|
|
lda INPUTBUFFER-5,y ; TEST FOR EOL OR EOS
|
|
beq @17 ; END OF LINE
|
|
sec
|
|
sbc #':' ; END OF STATEMENT?
|
|
beq @10 ; YES, CLEAR DATAFLG
|
|
cmp #TOKEN_DATA-':' ; "DATA" TOKEN?
|
|
bne @11 ; NO, LEAVE DATAFLG ALONE
|
|
@10: sta DATAFLG ; DATAFLG = 0 OR $83-$3A = $49
|
|
@11: sec ; IS IT A "REM" TOKEN?
|
|
sbc #TOKEN_REM-':'
|
|
bne @1 ; NO, CONTINUE PARSING LINE
|
|
sta ENDCHR ; YES, CLEAR LITERAL FLAG
|
|
; ----------------------------------------------------------------------------
|
|
; HANDLE LITERAL (BETWEEN QUOTES) OR REMARK,
|
|
; BY COPYING CHARS UP TO ENDCHR.
|
|
; ----------------------------------------------------------------------------
|
|
@12: lda INPUTBUFFER,x
|
|
beq @9 ; END OF LINE
|
|
cmp ENDCHR
|
|
beq @9 ; FOUND ENDCHR
|
|
@13: iny ; NEXT OUTPUT CHAR
|
|
sta INPUTBUFFER-5,y
|
|
inx ; NEXT INPUT CHAR
|
|
bne @12 ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
; ADVANCE POINTER TO NEXT TOKEN NAME
|
|
; ----------------------------------------------------------------------------
|
|
@14: ldx TXTPTR ; GET POINTER TO INPUT LINE IN X-REG
|
|
inc TKNCNTR ; BUMP (TOKEN # - $80)
|
|
@15: lda (FAC),y ; SCAN THROUGH TABLE FOR BIT7 = 1
|
|
iny ; NEXT TOKEN ONE BEYOND THAT
|
|
bne @16 ; ...USUALLY ENOUGH TO BUMP Y-REG
|
|
inc FAC+1 ; NEXT SET OF 256 TOKEN CHARS
|
|
@16: asl a ; SEE IF SIGN BIT SET ON CHAR
|
|
bcc @15 ; NO, MORE IN THIS NAME
|
|
lda (FAC),y ; YES, AT NEXT NAME. END OF TABLE?
|
|
bne @7 ; NO, NOT END OF TABLE
|
|
lda INPUTBUFFER,x ; YES, SO NOT A KEYWORD
|
|
bpl @8 ; ...ALWAYS, COPY CHAR AS IS
|
|
; ---END OF LINE------------------
|
|
@17: sta INPUTBUFFER-3,y ; STORE ANOTHER 00 ON END
|
|
dec TXTPTR+1 ; SET TXTPTR = INPUTBUFFER-1
|
|
lda #<INPUTBUFFER-1+256
|
|
sta TXTPTR
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; SEARCH FOR LINE
|
|
;
|
|
; (LINNUM) = LINE # TO FIND
|
|
; IF NOT FOUND: CARRY = 0
|
|
; LOWTR POINTS AT NEXT LINE
|
|
; IF FOUND: CARRY = 1
|
|
; LOWTR POINTS AT LINE
|
|
; ----------------------------------------------------------------------------
|
|
FNDLIN: lda TXTTAB ; SEARCH FROM BEGINNING OF PROGRAM
|
|
ldx TXTTAB+1
|
|
FL1: ldy #1 ; SEARCH FROM (X,A)
|
|
sta LOWTR
|
|
stx LOWTR+1
|
|
lda (LOWTR),y
|
|
beq @3 ; END OF PROGRAM, AND NOT FOUND
|
|
iny
|
|
iny
|
|
lda LINNUM+1
|
|
cmp (LOWTR),y
|
|
bcc RTS1 ; IF NOT FOUND
|
|
beq @1
|
|
dey
|
|
bne @2
|
|
@1: lda LINNUM
|
|
dey
|
|
cmp (LOWTR),y
|
|
bcc RTS1 ; PAST LINE, NOT FOUND
|
|
beq RTS1 ; IF FOUND
|
|
@2: dey
|
|
lda (LOWTR),y
|
|
tax
|
|
dey
|
|
lda (LOWTR),y
|
|
bcs FL1 ; ALWAYS
|
|
@3: clc ; RETURN CARRY = 0
|
|
RTS1: rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "NEW" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
NEW: bne RTS1 ; IGNORE IF MORE TO THE STATEMENT
|
|
SCRTCH: lda #0
|
|
sta LOCK
|
|
tay
|
|
sta (TXTTAB),y
|
|
iny
|
|
sta (TXTTAB),y
|
|
lda TXTTAB
|
|
adc #2 ; (CARRY WASN'T CLEARED, SO "NEW" USUALLY
|
|
sta VARTAB ; ADDS 3, WHEREAS "FP" ADDS 2.)
|
|
sta PRGEND
|
|
lda TXTTAB+1
|
|
adc #0
|
|
sta VARTAB+1
|
|
sta PRGEND+1
|
|
; ----------------------------------------------------------------------------
|
|
SETPTRS:
|
|
jsr STXTPT ; SET TXTPTR TO TXTTAB - 1
|
|
lda #0 ; (THIS COULD HAVE BEEN ".byte $2C")
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "CLEAR" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
CLEAR: bne RTS2 ; IGNORE IF NOT AT END OF STATEMENT
|
|
CLEARC: lda MEMSIZ ; CLEAR STRING AREA
|
|
ldy MEMSIZ+1
|
|
sta FRETOP
|
|
sty FRETOP+1
|
|
lda VARTAB ; CLEAR ARRAY AREA
|
|
ldy VARTAB+1
|
|
sta ARYTAB
|
|
sty ARYTAB+1
|
|
sta STREND ; LOW END OF FREE SPACE
|
|
sty STREND+1
|
|
jsr RESTORE ; SET "DATA" POINTER TO BEGINNING
|
|
; ----------------------------------------------------------------------------
|
|
STKINI: ldx #TEMPST
|
|
stx TEMPPT
|
|
pla ; SAVE RETURN ADDRESS
|
|
tay
|
|
pla
|
|
ldx #$F8 ; START STACK AT $F8,
|
|
txs ; LEAVING ROOM FOR PARSING LINES
|
|
pha ; RESTORE RETURN ADDRESS
|
|
tya
|
|
pha
|
|
lda #0
|
|
sta OLDTEXT+1
|
|
sta SUBFLG
|
|
RTS2: rts
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; SET TXTPTR TO BEGINNING OF PROGRAM
|
|
; ----------------------------------------------------------------------------
|
|
STXTPT: clc ; TXTPTR = TXTTAB - 1
|
|
lda TXTTAB
|
|
adc #$FF
|
|
sta TXTPTR
|
|
lda TXTTAB+1
|
|
adc #$FF
|
|
sta TXTPTR+1
|
|
rts
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "LIST" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
LIST: bcc @1 ; NO LINE # SPECIFIED
|
|
beq @1 ; ---DITTO---
|
|
cmp #TOKEN_MINUS ; IF DASH OR COMMA, START AT LINE 0
|
|
beq @1 ; IT IS A DASH
|
|
cmp #',' ; COMMA?
|
|
bne RTS2 ; NO, ERROR
|
|
@1: jsr LINGET ; CONVERT LINE NUMBER IF ANY
|
|
jsr FNDLIN ; POINT LOWTR TO 1ST LINE
|
|
jsr CHRGOT ; RANGE SPECIFIED?
|
|
beq @3 ; NO
|
|
cmp #TOKEN_MINUS
|
|
beq @2
|
|
cmp #','
|
|
bne RTS1
|
|
@2: jsr CHRGET ; GET NEXT CHAR
|
|
jsr LINGET ; CONVERT SECOND LINE #
|
|
bne RTS2 ; BRANCH IF SYNTAX ERR
|
|
@3: pla ; POP RETURN ADRESS
|
|
pla ; (GET BACK BY "JMP NEWSTT")
|
|
lda LINNUM ; IF NO SECOND NUMBER, USE $FFFF
|
|
ora LINNUM+1
|
|
bne LIST0 ; THERE WAS A SECOND NUMBER
|
|
lda #$FF ; MAX END RANGE
|
|
sta LINNUM
|
|
sta LINNUM+1
|
|
LIST0: ldy #1
|
|
lda (LOWTR),y ; HIGH BYTE OF LINK
|
|
beq LIST3 ; END OF PROGRAM
|
|
jsr ISCNTC ; CHECK IF CONTROL-C HAS BEEN TYPED
|
|
jsr CRDO ; NO, PRINT <RETURN>
|
|
iny
|
|
lda (LOWTR),y ; GET LINE #, COMPARE WITH END RANGE
|
|
tax
|
|
iny
|
|
lda (LOWTR),y
|
|
cmp LINNUM+1
|
|
bne @5
|
|
cpx LINNUM
|
|
beq @6 ; ON LAST LINE OF RANGE
|
|
@5: bcs LIST3 ; FINISHED THE RANGE
|
|
; ---LIST ONE LINE----------------
|
|
@6: sty FORPNT
|
|
jsr LINPRT ; PRINT LINE # FROM X,A
|
|
lda #' ' ; PRINT SPACE AFTER LINE #
|
|
LIST1: ldy FORPNT
|
|
and #$7F
|
|
LIST2: jsr OUTDO
|
|
@1: iny
|
|
lda (LOWTR),y
|
|
bne LIST4 ; NOT END OF LINE YET
|
|
tay ; END OF LINE
|
|
lda (LOWTR),y ; GET LINK TO NEXT LINE
|
|
tax
|
|
iny
|
|
lda (LOWTR),y
|
|
stx LOWTR ; POINT TO NEXT LINE
|
|
sta LOWTR+1
|
|
bne LIST0 ; BRANCH IF NOT END OF PROGRAM
|
|
LIST3: jsr CRDO ; PRINT <RETURN>
|
|
jmp NEWSTT ; TO NEXT STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
GETCHR: iny ; PICK UP CHAR FROM TABLE
|
|
bne @1
|
|
inc FAC+1
|
|
@1: lda (FAC),y
|
|
rts
|
|
; ----------------------------------------------------------------------------
|
|
LIST4: bpl LIST2 ; BRANCH IF NOT A TOKEN
|
|
sec
|
|
sbc #$7F ; CONVERT TOKEN TO INDEX
|
|
tax
|
|
sty FORPNT ; SAVE LINE POINTER
|
|
ldy #<(TOKEN_NAME_TABLE-$100)
|
|
sty FAC ; POINT FAC TO TABLE
|
|
ldy #>(TOKEN_NAME_TABLE-$100)
|
|
sty FAC+1
|
|
ldy #$FF
|
|
@1: dex ; SKIP KEYWORDS UNTIL REACH THIS ONE
|
|
beq @3
|
|
@2: jsr GETCHR ; BUMP Y, GET CHAR FROM TABLE
|
|
bpl @2 ; NOT AT END OF KEYWORD YET
|
|
bmi @1 ; END OF KEYWORD, ALWAYS BRANCHES
|
|
@3: jsr OUTSP ; FOUND THE RIGHT KEYWORD, PRINT LEADING SPACE
|
|
@4: jsr GETCHR ; PRINT THE KEYWORD
|
|
bmi @5 ; LAST CHAR OF KEYWORD
|
|
jsr OUTDO
|
|
bne @4 ; ...ALWAYS
|
|
@5: jsr OUTDO ; PRINT LAST CHAR OF KEYWORD
|
|
lda #' ' ; PRINT TRAILING SPACE
|
|
bne LIST1 ; ...ALWAYS, BACK TO ACTUAL LINE
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "FOR" STATEMENT
|
|
;
|
|
; FOR PUSHES 18 BYTES ON THE STACK:
|
|
; 2 -- TXTPTR
|
|
; 2 -- LINE NUMBER
|
|
; 5 -- INITIAL (CURRENT) FOR VARIABLE VALUE
|
|
; 1 -- STEP SIGN
|
|
; 5 -- STEP VALUE
|
|
; 2 -- ADDRESS OF FOR VARIABLE IN VARTAB
|
|
; 1 -- FOR TOKEN ($81)
|
|
; ----------------------------------------------------------------------------
|
|
FOR: lda #$80
|
|
sta SUBFLG ; SUBSCRIPTS NOT ALLOWED
|
|
jsr LET ; DO <VAR> = <EXP>, STORE ADDR IN FORPNT
|
|
jsr GTFORPNT ; IS THIS FOR VARIABLE ACTIVE?
|
|
bne @1 ; NO
|
|
txa ; YES, CANCEL IT AND ENCLOSED LOOPS
|
|
adc #15 ; CARRY=1, THIS ADDS 16
|
|
tax ; X WAS ALREADY S+2
|
|
txs
|
|
@1: pla ; POP RETURN ADDRESS TOO
|
|
pla
|
|
lda #9 ; BE CERTAIN ENOUGH ROOM IN STACK
|
|
jsr CHKMEM
|
|
jsr DATAN ; SCAN AHEAD TO NEXT STATEMENT
|
|
clc ; PUSH STATEMENT ADDRESS ON STACK
|
|
tya
|
|
adc TXTPTR
|
|
pha
|
|
lda TXTPTR+1
|
|
adc #0
|
|
pha
|
|
lda CURLIN+1 ; PUSH LINE NUMBER ON STACK
|
|
pha
|
|
lda CURLIN
|
|
pha
|
|
lda #TOKEN_TO
|
|
jsr SYNCHR ; REQUIRE "TO"
|
|
jsr CHKNUM ; <VAR> = <EXP> MUST BE NUMERIC
|
|
jsr FRMNUM ; GET FINAL VALUE, MUST BE NUMERIC
|
|
lda FACSIGN ; PUT SIGN INTO VALUE IN FAC
|
|
ora #$7F
|
|
and FAC+1
|
|
sta FAC+1
|
|
lda #<STEP ; SET UP FOR RETURN
|
|
ldy #>STEP ; TO STEP
|
|
sta INDEX
|
|
sty INDEX+1
|
|
jmp FRM_STACK3 ; RETURNS BY "JMP (INDEX)"
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "STEP" PHRASE OF "FOR" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
STEP: lda #<CON_ONE ; STEP DEFAULT=1
|
|
ldy #>CON_ONE
|
|
jsr LOAD_FAC_FROM_YA
|
|
jsr CHRGOT
|
|
cmp #TOKEN_STEP
|
|
bne @1 ; USE DEFAULT VALUE OF 1.0
|
|
jsr CHRGET ; STEP SPECIFIED, GET IT
|
|
jsr FRMNUM
|
|
@1: jsr SIGN
|
|
jsr FRM_STACK2
|
|
lda FORPNT+1
|
|
pha
|
|
lda FORPNT
|
|
pha
|
|
lda #TOKEN_FOR
|
|
pha
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PERFORM NEXT STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
NEWSTT: tsx ; REMEMBER THE STACK POSITION
|
|
stx REMSTK
|
|
jsr ISCNTC ; SEE IF CONTROL-C HAS BEEN TYPED
|
|
lda TXTPTR ; NO, KEEP EXECUTING
|
|
ldy TXTPTR+1
|
|
ldx CURLIN+1 ; =$FF IF IN DIRECT MODE
|
|
inx ; $FF TURNS INTO $00
|
|
beq @1 ; IN DIRECT MODE
|
|
sta OLDTEXT ; IN RUNNING MODE
|
|
sty OLDTEXT+1
|
|
@1: ldy #0
|
|
lda (TXTPTR),y ; END OF LINE YET?
|
|
bne COLON ; NO
|
|
ldy #2 ; YES, SEE IF END OF PROGRAM
|
|
lda (TXTPTR),y
|
|
clc
|
|
beq GOEND ; YES, END OF PROGRAM
|
|
iny
|
|
lda (TXTPTR),y ; GET LINE # OF NEXT LINE
|
|
sta CURLIN
|
|
iny
|
|
lda (TXTPTR),y
|
|
sta CURLIN+1
|
|
tya ; ADJUST TXTPTR TO START
|
|
adc TXTPTR ; OF NEW LINE
|
|
sta TXTPTR
|
|
bcc @2
|
|
inc TXTPTR+1
|
|
@2:
|
|
NEWSTT2:
|
|
jsr CHRGET ; GET FIRST CHR OF STATEMENT
|
|
jsr EXECUTE_STATEMENT ; AND START PROCESSING
|
|
jmp NEWSTT ; BACK FOR MORE
|
|
; ----------------------------------------------------------------------------
|
|
GOEND: beq END4
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; EXECUTE A STATEMENT
|
|
;
|
|
; (A) IS FIRST CHAR OF STATEMENT
|
|
; CARRY IS SET
|
|
; ----------------------------------------------------------------------------
|
|
EXECUTE_STATEMENT:
|
|
beq RTS3 ; END OF LINE, NULL STATEMENT
|
|
EXECUTE_STATEMENT1:
|
|
sbc #$80 ; FIRST CHAR A TOKEN?
|
|
bcc @1 ; NOT TOKEN, MUST BE "LET"
|
|
cmp #$40 ; STATEMENT-TYPE TOKEN?
|
|
bcs SYNERR1 ; NO, SYNTAX ERROR
|
|
asl a ; DOUBLE TO GET INDEX
|
|
tay ; INTO ADDRESS TABLE
|
|
lda TOKEN_ADDRESS_TABLE+1,y
|
|
pha ; PUT ADDRESS ON STACK
|
|
lda TOKEN_ADDRESS_TABLE,y
|
|
pha
|
|
jmp CHRGET ; GET NEXT CHR & RTS TO ROUTINE
|
|
; ----------------------------------------------------------------------------
|
|
@1: jmp LET ; MUST BE <VAR> = <EXP>
|
|
; ----------------------------------------------------------------------------
|
|
COLON: cmp #':'
|
|
beq NEWSTT2
|
|
SYNERR1:
|
|
jmp SYNERR
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "RESTORE" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
RESTORE:
|
|
sec ; SET DATPTR TO BEGINNING OF PROGRAM
|
|
lda TXTTAB
|
|
sbc #1
|
|
ldy TXTTAB+1
|
|
bcs SETDA
|
|
dey
|
|
; ---SET DATPTR TO Y,A------------
|
|
SETDA: sta DATPTR
|
|
sty DATPTR+1
|
|
RTS3: rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; SEE IF CONTROL-C TYPED
|
|
; ----------------------------------------------------------------------------
|
|
ISCNTC: lda KEYBOARD
|
|
cmp #$83
|
|
beq @1
|
|
rts
|
|
@1: jsr RDKEY
|
|
CONTROL_C_TYPED:
|
|
ldx #$FF ; CONTROL C ATTEMPTED
|
|
bit ERRFLG ; "ON ERR" ENABLED?
|
|
bpl @2 ; NO
|
|
jmp HANDLERR ; YES, RETURN ERR CODE = 255
|
|
@2: cmp #3 ; SINCE IT IS CTRL-C, SET Z AND C BITS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "STOP" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
STOP: bcs END2 ; CARRY=1 TO FORCE PRINTING "BREAK AT.."
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "END" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
END: clc ; CARRY=0 TO AVOID PRINTING MESSAGE
|
|
END2: bne RTS4 ; IF NOT END OF STATEMENT, DO NOTHING
|
|
lda TXTPTR
|
|
ldy TXTPTR+1
|
|
ldx CURLIN+1
|
|
inx ; RUNNING?
|
|
beq @1 ; NO, DIRECT MODE
|
|
sta OLDTEXT
|
|
sty OLDTEXT+1
|
|
lda CURLIN
|
|
ldy CURLIN+1
|
|
sta OLDLIN
|
|
sty OLDLIN+1
|
|
@1: pla
|
|
pla
|
|
END4: lda #<QT_BREAK ; " BREAK"
|
|
ldy #>QT_BREAK
|
|
bcc @1
|
|
jmp PRINT_ERROR_LINNUM
|
|
@1: jmp RESTART
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "CONT" COMMAND
|
|
; ----------------------------------------------------------------------------
|
|
CONT: bne RTS4 ; IF NOT END OF STATEMENT, DO NOTHING
|
|
ldx #ERR_CANTCONT
|
|
ldy OLDTEXT+1 ; MEANINGFUL RE-ENTRY?
|
|
bne @1 ; YES
|
|
jmp ERROR ; NO
|
|
@1: lda OLDTEXT ; RESTORE TXTPTR
|
|
sta TXTPTR
|
|
sty TXTPTR+1
|
|
lda OLDLIN ; RESTORE LINE NUMBER
|
|
ldy OLDLIN+1
|
|
sta CURLIN
|
|
sty CURLIN+1
|
|
RTS4: rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "RUN" COMMAND
|
|
; ----------------------------------------------------------------------------
|
|
RUN: php ; SAVE STATUS WHILE SUBTRACTING
|
|
dec CURLIN+1 ; IF WAS $FF (MEANING DIRECT MODE) MAKE IT "RUNNING MODE"
|
|
plp ; GET STATUS AGAIN (FROM CHRGET)
|
|
bne @1 ; PROBABLY A LINE NUMBER
|
|
jmp SETPTRS ; START AT BEGINNING OF PROGRAM
|
|
@1: jsr CLEARC ; CLEAR VARIABLES
|
|
jmp GO_TO_LINE ; JOIN GOSUB STATEMENT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "GOSUB" STATEMENT
|
|
;
|
|
; LEAVES 7 BYTES ON STACK:
|
|
; 2 -- RETURN ADDRESS (NEWSTT)
|
|
; 2 -- TXTPTR
|
|
; 2 -- LINE #
|
|
; 1 -- GOSUB TOKEN
|
|
; ----------------------------------------------------------------------------
|
|
GOSUB: lda #3 ; BE SURE ENOUGH ROOM ON STACK
|
|
jsr CHKMEM
|
|
lda TXTPTR+1
|
|
pha
|
|
lda TXTPTR
|
|
pha
|
|
lda CURLIN+1
|
|
pha
|
|
lda CURLIN
|
|
pha
|
|
lda #TOKEN_GOSUB
|
|
pha
|
|
GO_TO_LINE:
|
|
jsr CHRGOT
|
|
jsr GOTO
|
|
jmp NEWSTT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "GOTO" STATEMENT
|
|
; ALSO USED BY "RUN" AND "GOSUB"
|
|
; ----------------------------------------------------------------------------
|
|
GOTO: jsr LINGET ; GET GOTO LINE
|
|
jsr REMN ; POINT Y TO EOL
|
|
lda CURLIN+1 ; IS CURRENT PAGE < GOTO PAGE?
|
|
cmp LINNUM+1
|
|
bcs @1 ; SEARCH FROM PROG START IF NOT
|
|
tya ; OTHERWISE SEARCH FROM NEXT LINE
|
|
sec
|
|
adc TXTPTR
|
|
ldx TXTPTR+1
|
|
bcc @2
|
|
inx
|
|
bcs @2
|
|
@1: lda TXTTAB ; GET PROGRAM BEGINNING
|
|
ldx TXTTAB+1
|
|
@2: jsr FL1 ; SEARCH FOR GOTO LINE
|
|
bcc UNDERR ; ERROR IF NOT THERE
|
|
lda LOWTR ; TXTPTR = START OF THE DESTINATION LINE
|
|
sbc #1
|
|
sta TXTPTR
|
|
lda LOWTR+1
|
|
sbc #0
|
|
sta TXTPTR+1
|
|
RTS5: rts ; RETURN TO NEWSTT OR GOSUB
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "POP" AND "RETURN" STATEMENTS
|
|
; ----------------------------------------------------------------------------
|
|
POP: bne RTS5
|
|
lda #$FF
|
|
sta FORPNT ; <<< BUG: SHOULD BE FORPNT+1 SEE "ALL ABOUT APPLESOFT", PAGES 100,101>>>
|
|
jsr GTFORPNT ; TO CANCEL FOR/NEXT IN SUB
|
|
txs
|
|
cmp #TOKEN_GOSUB ; LAST GOSUB FOUND?
|
|
beq RETURN
|
|
ldx #ERR_NOGOSUB
|
|
.byte $2C ; FAKE
|
|
UNDERR: ldx #ERR_UNDEFSTAT
|
|
jmp ERROR
|
|
; ----------------------------------------------------------------------------
|
|
SYNERR2:
|
|
jmp SYNERR
|
|
; ----------------------------------------------------------------------------
|
|
RETURN: pla ; DISCARD GOSUB TOKEN
|
|
pla
|
|
cpy #<(TOKEN_POP*2) ; BRANCH IF A POP
|
|
beq PULL3 ; PULL LINE #
|
|
sta CURLIN
|
|
pla
|
|
sta CURLIN+1
|
|
pla
|
|
sta TXTPTR ; PULL TXTPTR
|
|
pla
|
|
sta TXTPTR+1
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "DATA" STATEMENT
|
|
; EXECUTED BY SKIPPING TO NEXT COLON OR EOL
|
|
; ----------------------------------------------------------------------------
|
|
DATA: jsr DATAN ; MOVE TO NEXT STATEMENT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; ADD (Y) TO TXTPTR
|
|
; ----------------------------------------------------------------------------
|
|
ADDON: tya
|
|
clc
|
|
adc TXTPTR
|
|
sta TXTPTR
|
|
bcc @1
|
|
inc TXTPTR+1
|
|
@1:
|
|
RTS6: rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; SCAN AHEAD TO NEXT ":" OR EOL
|
|
; ----------------------------------------------------------------------------
|
|
DATAN: ldx #':' ; GET OFFSET IN Y TO EOL OR ":"
|
|
.byte $2C ; FAKE
|
|
; ----------------------------------------------------------------------------
|
|
REMN: ldx #0 ; TO EOL ONLY
|
|
stx CHARAC
|
|
ldy #0
|
|
sty ENDCHR
|
|
@1: lda ENDCHR ; TRICK TO COUNT QUOTE PARITY
|
|
ldx CHARAC
|
|
sta CHARAC
|
|
stx ENDCHR
|
|
@2: lda (TXTPTR),y
|
|
beq RTS6 ; END OF LINE
|
|
cmp ENDCHR
|
|
beq RTS6 ; COLON IF LOOKING FOR COLONS
|
|
iny
|
|
cmp #'"'
|
|
bne @2
|
|
beq @1 ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
PULL3: pla
|
|
pla
|
|
pla
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "IF" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
IF: jsr FRMEVL
|
|
jsr CHRGOT
|
|
cmp #TOKEN_GOTO
|
|
beq @1
|
|
lda #TOKEN_THEN
|
|
jsr SYNCHR
|
|
@1: lda FAC ; CONDITION TRUE OR FALSE?
|
|
bne IF_TRUE ; BRANCH IF TRUE
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "REM" STATEMENT, OR FALSE "IF" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
REM: jsr REMN ; SKIP REST OF LINE
|
|
beq ADDON ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
IF_TRUE:
|
|
jsr CHRGOT ; COMMAND OR NUMBER?
|
|
bcs @1 ; COMMAND
|
|
jmp GOTO ; NUMBER
|
|
@1: jmp EXECUTE_STATEMENT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "ON" STATEMENT
|
|
;
|
|
; ON <EXP> GOTO <LIST>
|
|
; ON <EXP> GOSUB <LIST>
|
|
; ----------------------------------------------------------------------------
|
|
ONGOTO: jsr GETBYT ; EVALUATE <EXP>, AS BYTE IN FAC+4
|
|
pha ; SAVE NEXT CHAR ON STACK
|
|
cmp #TOKEN_GOSUB
|
|
beq ON2
|
|
ON1: cmp #TOKEN_GOTO
|
|
bne SYNERR2
|
|
ON2: dec FAC+4 ; COUNTED TO RIGHT ONE YET?
|
|
bne @3 ; NO, KEEP LOOKING
|
|
pla ; YES, RETRIEVE CMD
|
|
jmp EXECUTE_STATEMENT1 ; AND GO.
|
|
@3: jsr CHRGET ; PRIME CONVERT SUBROUTINE
|
|
jsr LINGET ; CONVERT LINE #
|
|
cmp #',' ; TERMINATE WITH COMMA?
|
|
beq ON2 ; YES
|
|
pla ; NO, END OF LIST, SO IGNORE
|
|
RTS7: rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CONVERT LINE NUMBER
|
|
; ----------------------------------------------------------------------------
|
|
LINGET: ldx #0 ; ASC # TO HEX ADDRESS
|
|
stx LINNUM ; IN LINNUM.
|
|
stx LINNUM+1
|
|
@1: bcs RTS7 ; NOT A DIGIT
|
|
sbc #'0'-1 ; CONVERT DIGIT TO BINARY
|
|
sta CHARAC ; SAVE THE DIGIT
|
|
lda LINNUM+1 ; CHECK RANGE
|
|
sta INDEX
|
|
cmp #>6400 ; LINE # TOO LARGE?
|
|
bcs ON1 ; YES, > 63999, GO INDIRECTLY TO "SYNTAX ERROR".
|
|
lda LINNUM ; MULTIPLY BY TEN
|
|
asl a
|
|
rol INDEX
|
|
asl a
|
|
rol INDEX
|
|
adc LINNUM
|
|
sta LINNUM
|
|
lda INDEX
|
|
adc LINNUM+1
|
|
sta LINNUM+1
|
|
asl LINNUM
|
|
rol LINNUM+1
|
|
lda LINNUM
|
|
adc CHARAC ; ADD DIGIT
|
|
sta LINNUM
|
|
bcc @2
|
|
inc LINNUM+1
|
|
@2: jsr CHRGET ; GET NEXT CHAR
|
|
jmp @1 ; MORE CONVERTING
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "LET" STATEMENT
|
|
;
|
|
; LET <VAR> = <EXP>
|
|
; <VAR> = <EXP>
|
|
; ----------------------------------------------------------------------------
|
|
LET: jsr PTRGET ; GET <VAR>
|
|
sta FORPNT
|
|
sty FORPNT+1
|
|
lda #TOKEN_EQUAL
|
|
jsr SYNCHR
|
|
lda VALTYP+1 ; SAVE VARIABLE TYPE
|
|
pha
|
|
lda VALTYP
|
|
pha
|
|
jsr FRMEVL ; EVALUATE <EXP>
|
|
pla
|
|
rol a
|
|
jsr CHKVAL
|
|
bne LETSTRING
|
|
pla
|
|
; ----------------------------------------------------------------------------
|
|
LET2: bpl @1 ; REAL VARIABLE
|
|
jsr ROUND_FAC ; INTEGER VAR: ROUND TO 32 BITS
|
|
jsr AYINT ; TRUNCATE TO 16-BITS
|
|
ldy #0
|
|
lda FAC+3
|
|
sta (FORPNT),y
|
|
iny
|
|
lda FAC+4
|
|
sta (FORPNT),y
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; REAL VARIABLE = EXPRESSION
|
|
; ----------------------------------------------------------------------------
|
|
@1: jmp SETFOR
|
|
; ----------------------------------------------------------------------------
|
|
LETSTRING:
|
|
pla
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; INSTALL STRING, DESCRIPTOR ADDRESS IS AT FAC+3,4
|
|
; ----------------------------------------------------------------------------
|
|
PUTSTR: ldy #2 ; STRING DATA ALREADY IN STRING AREA?
|
|
lda (FAC+3),y ; (STRING AREA IS BTWN FRETOP
|
|
cmp FRETOP+1 ; HIMEM)
|
|
bcc @2 ; YES, DATA ALREADY UP THERE
|
|
bne @1 ; NO
|
|
dey ; MAYBE, TEST LOW BYTE OF POINTER
|
|
lda (FAC+3),y
|
|
cmp FRETOP
|
|
bcc @2 ; YES, ALREADY THERE
|
|
@1: ldy FAC+4 ; NO. DESCRIPTOR ALREADY AMONG VARIABLES?
|
|
cpy VARTAB+1
|
|
bcc @2 ; NO
|
|
bne @3 ; YES
|
|
lda FAC+3 ; MAYBE, COMPARE LO-BYTE
|
|
cmp VARTAB
|
|
bcs @3 ; YES, DESCRIPTOR IS AMONG VARIABLES
|
|
@2: lda FAC+3 ; EITHER STRING ALREADY ON TOP, OR
|
|
ldy FAC+4 ; DESCRIPTOR IS NOT A VARIABLE
|
|
jmp @4 ; SO JUST STORE THE DESCRIPTOR
|
|
; ----------------------------------------------------------------------------
|
|
; STRING NOT YET IN STRING AREA,
|
|
; AND DESCRIPTOR IS A VARIABLE
|
|
; ----------------------------------------------------------------------------
|
|
@3: ldy #0 ; POINT AT LENGTH IN DESCRIPTOR
|
|
lda (FAC+3),y ; GET LENGTH
|
|
jsr STRINI ; MAKE A STRING THAT LONG UP ABOVE
|
|
lda DSCPTR ; SET UP SOURCE PNTR FOR MONINS
|
|
ldy DSCPTR+1
|
|
sta STRNG1
|
|
sty STRNG1+1
|
|
jsr MOVINS ; MOVE STRING DATA TO NEW AREA
|
|
lda #<FAC ; ADDRESS OF DESCRIPTOR IS IN FAC
|
|
ldy #>FAC
|
|
@4: sta DSCPTR
|
|
sty DSCPTR+1
|
|
jsr FRETMS ; DISCARD DESCRIPTOR IF 'TWAS TEMPORARY
|
|
ldy #0 ; COPY STRING DESCRIPTOR
|
|
lda (DSCPTR),y
|
|
sta (FORPNT),y
|
|
iny
|
|
lda (DSCPTR),y
|
|
sta (FORPNT),y
|
|
iny
|
|
lda (DSCPTR),y
|
|
sta (FORPNT),y
|
|
RTS8: rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
PRSTRING:
|
|
jsr STRPRT
|
|
jsr CHRGOT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "PRINT" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
PRINT: beq GOCR ; NO MORE LIST, PRINT <RETURN>
|
|
; ----------------------------------------------------------------------------
|
|
PRINT2: beq RTS8 ; NO MORE LIST, DON'T PRINT <RETURN>
|
|
cmp #TOKEN_SPC
|
|
clc
|
|
beq PR_TAB_OR_SPC ; C=0 FOR SPC(
|
|
cmp #','
|
|
beq PR_NEXT_CHAR
|
|
cmp #';'
|
|
beq PR_NEXT_CHAR
|
|
jsr FRMEVL ; EVALUATE EXPRESSION
|
|
bit VALTYP ; STRING OR FP VALUE?
|
|
bmi PRSTRING ; STRING
|
|
jsr FOUT ; FP: CONVERT INTO BUFFER
|
|
jsr STRLIT ; MAKE BUFFER INTO STRING
|
|
jmp PRSTRING ; PRINT THE STRING
|
|
; ----------------------------------------------------------------------------
|
|
GOCR: jmp CRDO
|
|
|
|
; ----------------------------------------------------------------------------
|
|
PR_TAB_OR_SPC:
|
|
jsr GTBYTC ; GET VALUE
|
|
cmp #')' ; TRAILING PARENTHESIS
|
|
beq @2 ; GOOD
|
|
jmp SYNERR ; NO, SYNTAX ERROR
|
|
@2: inx
|
|
NXSPC: dex
|
|
bne DOSPC ; MORE SPACES TO PRINT
|
|
; ----------------------------------------------------------------------------
|
|
PR_NEXT_CHAR:
|
|
jsr CHRGET
|
|
jmp PRINT2 ; CONTINUE PARSING PRINT LIST
|
|
; ----------------------------------------------------------------------------
|
|
DOSPC: jsr OUTSP
|
|
bne NXSPC ; ...ALWAYS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PRINT STRING AT (Y,A)
|
|
; ----------------------------------------------------------------------------
|
|
STROUT: jsr STRLIT ; MAKE (Y,A) PRINTABLE
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PRINT STRING AT (FACMO,FACLO)
|
|
; ----------------------------------------------------------------------------
|
|
STRPRT: jsr FREFAC ; GET ADDRESS INTO INDEX, (A)=LENGTH
|
|
tax ; USE X-REG FOR COUNTER
|
|
ldy #0 ; USE Y-REG FOR SCANNER
|
|
inx
|
|
@1: dex
|
|
beq RTS8 ; FINISHED
|
|
lda (INDEX),y ; NEXT CHAR FROM STRING
|
|
jsr OUTDO ; PRINT THE CHAR
|
|
iny
|
|
jmp @1
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; INPUT CONVERSION ERROR: ILLEGAL CHARACTER
|
|
; IN NUMERIC FIELD. MUST DISTINGUISH
|
|
; BETWEEN INPUT, READ, AND GET
|
|
; ----------------------------------------------------------------------------
|
|
INPUTERR:
|
|
lda INPUTFLG
|
|
beq RESPERR ; TAKEN IF INPUT
|
|
bmi READERR ; TAKEN IF READ
|
|
ldy #$FF ; FROM A GET
|
|
bne ERLIN ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
READERR:
|
|
lda DATLIN ; TELL WHERE THE "DATA" IS, RATHER
|
|
ldy DATLIN+1 ; THAN THE "READ"
|
|
; ----------------------------------------------------------------------------
|
|
ERLIN: sta CURLIN
|
|
sty CURLIN+1
|
|
jmp SYNERR
|
|
; ----------------------------------------------------------------------------
|
|
INPERR: pla
|
|
; ----------------------------------------------------------------------------
|
|
RESPERR:
|
|
bit ERRFLG ; "ON ERR" TURNED ON?
|
|
bpl @1 ; NO, GIVE REENTRY A TRY
|
|
ldx #254 ; ERROR CODE = 254
|
|
jmp HANDLERR
|
|
@1: lda #<ERRREENTRY ; "?REENTER"
|
|
ldy #>ERRREENTRY
|
|
jsr STROUT
|
|
lda OLDTEXT ; RE-EXECUTE THE WHOLE INPUT STATEMENT
|
|
ldy OLDTEXT+1
|
|
sta TXTPTR
|
|
sty TXTPTR+1
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "GET" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
GET: jsr ERRDIR ; ILLEGAL IF IN DIRECT MODE
|
|
ldx #<(INPUTBUFFER+1) ; SIMULATE INPUT
|
|
ldy #>(INPUTBUFFER+1)
|
|
lda #0
|
|
sta INPUTBUFFER+1
|
|
lda #$40 ; SET UP INPUTFLG
|
|
jmp PROCESS_INPUT_LIST
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "INPUT" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
INPUT: cmp #'"' ; CHECK FOR OPTIONAL PROMPT STRING
|
|
bne @1 ; NO, PRINT "?" PROMPT
|
|
jsr STRTXT ; MAKE A PRINTABLE STRING OUT OF IT
|
|
lda #';' ; MUST HAVE ; NOW
|
|
jsr SYNCHR
|
|
jsr STRPRT ; PRINT THE STRING
|
|
jmp @2
|
|
@1: jsr OUTQUES ; NO STRING, PRINT "?"
|
|
@2: jsr ERRDIR ; ILLEGAL IF IN DIRECT MODE
|
|
lda #',' ; PRIME THE BUFFER
|
|
sta INPUTBUFFER-1
|
|
jsr INLIN
|
|
lda INPUTBUFFER
|
|
cmp #$03 ; CONTROL C?
|
|
bne INPUTFLAGZERO ; NO
|
|
jmp CONTROL_C_TYPED
|
|
; ----------------------------------------------------------------------------
|
|
NXIN: jsr OUTQUES ; PRINT "?"
|
|
jmp INLIN
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "READ" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
READ: ldx DATPTR ; Y,X POINTS AT NEXT DATA STATEMENT
|
|
ldy DATPTR+1
|
|
lda #$98 ; SET INPUTFLG = $98
|
|
.byte $2C ; TRICK TO PROCESS_INPUT_LIST
|
|
; ----------------------------------------------------------------------------
|
|
INPUTFLAGZERO:
|
|
lda #0 ; SET INPUTFLG = $00
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PROCESS INPUT LIST
|
|
;
|
|
; (Y,X) IS ADDRESS OF INPUT DATA STRING
|
|
; (A) = VALUE FOR INPUTFLG: $00 FOR INPUT
|
|
; $40 FOR GET
|
|
; $98 FOR READ
|
|
; ----------------------------------------------------------------------------
|
|
PROCESS_INPUT_LIST:
|
|
sta INPUTFLG
|
|
stx INPTR ; ADDRESS OF INPUT STRING
|
|
sty INPTR+1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
PROCESS_INPUT_ITEM:
|
|
jsr PTRGET ; GET ADDRESS OF VARIABLE
|
|
sta FORPNT
|
|
sty FORPNT+1
|
|
lda TXTPTR ; SAVE CURRENT TXTPTR,
|
|
ldy TXTPTR+1 ; WHICH POINTS INTO PROGRAM
|
|
sta TXPSV
|
|
sty TXPSV+1
|
|
ldx INPTR ; SET TXTPTR TO POINT AT INPUT BUFFER
|
|
ldy INPTR+1 ; OR "DATA" LINE
|
|
stx TXTPTR
|
|
sty TXTPTR+1
|
|
jsr CHRGOT ; GET CHAR AT PNTR
|
|
bne INSTART ; NOT END OF LINE OR COLON
|
|
bit INPUTFLG ; DOING A "GET"?
|
|
bvc @1 ; NO
|
|
jsr RDKEY ; YES, GET CHAR
|
|
sta INPUTBUFFER
|
|
ldx #<(INPUTBUFFER-1)
|
|
ldy #>(INPUTBUFFER-1)
|
|
bne @2 ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
@1: bmi FINDATA ; DOING A "READ"
|
|
jsr OUTQUES ; DOING AN "INPUT", PRINT "?"
|
|
jsr NXIN ; PRINT ANOTHER "?", AND INPUT A LINE
|
|
@2: stx TXTPTR
|
|
sty TXTPTR+1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
INSTART:
|
|
jsr CHRGET ; GET NEXT INPUT CHAR
|
|
bit VALTYP ; STRING OR NUMERIC?
|
|
bpl @5 ; NUMERIC
|
|
bit INPUTFLG ; STRING -- NOW WHAT INPUT TYPE?
|
|
bvc @1 ; NOT A "GET"
|
|
inx ; "GET"
|
|
stx TXTPTR
|
|
lda #0
|
|
sta CHARAC ; NO OTHER TERMINATORS THAN $00
|
|
beq @2 ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
@1: sta CHARAC
|
|
cmp #'"' ; TERMINATE ON $00 OR QUOTE
|
|
beq @3
|
|
lda #':' ; TERMINATE ON $00, COLON, OR COMMA
|
|
sta CHARAC
|
|
lda #','
|
|
@2: clc
|
|
@3: sta ENDCHR
|
|
lda TXTPTR
|
|
ldy TXTPTR+1
|
|
adc #0 ; SKIP OVER QUOTATION MARK, IF
|
|
bcc @4 ; THERE WAS ONE
|
|
iny
|
|
@4: jsr STRLT2 ; BUILD STRING STARTING AT (Y,A) TERMINATED BY $00, (CHARAC), OR (ENDCHR)
|
|
jsr POINT ; SET TXTPTR TO POINT AT STRING
|
|
jsr PUTSTR ; STORE STRING IN VARIABLE
|
|
jmp INPUT_MORE
|
|
; ----------------------------------------------------------------------------
|
|
@5: pha
|
|
lda INPUTBUFFER ; ANYTHING IN BUFFER?
|
|
beq INPFIN ; NO, SEE IF READ OR INPUT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
INPUT_DATA:
|
|
pla ; "READ"
|
|
jsr FIN ; GET FP NUMBER AT TXTPTR
|
|
lda VALTYP+1
|
|
jsr LET2 ; STORE RESULT IN VARIABLE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
INPUT_MORE:
|
|
jsr CHRGOT
|
|
beq @1 ; END OF LINE OR COLON
|
|
cmp #',' ; COMMA IN INPUT?
|
|
beq @1 ; YES
|
|
jmp INPUTERR ; NOTHING ELSE WILL DO
|
|
@1: lda TXTPTR ; SAVE POSITION IN INPUT BUFFER
|
|
ldy TXTPTR+1
|
|
sta INPTR
|
|
sty INPTR+1
|
|
lda TXPSV ; RESTORE PROGRAM POINTER
|
|
ldy TXPSV+1
|
|
sta TXTPTR
|
|
sty TXTPTR+1
|
|
jsr CHRGOT ; NEXT CHAR FROM PROGRAM
|
|
beq INPDONE ; END OF STATEMENT
|
|
jsr CHKCOM ; BETTER BE A COMMA THEN
|
|
jmp PROCESS_INPUT_ITEM
|
|
|
|
; ----------------------------------------------------------------------------
|
|
INPFIN: lda INPUTFLG ; "INPUT" OR "READ"
|
|
bne INPUT_DATA ; "READ"
|
|
jmp INPERR
|
|
|
|
; ----------------------------------------------------------------------------
|
|
FINDATA:
|
|
jsr DATAN ; GET OFFSET TO NEXT COLON OR EOL
|
|
iny ; TO FIRST CHAR OF NEXT LINE
|
|
tax ; WHICH: EOL OR COLON?
|
|
bne @1 ; COLON
|
|
ldx #ERR_NODATA ; EOL: MIGHT BE OUT OF DATA
|
|
iny ; CHECK HI-BYTE OF FORWARD PNTR
|
|
lda (TXTPTR),y ; END OF PROGRAM?
|
|
beq GERR ; YES, WE ARE OUT OF DATA
|
|
iny ; PICK UP THE LINE #
|
|
lda (TXTPTR),y
|
|
sta DATLIN
|
|
iny
|
|
lda (TXTPTR),y
|
|
iny ; POINT AT FIRST TEXT CHAR IN LINE
|
|
sta DATLIN+1
|
|
@1: lda (TXTPTR),y ; GET 1ST TOKEN OF STATEMENT
|
|
tax ; SAVE TOKEN IN X-REG
|
|
jsr ADDON ; ADD (Y) TO TXTPTR
|
|
cpx #TOKEN_DATA ; DID WE FIND A "DATA" STATEMENT?
|
|
bne FINDATA ; NOT YET
|
|
jmp INSTART ; YES, READ IT
|
|
; ---NO MORE INPUT REQUESTED------
|
|
INPDONE:
|
|
lda INPTR ; GET POINTER IN CASE IT WAS "READ"
|
|
ldy INPTR+1
|
|
ldx INPUTFLG ; "READ" OR "INPUT"?
|
|
bpl @1 ; "INPUT"
|
|
jmp SETDA ; "DATA", SO STORE (Y,X) AT DATPTR
|
|
@1: ldy #0 ; "INPUT": ANY MORE CHARS ON LINE?
|
|
lda (INPTR),y
|
|
beq @2 ; NO, ALL IS WELL
|
|
lda #<ERREXTRA ; YES, ERROR
|
|
ldy #>ERREXTRA ; "EXTRA IGNORED"
|
|
jmp STROUT
|
|
@2: rts
|
|
|
|
; ----------------------------------------------------------------------------
|
|
ERREXTRA:
|
|
.byte "?EXTRA IGNORED",$0D,$00
|
|
ERRREENTRY:
|
|
.byte "?REENTER",$0D,$00
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "NEXT" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
NEXT: bne NEXT1 ; VARIABLE AFTER "NEXT"
|
|
ldy #0 ; FLAG BY SETTING FORPNT+1 = 0
|
|
beq NEXT2 ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
NEXT1: jsr PTRGET ; GET PNTR TO VARIABLE IN (Y,A)
|
|
NEXT2: sta FORPNT
|
|
sty FORPNT+1
|
|
jsr GTFORPNT ; FIND FOR-FRAME FOR THIS VARIABLE
|
|
beq NEXT3 ; FOUND IT
|
|
ldx #ERR_NOFOR ; NOT THERE, ABORT
|
|
GERR: beq JERROR ; ...ALWAYS
|
|
NEXT3: txs ; SET STACK PTR TO POINT TO THIS FRAME,
|
|
inx ; WHICH TRIMS OFF ANY INNER LOOPS
|
|
inx
|
|
inx
|
|
inx
|
|
txa ; LOW BYTE OF ADRS OF STEP VALUE
|
|
inx
|
|
inx
|
|
inx
|
|
inx
|
|
inx
|
|
inx
|
|
stx DEST ; LOW BYTE ADRS OF FOR VAR VALUE
|
|
ldy #>STACK ; (Y,A) IS ADDRESS OF STEP VALUE
|
|
jsr LOAD_FAC_FROM_YA ; STEP TO FAC
|
|
tsx
|
|
lda STACK+9,x
|
|
sta FACSIGN
|
|
lda FORPNT
|
|
ldy FORPNT+1
|
|
jsr FADD ; ADD TO FOR VALUE
|
|
jsr SETFOR ; PUT NEW VALUE BACK
|
|
ldy #>STACK ; (Y,A) IS ADDRESS OF END VALUE
|
|
jsr FCOMP2 ; COMPARE TO END VALUE
|
|
tsx
|
|
sec
|
|
sbc STACK+9,x ; SIGN OF STEP
|
|
beq @2 ; BRANCH IF FOR COMPLETE
|
|
lda STACK+15,x ; OTHERWISE SET UP
|
|
sta CURLIN ; FOR LINE #
|
|
lda STACK+16,x
|
|
sta CURLIN+1
|
|
lda STACK+18,x ; AND SET TXTPTR TO JUST
|
|
sta TXTPTR ; AFTER FOR STATEMENT
|
|
lda STACK+17,x
|
|
sta TXTPTR+1
|
|
@1: jmp NEWSTT
|
|
@2: txa ; POP OFF FOR-FRAME, LOOP IS DONE
|
|
adc #17 ; CARRY IS SET, SO ADDS 18
|
|
tax
|
|
txs
|
|
jsr CHRGOT ; CHAR AFTER VARIABLE
|
|
cmp #',' ; ANOTHER VARIABLE IN NEXT?
|
|
bne @1 ; NO, GO TO NEXT STATEMENT
|
|
jsr CHRGET ; YES, PRIME FOR NEXT VARIABLE
|
|
jsr NEXT1 ; (DOES NOT RETURN)
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; EVALUATE EXPRESSION, MAKE SURE IT IS NUMERIC
|
|
; ----------------------------------------------------------------------------
|
|
FRMNUM: jsr FRMEVL
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; MAKE SURE (FAC) IS NUMERIC
|
|
; ----------------------------------------------------------------------------
|
|
CHKNUM: clc
|
|
.byte $24 ; DUMMY FOR SKIP
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; MAKE SURE (FAC) IS STRING
|
|
; ----------------------------------------------------------------------------
|
|
CHKSTR: sec
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; MAKE SURE (FAC) IS CORRECT TYPE
|
|
; IF C=0, TYPE MUST BE NUMERIC
|
|
; IF C=1, TYPE MUST BE STRING
|
|
; ----------------------------------------------------------------------------
|
|
CHKVAL: bit VALTYP ; $00 IF NUMERIC, $FF IF STRING
|
|
bmi @2 ; TYPE IS STRING
|
|
bcs @3 ; NOT STRING, BUT WE NEED STRING
|
|
@1: rts ; TYPE IS CORRECT
|
|
@2: bcs @1 ; IS STRING AND WE WANTED STRING
|
|
@3: ldx #ERR_BADTYPE ; TYPE MISMATCH
|
|
JERROR: jmp ERROR
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; EVALUATE THE EXPRESSION AT TXTPTR, LEAVING THE
|
|
; RESULT IN FAC. WORKS FOR BOTH STRING AND NUMERIC
|
|
; EXPRESSIONS.
|
|
; ----------------------------------------------------------------------------
|
|
FRMEVL: ldx TXTPTR ; DECREMENT TXTPTR
|
|
bne @1
|
|
dec TXTPTR+1
|
|
@1: dec TXTPTR
|
|
ldx #0 ; START WITH PRECEDENCE = 0
|
|
.byte $24 ; TRICK TO SKIP FOLLOWING "PHA"
|
|
; ----------------------------------------------------------------------------
|
|
FRMEVL1:
|
|
pha ; PUSH RELOPS FLAGS
|
|
txa
|
|
pha ; SAVE LAST PRECEDENCE
|
|
lda #1
|
|
jsr CHKMEM ; CHECK IF ENOUGH ROOM ON STACK
|
|
jsr FRM_ELEMENT ; GET AN ELEMENT
|
|
lda #0
|
|
sta CPRTYP ; CLEAR COMPARISON OPERATOR FLAGS
|
|
; ----------------------------------------------------------------------------
|
|
FRMEVL2:
|
|
jsr CHRGOT ; CHECK FOR RELATIONAL OPERATORS
|
|
@1: sec ; > IS $AE, = IS $AF, < IS $B0
|
|
sbc #TOKEN_GREATER ; > IS 0, = IS 1, < IS 2
|
|
bcc @2 ; NOT RELATIONAL OPERATOR
|
|
cmp #3
|
|
bcs @2 ; NOT RELATIONAL OPERATOR
|
|
cmp #1 ; SET CARRY IF "=" OR "<"
|
|
rol a ; NOW > IS 0, = IS 3, < IS 5
|
|
eor #1 ; NOW > IS 1, = IS 2, < IS 4
|
|
eor CPRTYP ; SET BITS OF CPRTYP: 00000<=>
|
|
cmp CPRTYP ; CHECK FOR ILLEGAL COMBINATIONS
|
|
bcc SNTXERR ; IF LESS THAN, A RELOP WAS REPEATED
|
|
sta CPRTYP
|
|
jsr CHRGET ; ANOTHER OPERATOR?
|
|
jmp @1 ; CHECK FOR <,=,> AGAIN
|
|
; ----------------------------------------------------------------------------
|
|
@2: ldx CPRTYP ; DID WE FIND A RELATIONAL OPERATOR?
|
|
bne FRM_RELATIONAL ; YES
|
|
bcs NOTMATH ; NO, AND NEXT TOKEN IS > $D1
|
|
adc #TOKEN_GREATER-TOKEN_PLUS ; NO, AND NEXT TOKEN < $CF
|
|
bcc NOTMATH ; IF NEXT TOKEN < "+"
|
|
adc VALTYP ; + AND LAST RESULT A STRING?
|
|
bne @3 ; BRANCH IF NOT
|
|
jmp CAT ; CONCATENATE IF SO.
|
|
; ----------------------------------------------------------------------------
|
|
@3: adc #$FF ; +-*/ IS 0123
|
|
sta INDEX
|
|
asl a ; MULTIPLY BY 3
|
|
adc INDEX ; +-*/ IS 0,3,6,9
|
|
tay
|
|
|
|
; ----------------------------------------------------------------------------
|
|
FRM_PRECEDENCE_TEST:
|
|
pla ; GET LAST PRECEDENCE
|
|
cmp MATHTBL,y
|
|
bcs FRM_PERFORM1 ; DO NOW IF HIGHER PRECEDENCE
|
|
jsr CHKNUM ; WAS LAST RESULT A #?
|
|
NXOP: pha ; YES, SAVE PRECEDENCE ON STACK
|
|
SAVOP: jsr FRM_RECURSE ; SAVE REST, CALL FRMEVL RECURSIVELY
|
|
pla
|
|
ldy LASTOP
|
|
bpl PREFNC
|
|
tax
|
|
beq GOEX ; EXIT IF NO MATH IN EXPRESSION
|
|
bne FRM_PERFORM2 ; ...ALWAYS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; FOUND ONE OR MORE RELATIONAL OPERATORS <,=,>
|
|
; ----------------------------------------------------------------------------
|
|
FRM_RELATIONAL:
|
|
lsr VALTYP ; (VALTYP) = 0 (NUMERIC), = $FF (STRING)
|
|
txa ; SET CPRTYP TO 0000<=>C
|
|
rol a ; WHERE C=0 IF #, C=1 IF STRING
|
|
ldx TXTPTR ; BACK UP TXTPTR
|
|
bne @1
|
|
dec TXTPTR+1
|
|
@1: dec TXTPTR
|
|
ldy #M_REL-MATHTBL ; POINT AT RELOPS ENTRY
|
|
sta CPRTYP
|
|
bne FRM_PRECEDENCE_TEST ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
PREFNC: cmp MATHTBL,y
|
|
bcs FRM_PERFORM2 ; DO NOW IF HIGHER PRECEDENCE
|
|
bcc NXOP ; ...ALWAYS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; STACK THIS OPERATION AND CALL FRMEVL FOR
|
|
; ANOTHER ONE
|
|
; ----------------------------------------------------------------------------
|
|
FRM_RECURSE:
|
|
lda MATHTBL+2,y
|
|
pha ; PUSH ADDRESS OF OPERATION PERFORMER
|
|
lda MATHTBL+1,y
|
|
pha
|
|
jsr FRM_STACK1 ; STACK FAC.SIGN AND FAC
|
|
lda CPRTYP ; A=RELOP FLAGS, X=PRECEDENCE BYTE
|
|
jmp FRMEVL1 ; RECURSIVELY CALL FRMEVL
|
|
; ----------------------------------------------------------------------------
|
|
SNTXERR:
|
|
jmp SYNERR
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; STACK (FAC)
|
|
; THREE ENTRY POINTS:
|
|
; 1, FROM FRMEVL
|
|
; 2, FROM "STEP"
|
|
; 3, FROM "FOR"
|
|
; ----------------------------------------------------------------------------
|
|
FRM_STACK1:
|
|
lda FACSIGN ; GET FAC.SIGN TO PUSH IT
|
|
ldx MATHTBL,y ; PRECEDENCE BYTE FROM MATHTBL
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; ENTER HERE FROM "STEP", TO PUSH STEP SIGN AND VALUE
|
|
; ----------------------------------------------------------------------------
|
|
FRM_STACK2:
|
|
tay ; FAC.SIGN OR SGN(STEP VALUE)
|
|
pla ; PULL RETURN ADDRESS AND ADD 1
|
|
sta INDEX ; <<< ASSUMES NOT ON PAGE BOUNDARY! >>>
|
|
inc INDEX ; PLACE BUMPED RETURN ADDRESS IN
|
|
pla ; INDEX,INDEX+1
|
|
sta INDEX+1
|
|
tya ; FAC.SIGN OR SGN(STEP VALUE)
|
|
pha ; PUSH FAC.SIGN OR SGN(STEP VALUE)
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; ENTER HERE FROM "FOR", WITH (INDEX) = STEP,
|
|
; TO PUSH INITIAL VALUE OF "FOR" VARIABLE
|
|
; ----------------------------------------------------------------------------
|
|
FRM_STACK3:
|
|
jsr ROUND_FAC ; ROUND TO 32 BITS
|
|
lda FAC+4 ; PUSH (FAC)
|
|
pha
|
|
lda FAC+3
|
|
pha
|
|
lda FAC+2
|
|
pha
|
|
lda FAC+1
|
|
pha
|
|
lda FAC
|
|
pha
|
|
jmp (INDEX) ; DO RTS FUNNY WAY
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
NOTMATH:
|
|
ldy #$FF ; SET UP TO EXIT ROUTINE
|
|
pla
|
|
GOEX: beq EXIT ; EXIT IF NO MATH TO DO
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PERFORM STACKED OPERATION
|
|
;
|
|
; (A) = PRECEDENCE BYTE
|
|
; STACK: 1 -- CPRMASK
|
|
; 5 -- (ARG)
|
|
; 2 -- ADDR OF PERFORMER
|
|
; ----------------------------------------------------------------------------
|
|
FRM_PERFORM1:
|
|
cmp #PREL ; WAS IT RELATIONAL OPERATOR?
|
|
beq @1 ; YES, ALLOW STRING COMPARE
|
|
jsr CHKNUM ; MUST BE NUMERIC VALUE
|
|
@1: sty LASTOP
|
|
FRM_PERFORM2:
|
|
pla ; GET 0000<=>C FROM STACK
|
|
lsr a ; SHIFT TO 00000<=> FORM
|
|
sta CPRMASK ; 00000<=>
|
|
pla
|
|
sta ARG ; GET FLOATING POINT VALUE OFF STACK,
|
|
pla ; AND PUT IT IN ARG
|
|
sta ARG+1
|
|
pla
|
|
sta ARG+2
|
|
pla
|
|
sta ARG+3
|
|
pla
|
|
sta ARG+4
|
|
pla
|
|
sta ARG+5
|
|
eor FACSIGN ; SAVE EOR OF SIGNS OF THE OPERANDS,
|
|
sta SGNCPR ; IN CASE OF MULTIPLY OR DIVIDE
|
|
EXIT: lda FAC ; FAC EXPONENT IN A-REG / STATUS .EQ. IF (FAC)=0
|
|
rts ; RTS GOES TO PERFORM OPERATION
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; GET ELEMENT IN EXPRESSION
|
|
;
|
|
; GET VALUE OF VARIABLE OR NUMBER AT TXTPNT, OR POINT
|
|
; TO STRING DESCRIPTOR IF A STRING, AND PUT IN FAC.
|
|
; ----------------------------------------------------------------------------
|
|
FRM_ELEMENT:
|
|
lda #0 ; ASSUME NUMERIC
|
|
sta VALTYP
|
|
@1: jsr CHRGET
|
|
bcs @3 ; NOT A DIGIT
|
|
@2: jmp FIN ; NUMERIC CONSTANT
|
|
@3: jsr ISLETC ; VARIABLE NAME?
|
|
bcs FRM_VARIABLE ; YES
|
|
cmp #'.' ; DECIMAL POINT
|
|
beq @2 ; YES, NUMERIC CONSTANT
|
|
cmp #TOKEN_MINUS ; UNARY MINUS?
|
|
beq MIN ; YES
|
|
cmp #TOKEN_PLUS ; UNARY PLUS
|
|
beq @1 ; YES
|
|
cmp #'"' ; STRING CONSTANT?
|
|
bne NOT_ ; NO
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; STRING CONSTANT ELEMENT
|
|
;
|
|
; SET Y,A = (TXTPTR)+CARRY
|
|
; ----------------------------------------------------------------------------
|
|
STRTXT: lda TXTPTR ; ADD (CARRY) TO GET ADDRESS OF 1ST CHAR
|
|
ldy TXTPTR+1 ; OF STRING IN Y,A
|
|
adc #0
|
|
bcc @1
|
|
iny
|
|
@1: jsr STRLIT ; BUILD DESCRIPTOR TO STRING / GET ADDRESS OF DESCRIPTOR IN FAC
|
|
jmp POINT ; POINT TXTPTR AFTER TRAILING QUOTE
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "NOT" FUNCTION
|
|
; IF FAC=0, RETURN FAC=1
|
|
; IF FAC<>0, RETURN FAC=0
|
|
; ----------------------------------------------------------------------------
|
|
NOT_: cmp #TOKEN_NOT
|
|
bne SGN_ ; NOT "NOT", TRY "SGN"
|
|
ldy #M_EQU-MATHTBL ; POINT AT = COMPARISON
|
|
bne EQUL ; ...ALWAYS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; COMPARISON FOR EQUALITY (= OPERATOR)
|
|
; ALSO USED TO EVALUATE "NOT" FUNCTION
|
|
; ----------------------------------------------------------------------------
|
|
EQUOP: lda FAC ; SET "TRUE" IF (FAC) = ZERO
|
|
bne @1 ; FALSE
|
|
ldy #1 ; TRUE
|
|
.byte $2C ; TRICK TO SKIP NEXT 2 BYTES
|
|
@1: ldy #0 ; FALSE
|
|
jmp SNGFLT
|
|
; ----------------------------------------------------------------------------
|
|
SGN_: cmp #TOKEN_SGN
|
|
bcc PARCHK
|
|
jmp UNARY
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; EVALUATE "(EXPRESSION)"
|
|
; ----------------------------------------------------------------------------
|
|
PARCHK: jsr CHKOPN ; IS THERE A '(' AT TXTPTR?
|
|
jsr FRMEVL ; YES, EVALUATE EXPRESSION
|
|
; ----------------------------------------------------------------------------
|
|
CHKCLS: lda #')' ; CHECK FOR ')'
|
|
.byte $2C ; TRICK
|
|
; ----------------------------------------------------------------------------
|
|
CHKOPN: lda #'('
|
|
.byte $2C ; TRICK
|
|
; ----------------------------------------------------------------------------
|
|
CHKCOM: lda #',' ; COMMA AT TXTPTR?
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; UNLESS CHAR AT TXTPTR = (A), SYNTAX ERROR
|
|
; ----------------------------------------------------------------------------
|
|
SYNCHR: ldy #0
|
|
cmp (TXTPTR),y
|
|
bne SYNERR
|
|
jmp CHRGET ; MATCH, GET NEXT CHAR & RETURN
|
|
; ----------------------------------------------------------------------------
|
|
SYNERR: ldx #ERR_SYNTAX
|
|
jmp ERROR
|
|
; ----------------------------------------------------------------------------
|
|
MIN: ldy #M_NEG-MATHTBL ; POINT AT UNARY MINUS
|
|
EQUL: pla
|
|
pla
|
|
jmp SAVOP
|
|
; ----------------------------------------------------------------------------
|
|
FRM_VARIABLE:
|
|
jsr PTRGET
|
|
FRM_VARIABLE_CALL = *-1 ; SO PTRGET CAN TELL WE CALLED
|
|
sta VPNT ; ADDRESS OF VARIABLE
|
|
sty VPNT+1
|
|
ldx VALTYP ; NUMERIC OR STRING?
|
|
beq @1 ; NUMERIC
|
|
ldx #0 ; STRING
|
|
stx STRNG1+1
|
|
rts
|
|
@1: ldx VALTYP+1 ; NUMERIC, WHICH TYPE?
|
|
bpl @2 ; FLOATING POINT
|
|
ldy #0 ; INTEGER
|
|
lda (VPNT),y
|
|
tax ; GET VALUE IN A,Y
|
|
iny
|
|
lda (VPNT),y
|
|
tay
|
|
txa
|
|
jmp GIVAYF ; CONVERT A,Y TO FLOATING POINT
|
|
@2: jmp LOAD_FAC_FROM_YA
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
UNARY: asl a ; DOUBLE TOKEN TO GET INDEX
|
|
pha
|
|
tax
|
|
jsr CHRGET
|
|
cpx #<(TOKEN_LEFTSTR*2-1) ; LEFT$, RIGHT$, AND MID$
|
|
bcc @1 ; NOT ONE OF THE STRING FUNCTIONS
|
|
jsr CHKOPN ; STRING FUNCTION, NEED "("
|
|
jsr FRMEVL ; EVALUATE EXPRESSION FOR STRING
|
|
jsr CHKCOM ; REQUIRE A COMMA
|
|
jsr CHKSTR ; MAKE SURE EXPRESSION IS A STRING
|
|
pla
|
|
tax ; RETRIEVE ROUTINE POINTER
|
|
lda VPNT+1 ; STACK ADDRESS OF STRING
|
|
pha
|
|
lda VPNT
|
|
pha
|
|
txa
|
|
pha ; STACK DOUBLED TOKEN
|
|
jsr GETBYT ; CONVERT NEXT EXPRESSION TO BYTE IN X-REG
|
|
pla ; GET DOUBLED TOKEN OFF STACK
|
|
tay ; USE AS INDEX TO BRANCH
|
|
txa ; VALUE OF SECOND PARAMETER
|
|
pha ; PUSH 2ND PARAM
|
|
jmp @2 ; JOIN UNARY FUNCTIONS
|
|
@1: jsr PARCHK ; REQUIRE "(EXPRESSION)"
|
|
pla
|
|
tay ; INDEX INTO FUNCTION ADDRESS TABLE
|
|
@2: lda UNFNC-TOKEN_SGN-TOKEN_SGN+$100,y
|
|
sta JMPADRS+1 ; PREPARE TO JSR TO ADDRESS
|
|
lda UNFNC-TOKEN_SGN-TOKEN_SGN+$101,y
|
|
sta JMPADRS+2
|
|
jsr JMPADRS ; DOES NOT RETURN FOR CHR$, LEFT$, RIGHT$, OR MID$
|
|
jmp CHKNUM ; REQUIRE NUMERIC RESULT
|
|
; ----------------------------------------------------------------------------
|
|
OR: lda ARG ; "OR" OPERATOR
|
|
ora FAC ; IF RESULT NONZERO, IT IS TRUE
|
|
bne TRUE
|
|
; ----------------------------------------------------------------------------
|
|
TAND: lda ARG ; "AND" OPERATOR
|
|
beq FALSE ; IF EITHER IS ZERO, RESULT IS FALSE
|
|
lda FAC
|
|
bne TRUE
|
|
; ----------------------------------------------------------------------------
|
|
FALSE: ldy #0 ; RETURN FAC=0
|
|
.byte $2C ; TRICK
|
|
; ----------------------------------------------------------------------------
|
|
TRUE: ldy #1 ; RETURN FAC=1
|
|
jmp SNGFLT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PERFORM RELATIONAL OPERATIONS
|
|
; ----------------------------------------------------------------------------
|
|
RELOPS: jsr CHKVAL ; MAKE SURE FAC IS CORRECT TYPE
|
|
bcs STRCMP ; TYPE MATCHES, BRANCH IF STRINGS
|
|
lda ARGSIGN ; NUMERIC COMPARISON
|
|
ora #$7F ; RE-PACK VALUE IN ARG FOR FCOMP
|
|
and ARG+1
|
|
sta ARG+1
|
|
lda #<ARG
|
|
ldy #>ARG
|
|
jsr FCOMP ; RETURN A-REG = -1,0,1
|
|
tax ; AS ARG <,=,> FAC
|
|
jmp NUMCMP
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; STRING COMPARISON
|
|
; ----------------------------------------------------------------------------
|
|
STRCMP: lda #0 ; SET RESULT TYPE TO NUMERIC
|
|
sta VALTYP
|
|
dec CPRTYP ; MAKE CPRTYP 0000<=>0
|
|
jsr FREFAC
|
|
sta FAC ; STRING LENGTH
|
|
stx FAC+1
|
|
sty FAC+2
|
|
lda ARG+3
|
|
ldy ARG+4
|
|
jsr FRETMP
|
|
stx ARG+3
|
|
sty ARG+4
|
|
tax ; LEN (ARG) STRING
|
|
sec
|
|
sbc FAC ; SET X TO SMALLER LEN
|
|
beq @1
|
|
lda #1
|
|
bcc @1
|
|
ldx FAC
|
|
lda #$FF
|
|
@1: sta FACSIGN ; FLAG WHICH SHORTER
|
|
ldy #$FF
|
|
inx
|
|
STRCMP1:
|
|
iny
|
|
dex
|
|
bne STRCMP2 ; MORE CHARS IN BOTH STRINGS
|
|
ldx FACSIGN ; IF = SO FAR, DECIDE BY LENGTH
|
|
; ----------------------------------------------------------------------------
|
|
NUMCMP: bmi CMPDONE
|
|
clc
|
|
bcc CMPDONE ; ...ALWAYS
|
|
; ----------------------------------------------------------------------------
|
|
STRCMP2:
|
|
lda (ARG+3),y
|
|
cmp (FAC+1),y
|
|
beq STRCMP1 ; SAME, KEEP COMPARING
|
|
ldx #$FF ; IN CASE ARG GREATER
|
|
bcs CMPDONE ; IT IS
|
|
ldx #1 ; FAC GREATER
|
|
; ----------------------------------------------------------------------------
|
|
CMPDONE:
|
|
inx ; CONVERT FF,0,1 TO 0,1,2
|
|
txa
|
|
rol a ; AND TO 0,2,4 IF C=0, ELSE 1,2,5
|
|
and CPRMASK ; 00000<=>
|
|
beq @1 ; IF NO MATCH: FALSE
|
|
lda #1 ; AT LEAST ONE MATCH: TRUE
|
|
@1: jmp FLOAT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; "DIM" STATEMENT
|
|
; ----------------------------------------------------------------------------
|
|
NXDIM: jsr CHKCOM ; SEPARATED BY COMMAS
|
|
DIM: tax ; NON-ZERO, FLAGS PTRGET DIM CALLED
|
|
jsr PTRGET2 ; ALLOCATE THE ARRAY
|
|
jsr CHRGOT ; NEXT CHAR
|
|
bne NXDIM ; NOT END OF STATEMENT
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PTRGET -- GENERAL VARIABLE SCAN
|
|
;
|
|
; SCANS VARIABLE NAME AT TXTPTR, AND SEARCHES THE
|
|
; VARTAB AND ARYTAB FOR THE NAME.
|
|
; IF NOT FOUND, CREATE VARIABLE OF APPROPRIATE TYPE.
|
|
; RETURN WITH ADDRESS IN VARPNT AND Y,A
|
|
;
|
|
; ACTUAL ACTIVITY CONTROLLED SOMEWHAT BY TWO FLAGS:
|
|
; DIMFLG -- NONZERO IF CALLED FROM "DIM"
|
|
; ELSE = 0
|
|
;
|
|
; SUBFLG -- = $00
|
|
; = $40 IF CALLED FROM "GETARYPT"
|
|
; ----------------------------------------------------------------------------
|
|
PTRGET: ldx #0
|
|
jsr CHRGOT ; GET FIRST CHAR OF VARIABLE NAME
|
|
; ----------------------------------------------------------------------------
|
|
PTRGET2:
|
|
stx DIMFLG ; X IS NONZERO IF FROM DIM
|
|
; ----------------------------------------------------------------------------
|
|
PTRGET3:
|
|
sta VARNAM
|
|
jsr CHRGOT
|
|
jsr ISLETC ; IS IT A LETTER?
|
|
bcs NAMOK ; YES, OKAY SO FAR
|
|
BADNAM: jmp SYNERR ; NO, SYNTAX ERROR
|
|
NAMOK: ldx #0
|
|
stx VALTYP
|
|
stx VALTYP+1
|
|
; ----------------------------------------------------------------------------
|
|
PTRGET4:
|
|
jsr CHRGET ; SECOND CHAR OF VARIABLE NAME
|
|
bcc @1 ; NUMERIC
|
|
jsr ISLETC ; LETTER?
|
|
bcc @3 ; NO, END OF NAME
|
|
@1: tax ; SAVE SECOND CHAR OF NAME IN X
|
|
@2: jsr CHRGET ; SCAN TO END OF VARIABLE NAME
|
|
bcc @2 ; NUMERIC
|
|
jsr ISLETC
|
|
bcs @2 ; ALPHA
|
|
@3: cmp #'$' ; STRING?
|
|
bne @4 ; NO
|
|
lda #$FF
|
|
sta VALTYP
|
|
bne @5 ; ...ALWAYS
|
|
@4: cmp #'%' ; INTEGER?
|
|
bne @6 ; NO
|
|
lda SUBFLG ; YES; INTEGER VARIABLE ALLOWED?
|
|
bmi BADNAM ; NO, SYNTAX ERROR
|
|
lda #$80 ; YES
|
|
sta VALTYP+1 ; FLAG INTEGER MODE
|
|
ora VARNAM
|
|
sta VARNAM ; SET SIGN BIT ON VARNAME
|
|
@5: txa ; SECOND CHAR OF NAME
|
|
ora #$80 ; SET SIGN
|
|
tax
|
|
jsr CHRGET ; GET TERMINATING CHAR
|
|
@6: stx VARNAM+1 ; STORE SECOND CHAR OF NAME
|
|
sec
|
|
ora SUBFLG ; $00 OR $40 IF SUBSCRIPTS OK, ELSE $80
|
|
sbc #'(' ; IF SUBFLG=$00 AND CHAR="("...
|
|
bne @8 ; NOPE
|
|
@7: jmp ARRAY ; YES
|
|
@8: bit SUBFLG ; CHECK TOP TWO BITS OF SUBFLG
|
|
bmi @9 ; $80
|
|
bvs @7 ; $40, CALLED FROM GETARYPT
|
|
@9: lda #0 ; CLEAR SUBFLG
|
|
sta SUBFLG
|
|
lda VARTAB ; START LOWTR AT SIMPLE VARIABLE TABLE
|
|
ldx VARTAB+1
|
|
ldy #0
|
|
@10: stx LOWTR+1
|
|
@11: sta LOWTR
|
|
cpx ARYTAB+1 ; END OF SIMPLE VARIABLES?
|
|
bne @12 ; NO, GO ON
|
|
cmp ARYTAB ; YES; END OF ARRAYS?
|
|
beq NAMENOTFOUND ; YES, MAKE ONE
|
|
@12: lda VARNAM ; SAME FIRST LETTER?
|
|
cmp (LOWTR),y
|
|
bne @13 ; NOT SAME FIRST LETTER
|
|
lda VARNAM+1 ; SAME SECOND LETTER?
|
|
iny
|
|
cmp (LOWTR),y
|
|
beq SET_VARPNT_AND_YA ; YES, SAME VARIABLE NAME
|
|
dey ; NO, BUMP TO NEXT NAME
|
|
@13: clc
|
|
lda LOWTR
|
|
adc #7
|
|
bcc @11
|
|
inx
|
|
bne @10 ; ...ALWAYS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CHECK IF (A) IS ASCII LETTER A-Z
|
|
;
|
|
; RETURN CARRY = 1 IF A-Z
|
|
; = 0 IF NOT
|
|
; ----------------------------------------------------------------------------
|
|
ISLETC: cmp #'Z'+1 ; COMPARE HI END
|
|
bcs @1 ; ABOVE A-Z
|
|
cmp #'A' ; COMPARE LO END
|
|
rts ; C=0 IF LO, C=1 IF A-Z
|
|
@1: clc ; C=0 IF HI
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; VARIABLE NOT FOUND, SO MAKE ONE
|
|
; ----------------------------------------------------------------------------
|
|
NAMENOTFOUND:
|
|
pla ; LOOK AT RETURN ADDRESS ON STACK TO
|
|
pha ; SEE IF CALLED FROM FRM.VARIABLE
|
|
cmp #<FRM_VARIABLE_CALL
|
|
bne MAKENEWVARIABLE ; NO
|
|
tsx
|
|
lda STACK+2,x
|
|
cmp #>FRM_VARIABLE_CALL
|
|
bne MAKENEWVARIABLE ; NO
|
|
lda #<C_ZERO ; YES, CALLED FROM FRM.VARIABLE
|
|
ldy #>C_ZERO ; POINT TO A CONSTANT ZERO
|
|
rts ; NEW VARIABLE USED IN EXPRESSION = 0
|
|
|
|
; ----------------------------------------------------------------------------
|
|
C_ZERO: .word $0000 ; INTEGER OR REAL ZERO, OR NULL STRING
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; MAKE A NEW SIMPLE VARIABLE
|
|
;
|
|
; MOVE ARRAYS UP 7 BYTES TO MAKE ROOM FOR NEW VARIABLE
|
|
; ENTER 7-BYTE VARIABLE DATA IN THE HOLE
|
|
; ----------------------------------------------------------------------------
|
|
MAKENEWVARIABLE:
|
|
lda ARYTAB ; SET UP CALL TO BLTU TO
|
|
ldy ARYTAB+1 ; TO MOVE FROM ARYTAB THRU STREND-1
|
|
sta LOWTR ; 7 BYTES HIGHER
|
|
sty LOWTR+1
|
|
lda STREND
|
|
ldy STREND+1
|
|
sta HIGHTR
|
|
sty HIGHTR+1
|
|
clc
|
|
adc #7
|
|
bcc @1
|
|
iny
|
|
@1: sta ARYPNT
|
|
sty ARYPNT+1
|
|
jsr BLTU ; MOVE ARRAY BLOCK UP
|
|
lda ARYPNT ; STORE NEW START OF ARRAYS
|
|
ldy ARYPNT+1
|
|
iny
|
|
sta ARYTAB
|
|
sty ARYTAB+1
|
|
ldy #0
|
|
lda VARNAM ; FIRST CHAR OF NAME
|
|
sta (LOWTR),y
|
|
iny
|
|
lda VARNAM+1 ; SECOND CHAR OF NAME
|
|
sta (LOWTR),y
|
|
lda #0 ; SET FIVE-BYTE VALUE TO 0
|
|
iny
|
|
sta (LOWTR),y
|
|
iny
|
|
sta (LOWTR),y
|
|
iny
|
|
sta (LOWTR),y
|
|
iny
|
|
sta (LOWTR),y
|
|
iny
|
|
sta (LOWTR),y
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; PUT ADDRESS OF VALUE OF VARIABLE IN VARPNT AND Y,A
|
|
; ----------------------------------------------------------------------------
|
|
SET_VARPNT_AND_YA:
|
|
lda LOWTR ; LOWTR POINTS AT NAME OF VARIABLE,
|
|
clc ; SO ADD 2 TO GET TO VALUE
|
|
adc #2
|
|
ldy LOWTR+1
|
|
bcc @1
|
|
iny
|
|
@1: sta VARPNT ; ADDRESS IN VARPNT AND Y,A
|
|
sty VARPNT+1
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; COMPUTE ADDRESS OF FIRST VALUE IN ARRAY
|
|
; ARYPNT = (LOWTR) + #DIMS*2 + 5
|
|
; ----------------------------------------------------------------------------
|
|
GETARY: lda NUMDIM ; GET # OF DIMENSIONS
|
|
asl a ; #DIMS*2 (SIZE OF EACH DIM IN 2 BYTES)
|
|
adc #5 ; + 5 (2 FOR NAME, 2 FOR OFFSET TO NEXT ARRAY, AND 1 FOR #DIMS
|
|
adc LOWTR ; ADDRESS OF TH IS ARRAY IN ARYTAB
|
|
ldy LOWTR+1
|
|
bcc @1
|
|
iny
|
|
@1: sta ARYPNT ; ADDRESS OF FIRST VALUE IN ARRAY
|
|
sty ARYPNT+1
|
|
rts
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
NEG32768:
|
|
.byte $90,$80,$00,$00,$00 ; -32768 IN FLOATING POINT
|
|
; ----------------------------------------------------------------------------
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; EVALUATE NUMERIC FORMULA AT TXTPTR
|
|
; CONVERTING RESULT TO INTEGER 0 <= X <= 32767
|
|
; IN FAC+3,4
|
|
; ----------------------------------------------------------------------------
|
|
MAKINT: jsr CHRGET
|
|
jsr FRMNUM
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CONVERT FAC TO INTEGER
|
|
; MUST BE POSITIVE AND LESS THAN 32768
|
|
; ----------------------------------------------------------------------------
|
|
MKINT: lda FACSIGN ; ERROR IF -
|
|
bmi MI1
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CONVERT FAC TO INTEGER
|
|
; MUST BE -32767 <= FAC <= 32767
|
|
; ----------------------------------------------------------------------------
|
|
AYINT: lda FAC ; EXPONENT OF VALUE IN FAC
|
|
cmp #$90 ; ABS(VALUE) < 32768?
|
|
bcc MI2 ; YES, OK FOR INTEGER
|
|
lda #<NEG32768 ; NO
|
|
ldy #>NEG32768
|
|
jsr FCOMP
|
|
; ----------------------------------------------------------------------------
|
|
MI1: bne IQERR ; ILLEGAL QUANTITY
|
|
MI2: jmp QINT ; CONVERT TO INTEGER
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; LOCATE ARRAY ELEMENT OR CREATE AN ARRAY
|
|
; ----------------------------------------------------------------------------
|
|
ARRAY: lda SUBFLG ; SUBSCRIPTS GIVEN?
|
|
bne @2 ; NO
|
|
; ----------------------------------------------------------------------------
|
|
; PARSE THE SUBSCRIPT LIST
|
|
; ----------------------------------------------------------------------------
|
|
lda DIMFLG ; YES
|
|
ora VALTYP+1 ; SET HIGH BIT IF %
|
|
pha ; SAVE VALTYP AND DIMFLG ON STACK
|
|
lda VALTYP
|
|
pha
|
|
ldy #0 ; COUNT # DIMENSIONS IN Y-REG
|
|
@1: tya ; SAVE #DIMS ON STACK
|
|
pha
|
|
lda VARNAM+1 ; SAVE VARIABLE NAME ON STACK
|
|
pha
|
|
lda VARNAM
|
|
pha
|
|
jsr MAKINT ; EVALUATE SUBSCRIPT AS INTEGER
|
|
pla ; RESTORE VARIABLE NAME
|
|
sta VARNAM
|
|
pla
|
|
sta VARNAM+1
|
|
pla ; RESTORE # DIMS TO Y-REG
|
|
tay
|
|
tsx ; COPY VALTYP AND DIMFLG ON STACK
|
|
lda STACK+2,x ; TO LEAVE ROOM FOR THE SUBSCRIPT
|
|
pha
|
|
lda STACK+1,x
|
|
pha
|
|
lda FAC+3 ; GET SUBSCRIPT VALUE AND PLACE IN THE
|
|
sta STACK+2,x ; STACK WHERE VALTYP & DIMFLG WERE
|
|
lda FAC+4
|
|
sta STACK+1,x
|
|
iny ; COUNT THE SUBSCRIPT
|
|
jsr CHRGOT ; NEXT CHAR
|
|
cmp #','
|
|
beq @1 ; COMMA, PARSE ANOTHER SUBSCRIPT
|
|
sty NUMDIM ; NO MORE SUBSCRIPTS, SAVE #
|
|
jsr CHKCLS ; NOW NEED ")"
|
|
pla ; RESTORE VALTYPE AND DIMFLG
|
|
sta VALTYP
|
|
pla
|
|
sta VALTYP+1
|
|
and #$7F ; ISOLATE DIMFLG
|
|
sta DIMFLG
|
|
; ----------------------------------------------------------------------------
|
|
; SEARCH ARRAY TABLE FOR THIS ARRAY NAME
|
|
; ----------------------------------------------------------------------------
|
|
@2: ldx ARYTAB ; (A,X) = START OF ARRAY TABLE
|
|
lda ARYTAB+1
|
|
@3: stx LOWTR ; USE LOWTR FOR RUNNING POINTER
|
|
sta LOWTR+1
|
|
cmp STREND+1 ; DID WE REACH THE END OF ARRAYS YET?
|
|
bne @4 ; NO, KEEP SEARCHING
|
|
cpx STREND
|
|
beq MAKE_NEW_ARRAY ; YES, THIS IS A NEW ARRAY NAME
|
|
@4: ldy #0 ; POINT AT 1ST CHAR OF ARRAY NAME
|
|
lda (LOWTR),y ; GET 1ST CHAR OF NAME
|
|
iny ; POINT AT 2ND CHAR
|
|
cmp VARNAM ; 1ST CHAR SAME?
|
|
bne @5 ; NO, MOVE TO NEXT ARRAY
|
|
lda VARNAM+1 ; YES, TRY 2ND CHAR
|
|
cmp (LOWTR),y ; SAME?
|
|
beq USE_OLD_ARRAY ; YES, ARRAY FOUND
|
|
@5: iny ; POINT AT OFFSET TO NEXT ARRAY
|
|
lda (LOWTR),y ; ADD OFFSET TO RUNNING POINTER
|
|
clc
|
|
adc LOWTR
|
|
tax
|
|
iny
|
|
lda (LOWTR),y
|
|
adc LOWTR+1
|
|
bcc @3 ; ...ALWAYS
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; ERROR: BAD SUBSCRIPTS
|
|
; ----------------------------------------------------------------------------
|
|
SUBERR: ldx #ERR_BADSUBS
|
|
.byte $2C ; TRICK TO SKIP NEXT LINE
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; ERROR: ILLEGAL QUANTITY
|
|
; ----------------------------------------------------------------------------
|
|
IQERR: ldx #ERR_ILLQTY
|
|
JER: jmp ERROR
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; FOUND THE ARRAY
|
|
; ----------------------------------------------------------------------------
|
|
USE_OLD_ARRAY:
|
|
ldx #ERR_REDIMD ; SET UP FOR REDIM'D ARRAY ERROR
|
|
lda DIMFLG ; CALLED FROM "DIM" STATEMENT?
|
|
bne JER ; YES, ERROR
|
|
lda SUBFLG ; NO, CHECK IF ANY SUBSCRIPTS
|
|
beq @1 ; YES, NEED TO CHECK THE NUMBER
|
|
sec ; NO, SIGNAL ARRAY FOUND
|
|
rts
|
|
; ----------------------------------------------------------------------------
|
|
@1: jsr GETARY ; SET (ARYPNT) = ADDR OF FIRST ELEMENT
|
|
lda TKNCNTR ; COMPARE NUMBER OF DIMENSIONS
|
|
ldy #4
|
|
cmp (LOWTR),y
|
|
bne SUBERR ; NOT SAME, SUBSCRIPT ERROR
|
|
jmp FIND_ARRAY_ELEMENT
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
; CREATE A NEW ARRAY, UNLESS CALLED FROM GETARYPT
|
|
; ----------------------------------------------------------------------------
|
|
MAKE_NEW_ARRAY:
|
|
lda SUBFLG ; CALLED FROM GETARYPT?
|
|
beq @1 ; NO
|
|
ldx #ERR_NODATA ; YES, GIVE "OUT OF DATA" ERROR
|
|
jmp ERROR
|
|
@1: jsr GETARY ; PUT ADDR OF 1ST ELEMENT IN ARYPNT
|
|
jsr REASON ; MAKE SURE ENOUGH MEMORY LEFT
|
|
ldy #0 ; POINT Y-REG AT VARIABLE NAME SLOT
|
|
sty STRNG2+1 ; START SIZE COMPUTATION
|
|
ldx #5 ; ASSUME 5-BYTES PER ELEMENT
|
|
lda VARNAM ; STUFF VARIABLE NAME IN ARRAY
|
|
sta (LOWTR),y
|
|
bpl @2 ; NOT INTEGER ARRAY
|
|
dex ; INTEGER ARRAY, DECR. SIZE TO 4-BYTES
|
|
@2: iny ; POINT Y-REG AT NEXT CHAR OF NAME
|
|
lda VARNAM+1 ; REST OF ARRAY NAME
|
|
sta (LOWTR),y
|
|
bpl @3 ; REAL ARRAY, STICK WITH SIZE = 5 BYTES
|
|
dex ; INTEGER OR STRING ARRAY, ADJUST SIZE
|
|
dex ; TO INTEGER=3, STRING=2 BYTES
|
|
@3: stx STRNG2 ; STORE LOW-BYTE OF ARRAY ELEMENT SIZE
|
|
lda NUMDIM ; STORE NUMBER OF DIMENSIONS
|
|
iny ; IN 5TH BYTE OF ARRAY
|
|
iny
|
|
iny
|
|
sta (LOWTR),y
|
|
@4: ldx #11 ; DEFAULT DIMENSION = 11 ELEMENTS
|
|
lda #0 ; FOR HI-BYTE OF DIMENSION IF DEFAULT
|
|
bit DIMFLG ; DIMENSIONED ARRAY?
|
|
bvc @5 ; NO, USE DEFAULT VALUE
|
|
pla ; GET SPECIFIED DIM IN A,X
|
|
clc ; # ELEMENTS IS 1 LARGER THAN
|
|
adc #1 ; DIMENSION VALUE
|
|
tax
|
|
pla
|
|
adc #0
|
|
@5: iny ; ADD THIS DIMENSION TO ARRAY DESCRIPTOR
|
|
sta (LOWT< |