2021-01-16 00:08:36 +00:00
|
|
|
; Applesoft Lite
|
2017-05-11 20:42:22 +00:00
|
|
|
;
|
|
|
|
; 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
|
|
|
|
;
|
2021-01-16 00:08:36 +00:00
|
|
|
; Changed to support LOAD & SAVE via Apple-1 Serial Interface by Piotr Jaczewski
|
|
|
|
; 15-Jan-2021
|
|
|
|
;
|
2017-05-11 20:42:22 +00:00
|
|
|
|
|
|
|
.setcpu "6502"
|
|
|
|
.segment "BASIC"
|
|
|
|
|
|
|
|
.export FIX_LINKS, ERROR, INPUTBUFFER
|
2021-01-16 00:08:36 +00:00
|
|
|
.exportzp ERR_SYNTAX, ERR_NOSERIAL
|
2017-05-11 20:42:22 +00:00
|
|
|
|
|
|
|
.import CLS, OUTDO, CRDO, OUTSP, OUTQUES ; Imports from io.s
|
|
|
|
.import KEYBOARD, GETLN, RDKEY
|
|
|
|
|
2021-01-16 00:08:36 +00:00
|
|
|
.import SerialLoad, SerialSave, SerialMenu ; Imports from apple1serial.s
|
2017-05-11 20:42:22 +00:00
|
|
|
|
|
|
|
.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
|
2021-01-16 00:08:36 +00:00
|
|
|
.addr SerialMenu - 1 ; $9E... 157... MENU
|
|
|
|
.addr SerialSave - 1 ; $9F... 158... SAVE
|
|
|
|
.addr SerialLoad - 1 ; $A0... 160... LOAD
|
2017-05-11 20:42:22 +00:00
|
|
|
.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
|
2021-01-16 00:08:36 +00:00
|
|
|
htasc "MENU" ; $9E... 158 New tokens
|
2017-05-11 20:42:22 +00:00
|
|
|
htasc "SAVE" ; $9F... 159 for
|
2021-01-16 00:08:36 +00:00
|
|
|
htasc "LOAD" ; $A0... 160 Apple-1 Serial I/O
|
2017-05-11 20:42:22 +00:00
|
|
|
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"
|
|
|
|
|
2021-01-16 00:08:36 +00:00
|
|
|
ERR_NOSERIAL := <(*-ERROR_MESSAGES) ; New error message for Apple 1 Serial IO
|
|
|
|
htasc "NO SERIAL"
|
2017-05-11 20:42:22 +00:00
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
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
|
2021-01-16 00:08:36 +00:00
|
|
|
ldx #TEMP1-FAC+1+256 ; RESTORE TEMP1 AND TEMP2
|
2017-05-11 20:42:22 +00:00
|
|
|
@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)
|
2021-01-28 22:28:59 +00:00
|
|
|
;lda #'C'
|
|
|
|
;jsr OUTDO
|
2017-05-11 20:42:22 +00:00
|
|
|
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
|
2021-01-16 00:08:36 +00:00
|
|
|
ldx #<INPUTBUFFER-1+256
|
2017-05-11 20:42:22 +00:00
|
|
|
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
|
2021-01-16 00:08:36 +00:00
|
|
|
lda #<INPUTBUFFER-1+256
|
2017-05-11 20:42:22 +00:00
|
|
|
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
|
2021-01-16 00:08:36 +00:00
|
|
|
ldy #$FF
|
2017-05-11 20:42:22 +00:00
|
|
|
@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 (LOWTR),y
|
|
|
|
iny
|
|
|
|
txa
|
|
|
|
sta (LOWTR),y
|
|
|
|
jsr MULTIPLY_SUBSCRIPT ; MULTIPLY THIS DIMENSION BY RUNNING SIZE ((LOWTR)) * (STRNG2) --> A,X
|
|
|
|
stx STRNG2 ; STORE RUNNING SIZE IN STRNG2
|
|
|
|
sta STRNG2+1
|
|
|
|
ldy INDEX ; RETRIEVE Y SAVED BY MULTIPLY.SUBSCRIPT
|
|
|
|
dec NUMDIM ; COUNT DOWN # DIMS
|
|
|
|
bne @4 ; LOOP TILL DONE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NOW A,X HAS TOTAL # BYTES OF ARRAY ELEMENTS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
adc ARYPNT+1 ; COMPUTE ADDRESS OF END OF THIS ARRAY
|
|
|
|
bcs GME ; ...TOO LARGE, ERROR
|
|
|
|
sta ARYPNT+1
|
|
|
|
tay
|
|
|
|
txa
|
|
|
|
adc ARYPNT
|
|
|
|
bcc @6
|
|
|
|
iny
|
|
|
|
beq GME ; ...TOO LARGE, ERROR
|
|
|
|
@6: jsr REASON ; MAKE SURE THERE IS ROOM UP TO Y,A
|
|
|
|
sta STREND ; THERE IS ROOM SO SAVE NEW END OF TABLE
|
|
|
|
sty STREND+1 ; AND ZERO THE ARRAY
|
|
|
|
lda #0
|
|
|
|
inc STRNG2+1 ; PREPARE FOR FAST ZEROING LOOP
|
|
|
|
ldy STRNG2 ; # BYTES MOD 256
|
|
|
|
beq @8 ; FULL PAGE
|
|
|
|
@7: dey ; CLEAR PAGE FULL
|
|
|
|
sta (ARYPNT),y
|
|
|
|
bne @7
|
|
|
|
@8: dec ARYPNT+1 ; POINT TO NEXT PAGE
|
|
|
|
dec STRNG2+1 ; COUNT THE PAGES
|
|
|
|
bne @7 ; STILL MORE TO CLEAR
|
|
|
|
inc ARYPNT+1 ; RECOVER LAST DEC, POINT AT 1ST ELEMENT
|
|
|
|
sec
|
|
|
|
lda STREND ; COMPUTE OFFSET TO END OF ARRAYS
|
|
|
|
sbc LOWTR ; AND STORE IN ARRAY DESCRIPTOR
|
|
|
|
ldy #2
|
|
|
|
sta (LOWTR),y
|
|
|
|
lda STREND+1
|
|
|
|
iny
|
|
|
|
sbc LOWTR+1
|
|
|
|
sta (LOWTR),y
|
|
|
|
lda DIMFLG ; WAS THIS CALLED FROM "DIM" STATEMENT?
|
|
|
|
bne RTS9 ; YES, WE ARE FINISHED
|
|
|
|
iny ; NO, NOW NEED TO FIND THE ELEMENT
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FIND SPECIFIED ARRAY ELEMENT
|
|
|
|
;
|
|
|
|
; (LOWTR),Y POINTS AT # OF DIMS IN ARRAY DESCRIPTOR
|
|
|
|
; THE SUBSCRIPTS ARE ALL ON THE STACK AS INTEGERS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIND_ARRAY_ELEMENT:
|
|
|
|
lda (LOWTR),y ; GET # OF DIMENSIONS
|
|
|
|
sta NUMDIM
|
|
|
|
lda #0 ; ZERO SUBSCRIPT ACCUMULATOR
|
|
|
|
sta STRNG2
|
|
|
|
FAE1: sta STRNG2+1
|
|
|
|
iny
|
|
|
|
pla ; PULL NEXT SUBSCRIPT FROM STACK
|
|
|
|
tax ; SAVE IN FAC+3,4
|
|
|
|
sta FAC+3 ; AND COMPARE WITH DIMENSIONED SIZE
|
|
|
|
pla
|
|
|
|
sta FAC+4
|
|
|
|
cmp (LOWTR),y
|
|
|
|
bcc FAE2 ; SUBSCRIPT NOT TOO LARGE
|
|
|
|
bne GSE ; SUBSCRIPT IS TOO LARGE
|
|
|
|
iny ; CHECK LOW-BYTE OF SUBSCRIPT
|
|
|
|
txa
|
|
|
|
cmp (LOWTR),y
|
|
|
|
bcc FAE3 ; NOT TOO LARGE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GSE: jmp SUBERR ; BAD SUBSCRIPTS ERROR
|
|
|
|
GME: jmp MEMERR ; MEM FULL ERROR
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FAE2: iny ; BUMP POINTER INTO DESCRIPTOR
|
|
|
|
FAE3: lda STRNG2+1 ; BYPASS MULTIPLICATION IF VALUE SO
|
|
|
|
ora STRNG2 ; FAR = 0
|
|
|
|
clc
|
|
|
|
beq @1 ; IT IS ZERO SO FAR
|
|
|
|
jsr MULTIPLY_SUBSCRIPT ; NOT ZERO, SO MULTIPLY
|
|
|
|
txa ; ADD CURRENT SUBSCRIPT
|
|
|
|
adc FAC+3
|
|
|
|
tax
|
|
|
|
tya
|
|
|
|
ldy INDEX ; RETRIEVE Y SAVED BY MULTIPLY.SUBSCRIPT
|
|
|
|
@1: adc FAC+4 ; FINISH ADDING CURRENT SUBSCRIPT
|
|
|
|
stx STRNG2 ; STORE ACCUMULATED OFFSET
|
|
|
|
dec NUMDIM ; LAST SUBSCRIPT YET?
|
|
|
|
bne FAE1 ; NO, LOOP TILL DONE
|
|
|
|
sta STRNG2+1 ; YES, NOW MULTIPLY BE ELEMENT SIZE
|
|
|
|
ldx #5 ; START WITH SIZE = 5
|
|
|
|
lda VARNAM ; DETERMINE VARIABLE TYPE
|
|
|
|
bpl @2 ; NOT INTEGER
|
|
|
|
dex ; INTEGER, BACK DOWN SIZE TO 4 BYTES
|
|
|
|
@2: lda VARNAM+1 ; DISCRIMINATE BETWEEN REAL AND STR
|
|
|
|
bpl @3 ; IT IS REAL
|
|
|
|
dex ; SIZE = 3 IF STRING, =2 IF INTEGER
|
|
|
|
dex
|
|
|
|
@3: stx RESULT+2 ; SET UP MULTIPLIER
|
|
|
|
lda #0 ; HI-BYTE OF MULTIPLIER
|
|
|
|
jsr MULTIPLY_SUBS1 ; (STRNG2) BY ELEMENT SIZE
|
|
|
|
txa ; ADD ACCUMULATED OFFSET
|
|
|
|
adc ARYPNT ; TO ADDRESS OF 1ST ELEMENT
|
|
|
|
sta VARPNT ; TO GET ADDRESS OF SPECIFIED ELEMENT
|
|
|
|
tya
|
|
|
|
adc ARYPNT+1
|
|
|
|
sta VARPNT+1
|
|
|
|
tay ; RETURN WITH ADDR IN VARPNT
|
|
|
|
lda VARPNT ; AND IN Y,A
|
|
|
|
RTS9: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MULTIPLY (STRNG2) BY ((LOWTR),Y)
|
|
|
|
; LEAVING PRODUCT IN A,X. (HI-BYTE ALSO IN Y.)
|
|
|
|
; USED ONLY BY ARRAY SUBSCRIPT ROUTINES
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MULTIPLY_SUBSCRIPT:
|
|
|
|
sty INDEX ; SAVE Y-REG
|
|
|
|
lda (LOWTR),y ; GET MULTIPLIER
|
|
|
|
sta RESULT+2 ; SAVE IN RESULT+2,3
|
|
|
|
dey
|
|
|
|
lda (LOWTR),y
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MULTIPLY_SUBS1:
|
|
|
|
sta RESULT+3 ; LOW BYTE OF MULTIPLIER
|
|
|
|
lda #16 ; MULTIPLY 16 BITS
|
|
|
|
sta INDX
|
|
|
|
ldx #0 ; PRODUCT = 0 INITIALLY
|
|
|
|
ldy #0
|
|
|
|
@1: txa ; DOUBLE PRODUCT
|
|
|
|
asl a ; LOW BYTE
|
|
|
|
tax
|
|
|
|
tya ; HIGH BYTE
|
|
|
|
rol a ; IF TOO LARGE, SET CARRY
|
|
|
|
tay
|
|
|
|
bcs GME ; TOO LARGE, "MEM FULL ERROR"
|
|
|
|
asl STRNG2 ; NEXT BIT OF MUTLPLICAND
|
|
|
|
rol STRNG2+1 ; INTO CARRY
|
|
|
|
bcc @2 ; BIT=0, DON'T NEED TO ADD
|
|
|
|
clc ; BIT=1, ADD INTO PARTIAL PRODUCT
|
|
|
|
txa
|
|
|
|
adc RESULT+2
|
|
|
|
tax
|
|
|
|
tya
|
|
|
|
adc RESULT+3
|
|
|
|
tay
|
|
|
|
bcs GME ; TOO LARGE, "MEM FULL ERROR"
|
|
|
|
@2: dec INDX ; 16-BITS YET?
|
|
|
|
bne @1 ; NO, KEEP SHUFFLING
|
|
|
|
rts ; YES, PRODUCT IN Y,X AND A,X
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "FRE" FUNCTION
|
|
|
|
;
|
|
|
|
; COLLECTS GARBAGE AND RETURNS # BYTES OF MEMORY LEFT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FRE: lda VALTYP ; LOOK AT VALUE OF ARGUMENT
|
|
|
|
beq @1 ; =0 MEANS REAL, =$FF MEANS STRING
|
|
|
|
jsr FREFAC ; STRING, SO SET IT FREE IS TEMP
|
|
|
|
@1: jsr GARBAG ; COLLECT ALL THE GARBAGE IN SIGHT
|
|
|
|
sec ; COMPUTE SPACE BETWEEN ARRAYS AND
|
|
|
|
lda FRETOP ; STRING TEMP AREA
|
|
|
|
sbc STREND
|
|
|
|
tay
|
|
|
|
lda FRETOP+1
|
|
|
|
sbc STREND+1 ; FREE SPACE IN Y,A
|
|
|
|
; FALL INTO GIVAYF TO FLOAT THE VALUE
|
|
|
|
; NOTE THAT VALUES OVER 32767 WILL RETURN AS NEGATIVE
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FLOAT THE SIGNED INTEGER IN A,Y
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GIVAYF: ldx #0 ; MARK FAC VALUE TYPE REAL
|
|
|
|
stx VALTYP
|
|
|
|
sta FAC+1 ; SAVE VALUE FROM A,Y IN MANTISSA
|
|
|
|
sty FAC+2
|
|
|
|
ldx #$90 ; SET EXPONENT TO 2^16
|
|
|
|
jmp FLOAT1 ; CONVERT TO SIGNED FP
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FLOAT (Y) INTO FAC, GIVING VALUE 0-255
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SNGFLT: lda #0 ; MSB = 0
|
|
|
|
beq GIVAYF ; ...ALWAYS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; CHECK FOR DIRECT OR RUNNING MODE
|
|
|
|
; GIVING ERROR IF DIRECT MODE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ERRDIR: ldx CURLIN+1 ; =$FF IF DIRECT MODE
|
|
|
|
inx ; MAKES $FF INTO ZERO
|
|
|
|
bne RTS9 ; RETURN IF RUNNING MODE
|
|
|
|
ldx #ERR_ILLDIR ; DIRECT MODE, GIVE ERROR
|
|
|
|
jmp ERROR
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "STR$" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STR: jsr CHKNUM ; EXPRESSION MUST BE NUMERIC
|
|
|
|
ldy #0 ; START STRING AT STACK-1 ($00FF) SO STRLIT CAN DIFFRENTIATE STR$ CALLS
|
|
|
|
jsr FOUT1 ; CONVERT FAC TO STRING
|
|
|
|
pla ; POP RETURN OFF STACK
|
|
|
|
pla
|
2021-01-16 00:08:36 +00:00
|
|
|
lda #<STACK-1+256 ; POINT TO STACK-1
|
2017-05-11 20:42:22 +00:00
|
|
|
ldy #>STACK-1 ; (WHICH=0)
|
|
|
|
beq STRLIT ; ...ALWAYS, CREATE DESC & MOVE STRING
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE
|
|
|
|
; ADDRESS IS IN FAC+3,4 AND WHOSE LENGTH IS IN A-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STRINI: ldx FAC+3 ; Y,X = STRING ADDRESS
|
|
|
|
ldy FAC+4
|
|
|
|
stx DSCPTR
|
|
|
|
sty DSCPTR+1
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; GET SPACE AND MAKE DESCRIPTOR FOR STRING WHOSE
|
|
|
|
; ADDRESS IS IN Y,X AND WHOSE LENGTH IS IN A-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STRSPA: jsr GETSPA ; A HOLDS LENGTH
|
|
|
|
stx FAC+1 ; SAVE DESCRIPTOR IN FAC
|
|
|
|
sty FAC+2 ; ---FAC--- --FAC+1-- --FAC+2--
|
|
|
|
sta FAC ; <LENGTH> <ADDR-LO> <ADDR-HI>
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A
|
|
|
|
; AND TERMINATED BY $00 OR QUOTATION MARK
|
|
|
|
; RETURN WITH DESCRIPTOR IN A TEMPORARY
|
|
|
|
; AND ADDRESS OF DESCRIPTOR IN FAC+3,4
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STRLIT: ldx #'"' ; SET UP LITERAL SCAN TO STOP ON
|
|
|
|
stx CHARAC ; QUOTATION MARK OR $00
|
|
|
|
stx ENDCHR
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; BUILD A DESCRIPTOR FOR STRING STARTING AT Y,A
|
|
|
|
; AND TERMINATED BY $00, (CHARAC), OR (ENDCHR)
|
|
|
|
;
|
|
|
|
; RETURN WITH DESCRIPTOR IN A TEMPORARY
|
|
|
|
; AND ADDRESS OF DESCRIPTOR IN FAC+3,4
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STRLT2: sta STRNG1 ; SAVE ADDRESS OF STRING
|
|
|
|
sty STRNG1+1
|
|
|
|
sta FAC+1 ; ...AGAIN
|
|
|
|
sty FAC+2
|
|
|
|
ldy #$FF
|
|
|
|
@1: iny ; FIND END OF STRING
|
|
|
|
lda (STRNG1),y ; NEXT STRING CHAR
|
|
|
|
beq @3 ; END OF STRING
|
|
|
|
cmp CHARAC ; ALTERNATE TERMINATOR # 1?
|
|
|
|
beq @2 ; YES
|
|
|
|
cmp ENDCHR ; ALTERNATE TERMINATOR # 2?
|
|
|
|
bne @1 ; NO, KEEP SCANNING
|
|
|
|
@2: cmp #'"' ; IS STRING ENDED WITH QUOTE MARK?
|
|
|
|
beq @4 ; YES, C=1 TO INCLUDE " IN STRING
|
|
|
|
@3: clc
|
|
|
|
@4: sty FAC ; SAVE LENGTH
|
|
|
|
tya
|
|
|
|
adc STRNG1 ; COMPUTE ADDRESS OF END OF STRING
|
|
|
|
sta STRNG2 ; (OF 00 BYTE, OR JUST AFTER ")
|
|
|
|
ldx STRNG1+1
|
|
|
|
bcc @5
|
|
|
|
inx
|
|
|
|
@5: stx STRNG2+1
|
|
|
|
lda STRNG1+1 ; WHERE DOES THE STRING START?
|
|
|
|
beq @6 ; PAGE 0, MUST BE FROM STR$ FUNCTION
|
|
|
|
cmp #2 ; PAGE 2?
|
|
|
|
bne PUTNEW ; NO, NOT PAGE 0 OR 2
|
|
|
|
@6: tya ; LENGTH OF STRING
|
|
|
|
jsr STRINI ; MAKE SPACE FOR STRING
|
|
|
|
ldx STRNG1
|
|
|
|
ldy STRNG1+1
|
|
|
|
jsr MOVSTR ; MOVE IT IN
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; STORE DESCRIPTOR IN TEMPORARY DESCRIPTOR STACK
|
|
|
|
;
|
|
|
|
; THE DESCRIPTOR IS NOW IN FAC, FAC+1, FAC+2
|
|
|
|
; PUT ADDRESS OF TEMP DESCRIPTOR IN FAC+3,4
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
PUTNEW: ldx TEMPPT ; POINTER TO NEXT TEMP STRING SLOT
|
|
|
|
cpx #TEMPST+9 ; MAX OF 3 TEMP STRINGS
|
|
|
|
bne PUTEMP ; ROOM FOR ANOTHER ONE
|
|
|
|
ldx #ERR_FRMCPX ; TOO MANY, FORMULA TOO COMPLEX
|
|
|
|
JERR: jmp ERROR
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
PUTEMP: lda FAC ; COPY TEMP DESCRIPTOR INTO TEMP STACK
|
|
|
|
sta 0,x
|
|
|
|
lda FAC+1
|
|
|
|
sta 1,x
|
|
|
|
lda FAC+2
|
|
|
|
sta 2,x
|
|
|
|
ldy #0
|
|
|
|
stx FAC+3 ; ADDRESS OF TEMP DESCRIPTOR
|
|
|
|
sty FAC+4 ; IN Y,X AND FAC+3,4
|
|
|
|
dey ; Y=$FF
|
|
|
|
sty VALTYP ; FLAG (FAC ) AS STRING
|
|
|
|
stx LASTPT ; INDEX OF LAST POINTER
|
|
|
|
inx ; UPDATE FOR NEXT TEMP ENTRY
|
|
|
|
inx
|
|
|
|
inx
|
|
|
|
stx TEMPPT
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MAKE SPACE FOR STRING AT BOTTOM OF STRING SPACE
|
|
|
|
; (A)=# BYTES SPACE TO MAKE
|
|
|
|
;
|
|
|
|
; RETURN WITH (A) SAME,
|
|
|
|
; AND Y,X = ADDRESS OF SPACE ALLOCATED
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GETSPA: lsr GARFLG ; CLEAR SIGNBIT OF FLAG
|
|
|
|
@1: pha ; A HOLDS LENGTH
|
|
|
|
eor #$FF ; GET -LENGTH
|
|
|
|
sec
|
|
|
|
adc FRETOP ; COMPUTE STARTING ADDRESS OF SPACE
|
|
|
|
ldy FRETOP+1 ; FOR THE STRING
|
|
|
|
bcs @2
|
|
|
|
dey
|
|
|
|
@2: cpy STREND+1 ; SEE IF FITS IN REMAINING MEMORY
|
|
|
|
bcc @4 ; NO, TRY GARBAGE
|
|
|
|
bne @3 ; YES, IT FITS
|
|
|
|
cmp STREND ; HAVE TO CHECK LOWER BYTES
|
|
|
|
bcc @4 ; NOT ENUF ROOM YET
|
|
|
|
@3: sta FRETOP ; THERE IS ROOM SO SAVE NEW FRETOP
|
|
|
|
sty FRETOP+1
|
|
|
|
sta FRESPC
|
|
|
|
sty FRESPC+1
|
|
|
|
tax ; ADDR IN Y,X
|
|
|
|
pla ; LENGTH IN A
|
|
|
|
rts
|
|
|
|
@4: ldx #ERR_MEMFULL
|
|
|
|
lda GARFLG ; GARBAGE DONE YET?
|
|
|
|
bmi JERR ; YES, MEMORY IS REALLY FULL
|
|
|
|
jsr GARBAG ; NO, TRY COLLECTING NOW
|
|
|
|
lda #$80 ; FLAG THAT COLLECTED GARBAGE ALREADY
|
|
|
|
sta GARFLG
|
|
|
|
pla ; GET STRING LENGTH AGAIN
|
|
|
|
bne @1 ; ...ALWAYS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; SHOVE ALL REFERENCED STRINGS AS HIGH AS POSSIBLE
|
|
|
|
; IN MEMORY (AGAINST HIMEM), FREEING UP SPACE
|
|
|
|
; BELOW STRING AREA DOWN TO STREND.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GARBAG: ldx MEMSIZ ; COLLECT FROM TOP DOWN
|
|
|
|
lda MEMSIZ+1
|
|
|
|
FINDHIGHESTSTRING:
|
|
|
|
stx FRETOP ; ONE PASS THROUGH ALL VARS
|
|
|
|
sta FRETOP+1 ; FOR EACH ACTIVE STRING!
|
|
|
|
ldy #0
|
|
|
|
sty FNCNAM+1 ; FLAG IN CASE NO STRINGS TO COLLECT
|
|
|
|
lda STREND
|
|
|
|
ldx STREND+1
|
|
|
|
sta LOWTR
|
|
|
|
stx LOWTR+1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; START BY COLLECTING TEMPORARIES
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
lda #<TEMPST
|
|
|
|
ldx #>TEMPST
|
|
|
|
sta INDEX
|
|
|
|
stx INDEX+1
|
|
|
|
@1: cmp TEMPPT ; FINISHED WITH TEMPS YET?
|
|
|
|
beq @2 ; YES, NOW DO SIMPLE VARIABLES
|
|
|
|
jsr CHECK_VARIABLE ; DO A TEMP
|
|
|
|
beq @1 ; ...ALWAYS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NOW COLLECT SIMPLE VARIABLES
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@2: lda #7 ; LENGTH OF EACH VARIABLE IS 7 BYTES
|
|
|
|
sta DSCLEN
|
|
|
|
lda VARTAB ; START AT BEGINNING OF VARTAB
|
|
|
|
ldx VARTAB+1
|
|
|
|
sta INDEX
|
|
|
|
stx INDEX+1
|
|
|
|
@3: cpx ARYTAB+1 ; FINISHED WITH SIMPLE VARIABLES?
|
|
|
|
bne @4 ; NO
|
|
|
|
cmp ARYTAB ; MAYBE, CHECK LO-BYTE
|
|
|
|
beq @5 ; YES, NOW DO ARRAYS
|
|
|
|
@4: jsr CHECK_SIMPLE_VARIABLE
|
|
|
|
beq @3 ; ...ALWAYS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NOW COLLECT ARRAY VARIABLES
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@5: sta ARYPNT
|
|
|
|
stx ARYPNT+1
|
|
|
|
lda #3 ; DESCRIPTORS IN ARRAYS ARE 3-BYTES EACH
|
|
|
|
sta DSCLEN
|
|
|
|
@6: lda ARYPNT ; COMPARE TO END OF ARRAYS
|
|
|
|
ldx ARYPNT+1
|
|
|
|
@7: cpx STREND+1 ; FINISHED WITH ARRAYS YET?
|
|
|
|
bne @8 ; NOT YET
|
|
|
|
cmp STREND ; MAYBE, CHECK LO-BYTE
|
|
|
|
bne @8 ; NOT FINISHED YET
|
|
|
|
jmp MOVE_HIGHEST_STRING_TO_TOP ; FINISHED
|
|
|
|
@8: sta INDEX ; SET UP PNTR TO START OF ARRAY
|
|
|
|
stx INDEX+1
|
|
|
|
ldy #0 ; POINT AT NAME OF ARRAY
|
|
|
|
lda (INDEX),y
|
|
|
|
tax ; 1ST LETTER OF NAME IN X-REG
|
|
|
|
iny
|
|
|
|
lda (INDEX),y
|
|
|
|
php ; STATUS FROM SECOND LETTER OF NAME
|
|
|
|
iny
|
|
|
|
lda (INDEX),y ; OFFSET TO NEXT ARRAY
|
|
|
|
adc ARYPNT ; (CARRY ALWAYS CLEAR)
|
|
|
|
sta ARYPNT ; CALCULATE START OF NEXT ARRAY
|
|
|
|
iny
|
|
|
|
lda (INDEX),y ; HI-BYTE OF OFFSET
|
|
|
|
adc ARYPNT+1
|
|
|
|
sta ARYPNT+1
|
|
|
|
plp ; GET STATUS FROM 2ND CHAR OF NAME
|
|
|
|
bpl @6 ; NOT A STRING ARRAY
|
|
|
|
txa ; SET STATUS WITH 1ST CHAR OF NAME
|
|
|
|
bmi @6 ; NOT A STRING ARRAY
|
|
|
|
iny
|
|
|
|
lda (INDEX),y ; # OF DIMENSIONS FOR THIS ARRAY
|
|
|
|
ldy #0
|
|
|
|
asl a ; PREAMBLE SIZE = 2*#DIMS + 5
|
|
|
|
adc #5
|
|
|
|
adc INDEX ; MAKE INDEX POINT AT FIRST ELEMENT
|
|
|
|
sta INDEX ; IN THE ARRAY
|
|
|
|
bcc @9
|
|
|
|
inc INDEX+1
|
|
|
|
@9: ldx INDEX+1 ; STEP THRU EACH STRING IN THIS ARRAY
|
|
|
|
@10: cpx ARYPNT+1 ; ARRAY DONE?
|
|
|
|
bne @11 ; NO, PROCESS NEXT ELEMENT
|
|
|
|
cmp ARYPNT ; MAYBE, CHECK LO-BYTE
|
|
|
|
beq @7 ; YES, MOVE TO NEXT ARRAY
|
|
|
|
@11: jsr CHECK_VARIABLE ; PROCESS THE ARRAY
|
|
|
|
beq @10 ; ...ALWAYS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; PROCESS A SIMPLE VARIABLE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CHECK_SIMPLE_VARIABLE:
|
|
|
|
lda (INDEX),y ; LOOK AT 1ST CHAR OF NAME
|
|
|
|
bmi CHECK_BUMP ; NOT A STRING VARIABLE
|
|
|
|
iny
|
|
|
|
lda (INDEX),y ; LOOK AT 2ND CHAR OF NAME
|
|
|
|
bpl CHECK_BUMP ; NOT A STRING VARIABLE
|
|
|
|
iny
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; IF STRING IS NOT EMPTY, CHECK IF IT IS HIGHEST
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CHECK_VARIABLE:
|
|
|
|
lda (INDEX),y ; GET LENGTH OF STRING
|
|
|
|
beq CHECK_BUMP ; IGNORE STRING IF LENGTH IS ZERO
|
|
|
|
iny
|
|
|
|
lda (INDEX),y ; GET ADDRESS OF STRING
|
|
|
|
tax
|
|
|
|
iny
|
|
|
|
lda (INDEX),y
|
|
|
|
cmp FRETOP+1 ; CHECK IF ALREADY COLLECTED
|
|
|
|
bcc @1 ; NO, BELOW FRETOP
|
|
|
|
bne CHECK_BUMP ; YES, ABOVE FRETOP
|
|
|
|
cpx FRETOP ; MAYBE, CHECK LO-BYTE
|
|
|
|
bcs CHECK_BUMP ; YES, ABOVE FRETOP
|
|
|
|
@1: cmp LOWTR+1 ; ABOVE HIGHEST STRING FOUND?
|
|
|
|
bcc CHECK_BUMP ; NO, IGNORE FOR NOW
|
|
|
|
bne @2 ; YES, THIS IS THE NEW HIGHEST
|
|
|
|
cpx LOWTR ; MAYBE, TRY LO-BYTE
|
|
|
|
bcc CHECK_BUMP ; NO, IGNORE FOR NOW
|
|
|
|
@2: stx LOWTR ; MAKE THIS THE HIGHEST STRING
|
|
|
|
sta LOWTR+1
|
|
|
|
lda INDEX ; SAVE ADDRESS OF DESCRIPTOR TOO
|
|
|
|
ldx INDEX+1
|
|
|
|
sta FNCNAM
|
|
|
|
stx FNCNAM+1
|
|
|
|
lda DSCLEN
|
|
|
|
sta LENGTH
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ADD (DSCLEN) TO PNTR IN INDEX
|
|
|
|
; RETURN WITH Y=0, PNTR ALSO IN X,A
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CHECK_BUMP:
|
|
|
|
lda DSCLEN ; BUMP TO NEXT VARIABLE
|
|
|
|
clc
|
|
|
|
adc INDEX
|
|
|
|
sta INDEX
|
|
|
|
bcc CHECK_EXIT
|
|
|
|
inc INDEX+1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CHECK_EXIT:
|
|
|
|
ldx INDEX+1
|
|
|
|
ldy #0
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FOUND HIGHEST NON-EMPTY STRING, SO MOVE IT
|
|
|
|
; TO TOP AND GO BACK FOR ANOTHER
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MOVE_HIGHEST_STRING_TO_TOP:
|
|
|
|
ldx FNCNAM+1 ; ANY STRING FOUND?
|
|
|
|
beq CHECK_EXIT ; NO, RETURN
|
|
|
|
lda LENGTH ; GET LENGTH OF VARIABLE ELEMENT
|
|
|
|
and #4 ; WAS 7 OR 3, MAKE 4 OR 0
|
|
|
|
lsr a ; 2 0R 0; IN SIMPLE VARIABLES,
|
|
|
|
tay ; NAME PRECEDES DESCRIPTOR
|
|
|
|
sta LENGTH ; 2 OR 0
|
|
|
|
lda (FNCNAM),y ; GET LENGTH FROM DESCRIPTOR
|
|
|
|
adc LOWTR ; CARRY ALREADY CLEARED BY LSR
|
|
|
|
sta HIGHTR ; STRING IS BTWN (LOWTR) AND (HIGHTR)
|
|
|
|
lda LOWTR+1
|
|
|
|
adc #0
|
|
|
|
sta HIGHTR+1
|
|
|
|
lda FRETOP ; HIGH END DESTINATION
|
|
|
|
ldx FRETOP+1
|
|
|
|
sta HIGHDS
|
|
|
|
stx HIGHDS+1
|
|
|
|
jsr BLTU2 ; MOVE STRING UP
|
|
|
|
ldy LENGTH ; FIX ITS DESCRIPTOR
|
|
|
|
iny ; POINT AT ADDRESS IN DESCRIPTOR
|
|
|
|
lda HIGHDS ; STORE NEW ADDRESS
|
|
|
|
sta (FNCNAM),y
|
|
|
|
tax
|
|
|
|
inc HIGHDS+1 ; CORRECT BLTU'S OVERSHOOT
|
|
|
|
lda HIGHDS+1
|
|
|
|
iny
|
|
|
|
sta (FNCNAM),y
|
|
|
|
jmp FINDHIGHESTSTRING
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; CONCATENATE TWO STRINGS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CAT: lda FAC+4 ; SAVE ADDRESS OF FIRST DESCRIPTOR
|
|
|
|
pha
|
|
|
|
lda FAC+3
|
|
|
|
pha
|
|
|
|
jsr FRM_ELEMENT ; GET SECOND STRING ELEMENT
|
|
|
|
jsr CHKSTR ; MUST BE A STRING
|
|
|
|
pla ; RECOVER ADDRES OF 1ST DESCRIPTOR
|
|
|
|
sta STRNG1
|
|
|
|
pla
|
|
|
|
sta STRNG1+1
|
|
|
|
ldy #0
|
|
|
|
lda (STRNG1),y ; ADD LENGTHS, GET CONCATENATED SIZE
|
|
|
|
clc
|
|
|
|
adc (FAC+3),y
|
|
|
|
bcc @1 ; OK IF < $100
|
|
|
|
ldx #ERR_STRLONG
|
|
|
|
jmp ERROR
|
|
|
|
@1: jsr STRINI ; GET SPACE FOR CONCATENATED STRINGS
|
|
|
|
jsr MOVINS ; MOVE 1ST STRING
|
|
|
|
lda DSCPTR
|
|
|
|
ldy DSCPTR+1
|
|
|
|
jsr FRETMP
|
|
|
|
jsr MOVSTR1 ; MOVE 2ND STRING
|
|
|
|
lda STRNG1
|
|
|
|
ldy STRNG1+1
|
|
|
|
jsr FRETMP
|
|
|
|
jsr PUTNEW ; SET UP DESCRIPTOR
|
|
|
|
jmp FRMEVL2 ; FINISH EXPRESSION
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; GET STRING DESCRIPTOR POINTED AT BY (STRNG1)
|
|
|
|
; AND MOVE DESCRIBED STRING TO (FRESPC)
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MOVINS: ldy #0
|
|
|
|
lda (STRNG1),y
|
|
|
|
pha ; LENGTH
|
|
|
|
iny
|
|
|
|
lda (STRNG1),y
|
|
|
|
tax ; PUT STRING POINTER IN X,Y
|
|
|
|
iny
|
|
|
|
lda (STRNG1),y
|
|
|
|
tay
|
|
|
|
pla ; RETRIEVE LENGTH
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MOVE STRING AT (Y,X) WITH LENGTH (A)
|
|
|
|
; TO DESTINATION WHOSE ADDRESS IS IN FRESPC,FRESPC+1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MOVSTR: stx INDEX ; PUT POINTER IN INDEX
|
|
|
|
sty INDEX+1
|
|
|
|
MOVSTR1:
|
|
|
|
tay ; LENGTH TO Y-REG
|
|
|
|
beq @2 ; IF LENGTH IS ZERO, FINISHED
|
|
|
|
pha ; SAVE LENGTH ON STACK
|
|
|
|
@1: dey ; MOVE BYTES FROM (INDEX) TO (FRESPC)
|
|
|
|
lda (INDEX),y
|
|
|
|
sta (FRESPC),y
|
|
|
|
tya ; TEST IF ANY LEFT TO MOVE
|
|
|
|
bne @1 ; YES, KEEP MOVING
|
|
|
|
pla ; NO, FINISHED. GET LENGTH
|
|
|
|
@2: clc ; AND ADD TO FRESPC, SO
|
|
|
|
adc FRESPC ; FRESPC POINTS TO NEXT HIGHER
|
|
|
|
sta FRESPC ; BYTE. (USED BY CONCATENATION)
|
|
|
|
bcc @4
|
|
|
|
inc FRESPC+1
|
|
|
|
@4: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; IF (FAC) IS A TEMPORARY STRING, RELEASE DESCRIPTOR
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FRESTR: jsr CHKSTR ; LAST RESULT A STRING?
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; IF STRING DESCRIPTOR POINTED TO BY FAC+3,4 IS
|
|
|
|
; A TEMPORARY STRING, RELEASE IT.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FREFAC: lda FAC+3 ; GET DESCRIPTOR POINTER
|
|
|
|
ldy FAC+4
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; IF STRING DESCRIPTOR WHOSE ADDRESS IS IN Y,A IS
|
|
|
|
; A TEMPORARY STRING, RELEASE IT.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FRETMP: sta INDEX ; SAVE THE ADDRESS OF THE DESCRIPTOR
|
|
|
|
sty INDEX+1
|
|
|
|
jsr FRETMS ; FREE DESCRIPTOR IF IT IS TEMPORARY
|
|
|
|
php ; REMEMBER IF TEMP
|
|
|
|
ldy #0 ; POINT AT LENGTH OF STRING
|
|
|
|
lda (INDEX),y
|
|
|
|
pha ; SAVE LENGTH ON STACK
|
|
|
|
iny
|
|
|
|
lda (INDEX),y
|
|
|
|
tax ; GET ADDRESS OF STRING IN Y,X
|
|
|
|
iny
|
|
|
|
lda (INDEX),y
|
|
|
|
tay
|
|
|
|
pla ; LENGTH IN A
|
|
|
|
plp ; RETRIEVE STATUS, Z=1 IF TEMP
|
|
|
|
bne @2 ; NOT A TEMPORARY STRING
|
|
|
|
cpy FRETOP+1 ; IS IT THE LOWEST STRING?
|
|
|
|
bne @2 ; NO
|
|
|
|
cpx FRETOP
|
|
|
|
bne @2 ; NO
|
|
|
|
pha ; YES, PUSH LENGTH AGAIN
|
|
|
|
clc ; RECOVER THE SPACE USED BY
|
|
|
|
adc FRETOP ; THE STRING
|
|
|
|
sta FRETOP
|
|
|
|
bcc @1
|
|
|
|
inc FRETOP+1
|
|
|
|
@1: pla ; RETRIEVE LENGTH AGAIN
|
|
|
|
@2: stx INDEX ; ADDRESS OF STRING IN Y,X
|
|
|
|
sty INDEX+1 ; LENGTH OF STRING IN A-REG
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; RELEASE TEMPORARY DESCRIPTOR IF Y,A = LASTPT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FRETMS: cpy LASTPT+1 ; COMPARE Y,A TO LATEST TEMP
|
|
|
|
bne @1 ; NOT SAME ONE, CANNOT RELEASE
|
|
|
|
cmp LASTPT
|
|
|
|
bne @1 ; NOT SAME ONE, CANNOT RELEASE
|
|
|
|
sta TEMPPT ; UPDATE TEMPT FOR NEXT TEMP
|
|
|
|
sbc #3 ; BACK OFF LASTPT
|
|
|
|
sta LASTPT
|
|
|
|
ldy #0 ; NOW Y,A POINTS TO TOP TEMP
|
|
|
|
@1: rts ; Z=0 IF NOT TEMP, Z=1 IF TEMP
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "CHR$" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CHRSTR: jsr CONINT ; CONVERT ARGUMENT TO BYTE IN X
|
|
|
|
txa
|
|
|
|
pha ; SAVE IT
|
|
|
|
lda #1 ; GET SPACE FOR STRING OF LENGTH 1
|
|
|
|
jsr STRSPA
|
|
|
|
pla ; RECALL THE CHARACTER
|
|
|
|
ldy #0 ; PUT IN STRING
|
|
|
|
sta (FAC+1),y
|
|
|
|
pla ; POP RETURN ADDRESS
|
|
|
|
pla
|
|
|
|
jmp PUTNEW ; MAKE IT A TEMPORARY STRING
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "LEFT$" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
LEFTSTR:
|
|
|
|
jsr SUBSTRING_SETUP
|
|
|
|
cmp (DSCPTR),y ; COMPARE 1ST PARAMETER TO LENGTH
|
|
|
|
tya ; Y=A=0
|
|
|
|
SUBSTRING1:
|
|
|
|
bcc @1 ; 1ST PARAMETER SMALLER, USE IT
|
|
|
|
lda (DSCPTR),y ; 1ST IS LONGER, USE STRING LENGTH
|
|
|
|
tax ; IN X-REG
|
|
|
|
tya ; Y=A=0 AGAIN
|
|
|
|
@1: pha ; PUSH LEFT END OF SUBSTRING
|
|
|
|
SUBSTRING2:
|
|
|
|
txa
|
|
|
|
SUBSTRING3:
|
|
|
|
pha ; PUSH LENGTH OF SUBSTRING
|
|
|
|
jsr STRSPA ; MAKE ROOM FOR STRING OF (A) BYTES
|
|
|
|
lda DSCPTR ; RELEASE PARAMETER STRING IF TEMP
|
|
|
|
ldy DSCPTR+1
|
|
|
|
jsr FRETMP
|
|
|
|
pla ; GET LENGTH OF SUBSTRING
|
|
|
|
tay ; IN Y-REG
|
|
|
|
pla ; GET LEFT END OF SUBSTRING
|
|
|
|
clc ; ADD TO POINTER TO STRING
|
|
|
|
adc INDEX
|
|
|
|
sta INDEX
|
|
|
|
bcc @1
|
|
|
|
inc INDEX+1
|
|
|
|
@1: tya ; LENGTH
|
|
|
|
jsr MOVSTR1 ; COPY STRING INTO SPACE
|
|
|
|
jmp PUTNEW ; ADD TO TEMPS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "RIGHT$" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
RIGHTSTR:
|
|
|
|
jsr SUBSTRING_SETUP
|
|
|
|
clc ; COMPUTE LENGTH-WIDTH OF SUBSTRING
|
|
|
|
sbc (DSCPTR),y ; TO GET STARTING POINT IN STRING
|
|
|
|
eor #$FF
|
|
|
|
jmp SUBSTRING1 ; JOIN LEFT$
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "MID$" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MIDSTR: lda #$FF ; FLAG WHETHER 2ND PARAMETER
|
|
|
|
sta FAC+4
|
|
|
|
jsr CHRGOT ; SEE IF ")" YET
|
|
|
|
cmp #')'
|
|
|
|
beq @1 ; YES, NO 2ND PARAMETER
|
|
|
|
jsr CHKCOM ; NO, MUST HAVE COMMA
|
|
|
|
jsr GETBYT ; GET 2ND PARAM IN X-REG
|
|
|
|
@1: jsr SUBSTRING_SETUP
|
|
|
|
dex ; 1ST PARAMETER - 1
|
|
|
|
txa
|
|
|
|
pha
|
|
|
|
clc
|
|
|
|
ldx #0
|
|
|
|
sbc (DSCPTR),y
|
|
|
|
bcs SUBSTRING2
|
|
|
|
eor #$FF
|
|
|
|
cmp FAC+4 ; USE SMALLER OF TWO
|
|
|
|
bcc SUBSTRING3
|
|
|
|
lda FAC+4
|
|
|
|
bcs SUBSTRING3 ; ...ALWAYS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; COMMON SETUP ROUTINE FOR LEFT$, RIGHT$, MID$:
|
|
|
|
; REQUIRE ")"; POP RETURN ADRS, GET DESCRIPTOR
|
|
|
|
; ADDRESS, GET 1ST PARAMETER OF COMMAND
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SUBSTRING_SETUP:
|
|
|
|
jsr CHKCLS ; REQUIRE ")"
|
|
|
|
pla ; SAVE RETURN ADDRESS
|
|
|
|
tay ; IN Y-REG AND LENGTH
|
|
|
|
pla
|
|
|
|
sta LENGTH
|
|
|
|
pla ; POP PREVIOUS RETURN ADDRESS
|
|
|
|
pla ; (FROM GOROUT).
|
|
|
|
pla ; RETRIEVE 1ST PARAMETER
|
|
|
|
tax
|
|
|
|
pla ; GET ADDRESS OF STRING DESCRIPTOR
|
|
|
|
sta DSCPTR
|
|
|
|
pla
|
|
|
|
sta DSCPTR+1
|
|
|
|
lda LENGTH ; RESTORE RETURN ADDRESS
|
|
|
|
pha
|
|
|
|
tya
|
|
|
|
pha
|
|
|
|
ldy #0
|
|
|
|
txa ; GET 1ST PARAMETER IN A-REG
|
|
|
|
beq GOIQ ; ERROR IF 0
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "LEN" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
LEN: jsr GETSTR ; GET LENTGH IN Y-REG, MAKE FAC NUMERIC
|
|
|
|
jmp SNGFLT ; FLOAT Y-REG INTO FAC
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; IF LAST RESULT IS A TEMPORARY STRING, FREE IT
|
|
|
|
; MAKE VALTYP NUMERIC, RETURN LENGTH IN Y-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GETSTR: jsr FRESTR ; IF LAST RESULT IS A STRING, FREE IT
|
|
|
|
ldx #0 ; MAKE VALTYP NUMERIC
|
|
|
|
stx VALTYP
|
|
|
|
tay ; LENGTH OF STRING TO Y-REG
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "ASC" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ASC: jsr GETSTR ; GET STRING, GET LENGTH IN Y-REG
|
|
|
|
beq GOIQ ; ERROR IF LENGTH 0
|
|
|
|
ldy #0
|
|
|
|
lda (INDEX),y ; GET 1ST CHAR OF STRING
|
|
|
|
tay
|
|
|
|
jmp SNGFLT ; FLOAT Y-REG INTO FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GOIQ: jmp IQERR ; ILLEGAL QUANTITY ERROR
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; SCAN TO NEXT CHARACTER AND CONVERT EXPRESSION
|
|
|
|
; TO SINGLE BYTE IN X-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GTBYTC: jsr CHRGET
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; EVALUATE EXPRESSION AT TXTPTR, AND
|
|
|
|
; CONVERT IT TO SINGLE BYTE IN X-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GETBYT: jsr FRMNUM
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; CONVERT (FAC) TO SINGLE BYTE INTEGER IN X-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CONINT: jsr MKINT ; CONVERT IF IN RANGE -32767 TO +32767
|
|
|
|
ldx FAC+3 ; HI-BYTE MUST BE ZERO
|
|
|
|
bne GOIQ ; VALUE > 255, ERROR
|
|
|
|
ldx FAC+4 ; VALUE IN X-REG
|
|
|
|
jmp CHRGOT ; GET NEXT CHAR IN A-REG
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "VAL" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
VAL: jsr GETSTR ; GET POINTER TO STRING IN INDEX
|
|
|
|
bne @1 ; LENGTH NON-ZERO
|
|
|
|
jmp ZERO_FAC ; RETURN 0 IF LENGTH=0
|
|
|
|
@1: ldx TXTPTR ; SAVE CURRENT TXTPTR
|
|
|
|
ldy TXTPTR+1
|
|
|
|
stx STRNG2
|
|
|
|
sty STRNG2+1
|
|
|
|
ldx INDEX
|
|
|
|
stx TXTPTR ; POINT TXTPTR TO START OF STRING
|
|
|
|
clc
|
|
|
|
adc INDEX ; ADD LENGTH
|
|
|
|
sta DEST ; POINT DEST TO END OF STRING + 1
|
|
|
|
ldx INDEX+1
|
|
|
|
stx TXTPTR+1
|
|
|
|
bcc @2
|
|
|
|
inx
|
|
|
|
@2: stx DEST+1
|
|
|
|
ldy #0 ; SAVE BYTE THAT FOLLOWS STRING
|
|
|
|
lda (DEST),y ; ON STACK
|
|
|
|
pha
|
|
|
|
lda #0 ; AND STORE $00 IN ITS PLACE
|
|
|
|
sta (DEST),y
|
|
|
|
jsr CHRGOT ; PRIME THE PUMP
|
|
|
|
jsr FIN ; EVALUATE STRING
|
|
|
|
pla ; GET BYTE THAT SHOULD FOLLOW STRING
|
|
|
|
ldy #0 ; AND PUT IT BACK
|
|
|
|
sta (DEST),y
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; COPY STRNG2 INTO TXTPTR
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
POINT: ldx STRNG2
|
|
|
|
ldy STRNG2+1
|
|
|
|
stx TXTPTR
|
|
|
|
sty TXTPTR+1
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; EVALUATE "EXP1,EXP2"
|
|
|
|
;
|
|
|
|
; CONVERT EXP1 TO 16-BIT NUMBER IN LINNUM
|
|
|
|
; CONVERT EXP2 TO 8-BIT NUMBER IN X-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GTNUM: jsr FRMNUM
|
|
|
|
jsr GETADR
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; EVALUATE ",EXPRESSION"
|
|
|
|
; CONVERT EXPRESSION TO SINGLE BYTE IN X-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
COMBYTE:
|
|
|
|
jsr CHKCOM ; MUST HAVE COMMA FIRST
|
|
|
|
jmp GETBYT ; CONVERT EXPRESSION TO BYTE IN X-REG
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; CONVERT (FAC) TO A 16-BIT VALUE IN LINNUM
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GETADR: lda FAC ; FAC < 2^16?
|
|
|
|
cmp #$91
|
|
|
|
bcs GOIQ ; NO, ILLEGAL QUANTITY
|
|
|
|
jsr QINT ; CONVERT TO INTEGER
|
|
|
|
lda FAC+3 ; COPY IT INTO LINNUM
|
|
|
|
ldy FAC+4
|
|
|
|
sty LINNUM ; TO LINNUM
|
|
|
|
sta LINNUM+1
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "PEEK" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
PEEK: lda LINNUM ; SAVE (LINNUM) ON STACK DURING PEEK
|
|
|
|
pha
|
|
|
|
lda LINNUM+1
|
|
|
|
pha
|
|
|
|
jsr GETADR ; GET ADDRESS PEEKING AT
|
|
|
|
ldy #0
|
|
|
|
lda (LINNUM),y ; TAKE A QUICK LOOK
|
|
|
|
tay ; VALUE IN Y-REG
|
|
|
|
pla ; RESTORE LINNUM FROM STACK
|
|
|
|
sta LINNUM+1
|
|
|
|
pla
|
|
|
|
sta LINNUM
|
|
|
|
jmp SNGFLT ; FLOAT Y-REG INTO FAC
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "POKE" STATEMENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
POKE: jsr GTNUM ; GET THE ADDRESS AND VALUE
|
|
|
|
txa ; VALUE IN A,
|
|
|
|
ldy #0
|
|
|
|
sta (LINNUM),y ; STORE IT AWAY,
|
|
|
|
RTS10: rts ; AND THAT'S ALL FOR TODAY
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ADD 0.5 TO FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FADDH: lda #<CON_HALF ; FAC+1/2 -> FAC
|
|
|
|
ldy #>CON_HALF
|
|
|
|
jmp FADD
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = (Y,A) - FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FSUB: jsr LOAD_ARG_FROM_YA
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = ARG - FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FSUBT: lda FACSIGN ; COMPLEMENT FAC AND ADD
|
|
|
|
eor #$FF
|
|
|
|
sta FACSIGN
|
|
|
|
eor ARGSIGN ; FIX SGNCPR TOO
|
|
|
|
sta SGNCPR
|
|
|
|
lda FAC ; MAKE STATUS SHOW FAC EXPONENT
|
|
|
|
jmp FADDT ; JOIN FADD
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; SHIFT SMALLER ARGUMENT MORE THAN 7 BITS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FADD1: jsr SHIFT_RIGHT ; ALIGN RADIX BY SHIFTING
|
|
|
|
bcc FADD3 ; ...ALWAYS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = (Y,A) + FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FADD: jsr LOAD_ARG_FROM_YA
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = ARG + FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FADDT: bne @1 ; FAC IS NON-ZERO
|
|
|
|
jmp COPY_ARG_TO_FAC ; FAC = 0 + ARG
|
|
|
|
@1: ldx FACEXTENSION
|
|
|
|
stx ARGEXTENSION
|
|
|
|
ldx #ARG ; SET UP TO SHIFT ARG
|
|
|
|
lda ARG ; EXPONENT
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FADD2: tay
|
|
|
|
beq RTS10 ; IF ARG=0, WE ARE FINISHED
|
|
|
|
sec
|
|
|
|
sbc FAC ; GET DIFFNCE OF EXP
|
|
|
|
beq FADD3 ; GO ADD IF SAME EXP
|
|
|
|
bcc @1 ; ARG HAS SMALLER EXPONENT
|
|
|
|
sty FAC ; EXP HAS SMALLER EXPONENT
|
|
|
|
ldy ARGSIGN
|
|
|
|
sty FACSIGN
|
|
|
|
eor #$FF ; COMPLEMENT SHIFT COUNT
|
|
|
|
adc #0 ; CARRY WAS SET
|
|
|
|
ldy #0
|
|
|
|
sty ARGEXTENSION
|
|
|
|
ldx #FAC ; SET UP TO SHIFT FAC
|
|
|
|
bne @2 ; ...ALWAYS
|
|
|
|
@1: ldy #0
|
|
|
|
sty FACEXTENSION
|
|
|
|
@2: cmp #$F9 ; SHIFT MORE THAN 7 BITS?
|
|
|
|
bmi FADD1 ; YES
|
|
|
|
tay ; INDEX TO # OF SHIFTS
|
|
|
|
lda FACEXTENSION
|
|
|
|
lsr 1,x ; START SHIFTING...
|
|
|
|
jsr SHIFT_RIGHT4 ; ...COMPLETE SHIFTING
|
|
|
|
FADD3: bit SGNCPR ; DO FAC AND ARG HAVE SAME SIGNS?
|
|
|
|
bpl FADD4 ; YES, ADD THE MANTISSAS
|
|
|
|
ldy #FAC ; NO, SUBTRACT SMALLER FROM LARGER
|
|
|
|
cpx #ARG ; WHICH WAS ADJUSTED?
|
|
|
|
beq @1 ; IF ARG, DO FAC-ARG
|
|
|
|
ldy #ARG ; IF FAC, DO ARG-FAC
|
|
|
|
@1: sec ; SUBTRACT SMALLER FROM LARGER (WE HOPE)
|
|
|
|
eor #$FF ; (IF EXPONENTS WERE EQUAL, WE MIGHT BE
|
|
|
|
adc ARGEXTENSION ; SUBTRACTING LARGER FROM SMALLER)
|
|
|
|
sta FACEXTENSION
|
|
|
|
lda 4,y
|
|
|
|
sbc 4,x
|
|
|
|
sta FAC+4
|
|
|
|
lda 3,y
|
|
|
|
sbc 3,x
|
|
|
|
sta FAC+3
|
|
|
|
lda 2,y
|
|
|
|
sbc 2,x
|
|
|
|
sta FAC+2
|
|
|
|
lda 1,y
|
|
|
|
sbc 1,x
|
|
|
|
sta FAC+1
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NORMALIZE VALUE IN FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
NORMALIZE_FAC1:
|
|
|
|
bcs NORMALIZE_FAC2
|
|
|
|
jsr COMPLEMENT_FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
NORMALIZE_FAC2:
|
|
|
|
ldy #0 ; SHIFT UP SIGNIF DIGIT
|
|
|
|
tya ; START A=0, COUNT SHIFTS IN A-REG
|
|
|
|
clc
|
|
|
|
@1: ldx FAC+1 ; LOOK AT MOST SIGNIFICANT BYTE
|
|
|
|
bne NORMALIZE_FAC4 ; SOME 1-BITS HERE
|
|
|
|
ldx FAC+2 ; HI-BYTE OF MANTISSA STILL ZERO,
|
|
|
|
stx FAC+1 ; SO DO A FAST 8-BIT SHUFFLE
|
|
|
|
ldx FAC+3
|
|
|
|
stx FAC+2
|
|
|
|
ldx FAC+4
|
|
|
|
stx FAC+3
|
|
|
|
ldx FACEXTENSION
|
|
|
|
stx FAC+4
|
|
|
|
sty FACEXTENSION ; ZERO EXTENSION BYTE
|
|
|
|
adc #8 ; BUMP SHIFT COUNT
|
|
|
|
cmp #32 ; DONE 4 TIMES YET?
|
|
|
|
bne @1 ; NO, STILL MIGHT BE SOME 1'S (YES, VALUE OF FAC IS ZERO)
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; SET FAC = 0
|
|
|
|
; (ONLY NECESSARY TO ZERO EXPONENT AND SIGN CELLS)
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ZERO_FAC:
|
|
|
|
lda #0
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STA_IN_FAC_SIGN_AND_EXP:
|
|
|
|
sta FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STA_IN_FAC_SIGN:
|
|
|
|
sta FACSIGN
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ADD MANTISSAS OF FAC AND ARG INTO FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FADD4: adc ARGEXTENSION
|
|
|
|
sta FACEXTENSION
|
|
|
|
lda FAC+4
|
|
|
|
adc ARG+4
|
|
|
|
sta FAC+4
|
|
|
|
lda FAC+3
|
|
|
|
adc ARG+3
|
|
|
|
sta FAC+3
|
|
|
|
lda FAC+2
|
|
|
|
adc ARG+2
|
|
|
|
sta FAC+2
|
|
|
|
lda FAC+1
|
|
|
|
adc ARG+1
|
|
|
|
sta FAC+1
|
|
|
|
jmp NORMALIZE_FAC5
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FINISH NORMALIZING FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
NORMALIZE_FAC3:
|
|
|
|
adc #1 ; COUNT BITS SHIFTED
|
|
|
|
asl FACEXTENSION
|
|
|
|
rol FAC+4
|
|
|
|
rol FAC+3
|
|
|
|
rol FAC+2
|
|
|
|
rol FAC+1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
NORMALIZE_FAC4:
|
|
|
|
bpl NORMALIZE_FAC3 ; UNTIL TOP BIT = 1
|
|
|
|
sec
|
|
|
|
sbc FAC ; ADJUST EXPONENT BY BITS SHIFTED
|
|
|
|
bcs ZERO_FAC ; UNDERFLOW, RETURN ZERO
|
|
|
|
eor #$FF
|
|
|
|
adc #1 ; 2'S COMPLEMENT
|
|
|
|
sta FAC ; CARRY=0 NOW
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
NORMALIZE_FAC5:
|
|
|
|
bcc RTS11 ; UNLESS MANTISSA CARRIED
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
NORMALIZE_FAC6:
|
|
|
|
inc FAC ; MANTISSA CARRIED, SO SHIFT RIGHT
|
|
|
|
beq OVERFLOW ; OVERFLOW IF EXPONENT TOO BIG
|
|
|
|
ror FAC+1
|
|
|
|
ror FAC+2
|
|
|
|
ror FAC+3
|
|
|
|
ror FAC+4
|
|
|
|
ror FACEXTENSION
|
|
|
|
RTS11: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; 2'S COMPLEMENT OF FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
COMPLEMENT_FAC:
|
|
|
|
lda FACSIGN
|
|
|
|
eor #$FF
|
|
|
|
sta FACSIGN
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; 2'S COMPLEMENT OF FAC MANTISSA ONLY
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
COMPLEMENT_FAC_MANTISSA:
|
|
|
|
lda FAC+1
|
|
|
|
eor #$FF
|
|
|
|
sta FAC+1
|
|
|
|
lda FAC+2
|
|
|
|
eor #$FF
|
|
|
|
sta FAC+2
|
|
|
|
lda FAC+3
|
|
|
|
eor #$FF
|
|
|
|
sta FAC+3
|
|
|
|
lda FAC+4
|
|
|
|
eor #$FF
|
|
|
|
sta FAC+4
|
|
|
|
lda FACEXTENSION
|
|
|
|
eor #$FF
|
|
|
|
sta FACEXTENSION
|
|
|
|
inc FACEXTENSION ; START INCREMENTING MANTISSA
|
|
|
|
bne RTS12
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; INCREMENT FAC MANTISSA
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
INCREMENT_FAC_MANTISSA:
|
|
|
|
inc FAC+4 ; ADD CARRY FROM EXTRA
|
|
|
|
bne RTS12
|
|
|
|
inc FAC+3
|
|
|
|
bne RTS12
|
|
|
|
inc FAC+2
|
|
|
|
bne RTS12
|
|
|
|
inc FAC+1
|
|
|
|
RTS12: rts
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
OVERFLOW:
|
|
|
|
ldx #ERR_OVERFLOW
|
|
|
|
jmp ERROR
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; SHIFT 1,X THRU 5,X RIGHT
|
|
|
|
; (A) = NEGATIVE OF SHIFT COUNT
|
|
|
|
; (X) = POINTER TO BYTES TO BE SHIFTED
|
|
|
|
;
|
|
|
|
; RETURN WITH (Y)=0, CARRY=0, EXTENSION BITS IN A-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SHIFT_RIGHT1:
|
|
|
|
ldx #RESULT-1 ; SHIFT RESULT RIGHT
|
|
|
|
SHIFT_RIGHT2:
|
|
|
|
ldy 4,x ; SHIFT 8 BITS RIGHT
|
|
|
|
sty FACEXTENSION
|
|
|
|
ldy 3,x
|
|
|
|
sty 4,x
|
|
|
|
ldy 2,x
|
|
|
|
sty 3,x
|
|
|
|
ldy 1,x
|
|
|
|
sty 2,x
|
|
|
|
ldy SHIFTSIGNEXT ; $00 IF +, $FF IF -
|
|
|
|
sty 1,x
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MAIN ENTRY TO RIGHT SHIFT SUBROUTINE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SHIFT_RIGHT:
|
|
|
|
adc #8
|
|
|
|
bmi SHIFT_RIGHT2 ; STILL MORE THAN 8 BITS TO GO
|
|
|
|
beq SHIFT_RIGHT2 ; EXACTLY 8 MORE BITS TO GO
|
|
|
|
sbc #8 ; UNDO ADC ABOVE
|
|
|
|
tay ; REMAINING SHIFT COUNT
|
|
|
|
lda FACEXTENSION
|
|
|
|
bcs SHIFT_RIGHT5 ; FINISHED SHIFTING
|
|
|
|
SHIFT_RIGHT3:
|
|
|
|
asl 1,x ; SIGN -> CARRY (SIGN EXTENSION)
|
|
|
|
bcc @1 ; SIGN +
|
|
|
|
inc 1,x ; PUT SIGN IN LSB
|
|
|
|
@1: ror 1,x ; RESTORE VALUE, SIGN STILL IN CARRY
|
|
|
|
ror 1,x ; START RIGHT SHIFT, INSERTING SIGN
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ENTER HERE FOR SHORT SHIFTS WITH NO SIGN EXTENSION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SHIFT_RIGHT4:
|
|
|
|
ror 2,x
|
|
|
|
ror 3,x
|
|
|
|
ror 4,x
|
|
|
|
ror a ; EXTENSION
|
|
|
|
iny ; COUNT THE SHIFT
|
|
|
|
bne SHIFT_RIGHT3
|
|
|
|
SHIFT_RIGHT5:
|
|
|
|
clc ; RETURN WITH CARRY CLEAR
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CON_ONE:
|
|
|
|
.byte $81,$00,$00,$00,$00
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
POLY_LOG:
|
|
|
|
.byte $03 ; # OF COEFFICIENTS - 1
|
|
|
|
.byte $7F,$5E,$56,$CB,$79 ; * X^7 +
|
|
|
|
.byte $80,$13,$9B,$0B,$64 ; * X^5 +
|
|
|
|
.byte $80,$76,$38,$93,$16 ; * X^3 +
|
|
|
|
.byte $82,$38,$AA,$3B,$20 ; * X
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CON_SQR_HALF:
|
|
|
|
.byte $80,$35,$04,$F3,$34
|
|
|
|
CON_SQR_TWO:
|
|
|
|
.byte $81,$35,$04,$F3,$34
|
|
|
|
CON_NEG_HALF:
|
|
|
|
.byte $80,$80,$00,$00,$00
|
|
|
|
CON_LOG_TWO:
|
|
|
|
.byte $80,$31,$72,$17,$F8
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "LOG" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
LOG: jsr SIGN ; GET -1,0,+1 IN A-REG FOR FAC
|
|
|
|
beq GIQ ; LOG (0) IS ILLEGAL
|
|
|
|
bpl LOG2 ; >0 IS OK
|
|
|
|
GIQ: jmp IQERR ; <= 0 IS NO GOOD
|
|
|
|
LOG2: lda FAC ; FIRST GET LOG BASE 2
|
|
|
|
sbc #$7F ; SAVE UNBIASED EXPONENT
|
|
|
|
pha
|
|
|
|
lda #$80 ; NORMALIZE BETWEEN .5 AND 1
|
|
|
|
sta FAC
|
|
|
|
lda #<CON_SQR_HALF
|
|
|
|
ldy #>CON_SQR_HALF
|
|
|
|
jsr FADD ; COMPUTE VIA SERIES OF ODD
|
|
|
|
lda #<CON_SQR_TWO ; POWERS OF
|
|
|
|
ldy #>CON_SQR_TWO ; (SQR(2)X-1)/(SQR(2)X+1)
|
|
|
|
jsr FDIV
|
|
|
|
lda #<CON_ONE
|
|
|
|
ldy #>CON_ONE
|
|
|
|
jsr FSUB
|
|
|
|
lda #<POLY_LOG
|
|
|
|
ldy #>POLY_LOG
|
|
|
|
jsr POLYNOMIAL_ODD
|
|
|
|
lda #<CON_NEG_HALF
|
|
|
|
ldy #>CON_NEG_HALF
|
|
|
|
jsr FADD
|
|
|
|
pla
|
|
|
|
jsr ADDACC ; ADD ORIGINAL EXPONENT
|
|
|
|
lda #<CON_LOG_TWO ; MULTIPLY BY LOG(2) TO FORM
|
|
|
|
ldy #>CON_LOG_TWO ; NATURAL LOG OF X
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = (Y,A) * FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FMULT: jsr LOAD_ARG_FROM_YA
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = ARG * FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FMULTT: bne @1 ; FAC .NE. ZERO
|
|
|
|
rts ; FAC = 0 * ARG = 0
|
|
|
|
@1: jsr ADD_EXPONENTS
|
|
|
|
lda #0
|
|
|
|
sta RESULT ; INIT PRODUCT = 0
|
|
|
|
sta RESULT+1
|
|
|
|
sta RESULT+2
|
|
|
|
sta RESULT+3
|
|
|
|
lda FACEXTENSION
|
|
|
|
jsr MULTIPLY1
|
|
|
|
lda FAC+4
|
|
|
|
jsr MULTIPLY1
|
|
|
|
lda FAC+3
|
|
|
|
jsr MULTIPLY1
|
|
|
|
lda FAC+2
|
|
|
|
jsr MULTIPLY1
|
|
|
|
lda FAC+1
|
|
|
|
jsr MULTIPLY2
|
|
|
|
jmp COPY_RESULT_INTO_FAC
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MULTIPLY ARG BY (A) INTO RESULT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MULTIPLY1:
|
|
|
|
bne MULTIPLY2 ; THIS BYTE NON-ZERO
|
|
|
|
jmp SHIFT_RIGHT1 ; (A)=0, JUST SHIFT ARG RIGHT 8
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MULTIPLY2:
|
|
|
|
lsr a ; SHIFT BIT INTO CARRY
|
|
|
|
ora #$80 ; SUPPLY SENTINEL BIT
|
|
|
|
@1: tay ; REMAINING MULTIPLIER TO Y
|
|
|
|
bcc @2 ; THIS MULTIPLIER BIT = 0
|
|
|
|
clc ; = 1, SO ADD ARG TO RESULT
|
|
|
|
lda RESULT+3
|
|
|
|
adc ARG+4
|
|
|
|
sta RESULT+3
|
|
|
|
lda RESULT+2
|
|
|
|
adc ARG+3
|
|
|
|
sta RESULT+2
|
|
|
|
lda RESULT+1
|
|
|
|
adc ARG+2
|
|
|
|
sta RESULT+1
|
|
|
|
lda RESULT
|
|
|
|
adc ARG+1
|
|
|
|
sta RESULT
|
|
|
|
@2: ror RESULT ; SHIFT RESULT RIGHT 1
|
|
|
|
ror RESULT+1
|
|
|
|
ror RESULT+2
|
|
|
|
ror RESULT+3
|
|
|
|
ror FACEXTENSION
|
|
|
|
tya ; REMAINING MULTIPLIER
|
|
|
|
lsr a ; LSB INTO CARRY
|
|
|
|
bne @1 ; IF SENTINEL STILL HERE, MULTIPLY
|
|
|
|
rts ; 8 X 32 COMPLETED
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; UNPACK NUMBER AT (Y,A) INTO ARG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
LOAD_ARG_FROM_YA:
|
|
|
|
sta INDEX ; USE INDEX FOR PNTR
|
|
|
|
sty INDEX+1
|
|
|
|
ldy #4 ; FIVE BYTES TO MOVE
|
|
|
|
lda (INDEX),y
|
|
|
|
sta ARG+4
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta ARG+3
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta ARG+2
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta ARGSIGN
|
|
|
|
eor FACSIGN ; SET COMBINED SIGN FOR MULT/DIV
|
|
|
|
sta SGNCPR
|
|
|
|
lda ARGSIGN ; TURN ON NORMALIZED INVISIBLE BIT
|
|
|
|
ora #$80 ; TO COMPLETE MANTISSA
|
|
|
|
sta ARG+1
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta ARG ; EXPONENT
|
|
|
|
lda FAC ; SET STATUS BITS ON FAC EXPONENT
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ADD EXPONENTS OF ARG AND FAC
|
|
|
|
; (CALLED BY FMULT AND FDIV)
|
|
|
|
;
|
|
|
|
; ALSO CHECK FOR OVERFLOW, AND SET RESULT SIGN
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ADD_EXPONENTS:
|
|
|
|
lda ARG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ADD_EXPONENTS1:
|
|
|
|
beq ZERO ; IF ARG=0, RESULT IS ZERO
|
|
|
|
clc
|
|
|
|
adc FAC
|
|
|
|
bcc @1 ; IN RANGE
|
|
|
|
bmi JOV ; OVERFLOW
|
|
|
|
clc
|
|
|
|
.byte $2C ; TRICK TO SKIP
|
|
|
|
@1: bpl ZERO ; OVERFLOW
|
|
|
|
adc #$80 ; RE-BIAS
|
|
|
|
sta FAC ; RESULT
|
|
|
|
beq @3
|
|
|
|
@2: lda SGNCPR ; SET SIGN OF RESULT
|
|
|
|
@3: sta FACSIGN
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; IF (FAC) IS POSITIVE, GIVE "OVERFLOW" ERROR
|
|
|
|
; IF (FAC) IS NEGATIVE, SET FAC=0, POP ONE RETURN, AND RTS
|
|
|
|
; CALLED FROM "EXP" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
OUTOFRNG:
|
|
|
|
lda FACSIGN
|
|
|
|
eor #$FF
|
|
|
|
bmi JOV ; ERROR IF POSITIVE #
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; POP RETURN ADDRESS AND SET FAC=0
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ZERO: pla
|
|
|
|
pla
|
|
|
|
jmp ZERO_FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
JOV: jmp OVERFLOW
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MULTIPLY FAC BY 10
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
MUL10: jsr COPY_FAC_TO_ARG_ROUNDED
|
|
|
|
tax ; TEXT FAC EXPONENT
|
|
|
|
beq @1 ; FINISHED IF FAC=0
|
|
|
|
clc
|
|
|
|
adc #2 ; ADD 2 TO EXPONENT GIVES (FAC)*4
|
|
|
|
bcs JOV ; OVERFLOW
|
|
|
|
ldx #0
|
|
|
|
stx SGNCPR
|
|
|
|
jsr FADD2 ; MAKES (FAC)*5
|
|
|
|
inc FAC ; *2, MAKES (FAC)*10
|
|
|
|
beq JOV ; OVERFLOW
|
|
|
|
@1: rts
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CONTEN: .byte $84,$20,$00,$00,$00
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; DIVIDE FAC BY 10
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
DIV10: jsr COPY_FAC_TO_ARG_ROUNDED
|
|
|
|
lda #<CONTEN ; SET UP TO PUT
|
|
|
|
ldy #>CONTEN ; 10 IN FAC
|
|
|
|
ldx #0
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = ARG / (Y,A)
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
DIV: stx SGNCPR
|
|
|
|
jsr LOAD_FAC_FROM_YA
|
|
|
|
jmp FDIVT ; DIVIDE ARG BY FAC
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = (Y,A) / FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FDIV: jsr LOAD_ARG_FROM_YA
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC = ARG / FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FDIVT: beq @8 ; FAC = 0, DIVIDE BY ZERO ERROR
|
|
|
|
jsr ROUND_FAC
|
|
|
|
lda #0 ; NEGATE FAC EXPONENT, SO
|
|
|
|
sec ; ADD.EXPONENTS FORMS DIFFERENCE
|
|
|
|
sbc FAC
|
|
|
|
sta FAC
|
|
|
|
jsr ADD_EXPONENTS
|
|
|
|
inc FAC
|
|
|
|
beq JOV ; OVERFLOW
|
2021-01-16 00:08:36 +00:00
|
|
|
ldx #252 ; INDEX FOR RESULT
|
2017-05-11 20:42:22 +00:00
|
|
|
lda #1 ; SENTINEL
|
|
|
|
@1: ldy ARG+1 ; SEE IF FAC CAN BE SUBTRACTED
|
|
|
|
cpy FAC+1
|
|
|
|
bne @2
|
|
|
|
ldy ARG+2
|
|
|
|
cpy FAC+2
|
|
|
|
bne @2
|
|
|
|
ldy ARG+3
|
|
|
|
cpy FAC+3
|
|
|
|
bne @2
|
|
|
|
ldy ARG+4
|
|
|
|
cpy FAC+4
|
|
|
|
@2: php ; SAVE THE ANSWER, AND ALSO ROLL THE
|
|
|
|
rol a ; BIT INTO THE QUOTIENT, SENTINEL OUT
|
|
|
|
bcc @3 ; NO SENTINEL, STILL NOT 8 TRIPS
|
|
|
|
inx ; 8 TRIPS, STORE BYTE OF QUOTIENT
|
|
|
|
sta RESULT+3,x
|
|
|
|
beq @6 ; 32-BITS COMPLETED
|
|
|
|
bpl @7 ; FINAL EXIT WHEN X=1
|
|
|
|
lda #1 ; RE-START SENTINEL
|
|
|
|
@3: plp ; GET ANSWER, CAN FAC BE SUBTRACTED?
|
|
|
|
bcs @5 ; YES, DO IT
|
|
|
|
@4: asl ARG+4 ; NO, SHIFT ARG LEFT
|
|
|
|
rol ARG+3
|
|
|
|
rol ARG+2
|
|
|
|
rol ARG+1
|
|
|
|
bcs @2 ; ANOTHER TRIP
|
|
|
|
bmi @1 ; HAVE TO COMPARE FIRST
|
|
|
|
bpl @2 ; ...ALWAYS
|
|
|
|
@5: tay ; SAVE QUOTIENT/SENTINEL BYTE
|
|
|
|
lda ARG+4 ; SUBTRACT FAC FROM ARG ONCE
|
|
|
|
sbc FAC+4
|
|
|
|
sta ARG+4
|
|
|
|
lda ARG+3
|
|
|
|
sbc FAC+3
|
|
|
|
sta ARG+3
|
|
|
|
lda ARG+2
|
|
|
|
sbc FAC+2
|
|
|
|
sta ARG+2
|
|
|
|
lda ARG+1
|
|
|
|
sbc FAC+1
|
|
|
|
sta ARG+1
|
|
|
|
tya ; RESTORE QUOTIENT/SENTINEL BYTE
|
|
|
|
jmp @4 ; GO TO SHIFT ARG AND CONTINUE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@6: lda #$40 ; DO A FEW EXTENSION BITS
|
|
|
|
bne @3 ; ...ALWAYS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@7: asl a ; LEFT JUSTIFY THE EXTENSION BITS WE DID
|
|
|
|
asl a
|
|
|
|
asl a
|
|
|
|
asl a
|
|
|
|
asl a
|
|
|
|
asl a
|
|
|
|
sta FACEXTENSION
|
|
|
|
plp
|
|
|
|
jmp COPY_RESULT_INTO_FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@8: ldx #ERR_ZERODIV
|
|
|
|
jmp ERROR
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; COPY RESULT INTO FAC MANTISSA, AND NORMALIZE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
COPY_RESULT_INTO_FAC:
|
|
|
|
lda RESULT
|
|
|
|
sta FAC+1
|
|
|
|
lda RESULT+1
|
|
|
|
sta FAC+2
|
|
|
|
lda RESULT+2
|
|
|
|
sta FAC+3
|
|
|
|
lda RESULT+3
|
|
|
|
sta FAC+4
|
|
|
|
jmp NORMALIZE_FAC2
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; UNPACK (Y,A) INTO FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
LOAD_FAC_FROM_YA:
|
|
|
|
sta INDEX ; USE INDEX FOR PNTR
|
|
|
|
sty INDEX+1
|
|
|
|
ldy #4 ; PICK UP 5 BYTES
|
|
|
|
lda (INDEX),y
|
|
|
|
sta FAC+4
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta FAC+3
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta FAC+2
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta FACSIGN ; FIRST BIT IS SIGN
|
|
|
|
ora #$80 ; SET NORMALIZED INVISIBLE BIT
|
|
|
|
sta FAC+1
|
|
|
|
dey
|
|
|
|
lda (INDEX),y
|
|
|
|
sta FAC ; EXPONENT
|
|
|
|
sty FACEXTENSION ; Y=0
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ROUND FAC, STORE IN TEMP2
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STORE_FAC_IN_TEMP2_ROUNDED:
|
|
|
|
ldx #TEMP2 ; PACK FAC INTO TEMP2
|
|
|
|
.byte $2C ; TRICK TO BRANCH
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ROUND FAC, STORE IN TEMP1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STORE_FAC_IN_TEMP1_ROUNDED:
|
|
|
|
ldx #<TEMP1 ; PACK FAC INTO TEMP1
|
|
|
|
ldy #>TEMP1 ; HI-BYTE OF TEMP1 SAME AS TEMP2
|
|
|
|
beq STORE_FAC_AT_YX_ROUNDED ; ...ALWAYS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ROUND FAC, AND STORE WHERE FORPNT POINTS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SETFOR: ldx FORPNT
|
|
|
|
ldy FORPNT+1
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ROUND FAC, AND STORE AT (Y,X)
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STORE_FAC_AT_YX_ROUNDED:
|
|
|
|
jsr ROUND_FAC ; ROUND VALUE IN FAC USING EXTENSION
|
|
|
|
stx INDEX ; USE INDEX FOR PNTR
|
|
|
|
sty INDEX+1
|
|
|
|
ldy #4 ; STORING 5 PACKED BYTES
|
|
|
|
lda FAC+4
|
|
|
|
sta (INDEX),y
|
|
|
|
dey
|
|
|
|
lda FAC+3
|
|
|
|
sta (INDEX),y
|
|
|
|
dey
|
|
|
|
lda FAC+2
|
|
|
|
sta (INDEX),y
|
|
|
|
dey
|
|
|
|
lda FACSIGN ; PACK SIGN IN TOP BIT OF MANTISSA
|
|
|
|
ora #$7F
|
|
|
|
and FAC+1
|
|
|
|
sta (INDEX),y
|
|
|
|
dey
|
|
|
|
lda FAC ; EXPONENT
|
|
|
|
sta (INDEX),y
|
|
|
|
sty FACEXTENSION ; ZERO THE EXTENSION
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; COPY ARG INTO FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
COPY_ARG_TO_FAC:
|
|
|
|
lda ARGSIGN ; COPY SIGN
|
|
|
|
MFA: sta FACSIGN
|
|
|
|
ldx #5 ; MOVE 5 BYTES
|
|
|
|
@1: lda ARG-1,x
|
|
|
|
sta FAC-1,x
|
|
|
|
dex
|
|
|
|
bne @1
|
|
|
|
stx FACEXTENSION ; ZERO EXTENSION
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ROUND FAC AND COPY TO ARG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
COPY_FAC_TO_ARG_ROUNDED:
|
|
|
|
jsr ROUND_FAC ; ROUND FAC USING EXTENSION
|
|
|
|
MAF: ldx #6 ; COPY 6 BYTES, INCLUDES SIGN
|
|
|
|
@1: lda FAC-1,x
|
|
|
|
sta ARG-1,x
|
|
|
|
dex
|
|
|
|
bne @1
|
|
|
|
stx FACEXTENSION ; ZERO FAC EXTENSION
|
|
|
|
RTS14: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ROUND FAC USING EXTENSION BYTE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ROUND_FAC:
|
|
|
|
lda FAC
|
|
|
|
beq RTS14 ; FAC = 0, RETURN
|
|
|
|
asl FACEXTENSION ; IS FAC.EXTENSION >= 128?
|
|
|
|
bcc RTS14 ; NO, FINISHED
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; INCREMENT MANTISSA AND RE-NORMALIZE IF CARRY
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
INCREMENT_MANTISSA:
|
|
|
|
jsr INCREMENT_FAC_MANTISSA ; YES, INCREMENT FAC
|
|
|
|
bne RTS14 ; HIGH BYTE HAS BITS, FINISHED
|
|
|
|
jmp NORMALIZE_FAC6 ; HI-BYTE=0, SO SHIFT LEFT
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; TEST FAC FOR ZERO AND SIGN
|
|
|
|
;
|
|
|
|
; FAC > 0, RETURN +1
|
|
|
|
; FAC = 0, RETURN 0
|
|
|
|
; FAC < 0, RETURN -1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SIGN: lda FAC ; CHECK SIGN OF FAC AND
|
|
|
|
beq RTS15 ; RETURN -1,0,1 IN A-REG
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SIGN1: lda FACSIGN
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SIGN2: rol a ; MSBIT TO CARRY
|
|
|
|
lda #$FF ; -1
|
|
|
|
bcs RTS15 ; MSBIT = 1
|
|
|
|
lda #1 ; +1
|
|
|
|
RTS15: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "SGN" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SGN: jsr SIGN ; CONVERT FAC TO -1,0,1
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; CONVERT (A) INTO FAC, AS SIGNED VALUE -128 TO +127
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FLOAT: sta FAC+1 ; PUT IN HIGH BYTE OF MANTISSA
|
|
|
|
lda #0 ; CLEAR 2ND BYTE OF MANTISSA
|
|
|
|
sta FAC+2
|
|
|
|
ldx #$88 ; USE EXPONENT 2^9
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FLOAT UNSIGNED VALUE IN FAC+1,2
|
|
|
|
; (X) = EXPONENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FLOAT1: lda FAC+1 ; MSBIT=0, SET CARRY; =1, CLEAR CARRY
|
|
|
|
eor #$FF
|
|
|
|
rol a
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FLOAT UNSIGNED VALUE IN FAC+1,2
|
|
|
|
; (X) = EXPONENT
|
|
|
|
; C=0 TO MAKE VALUE NEGATIVE
|
|
|
|
; C=1 TO MAKE VALUE POSITIVE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FLOAT2: lda #0 ; CLEAR LOWER 16-BITS OF MANTISSA
|
|
|
|
sta FAC+4
|
|
|
|
sta FAC+3
|
|
|
|
stx FAC ; STORE EXPONENT
|
|
|
|
sta FACEXTENSION ; CLEAR EXTENSION
|
|
|
|
sta FACSIGN ; MAKE SIGN POSITIVE
|
|
|
|
jmp NORMALIZE_FAC1 ; IF C=0, WILL NEGATE FAC
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "ABS" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ABS: lsr FACSIGN ; CHANGE SIGN TO +
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; COMPARE FAC WITH PACKED # AT (Y,A)
|
|
|
|
; RETURN A=1,0,-1 AS (Y,A) IS <,=,> FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FCOMP: sta DEST ; USE DEST FOR PNTR
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; SPECIAL ENTRY FROM "NEXT" PROCESSOR
|
|
|
|
; "DEST" ALREADY SET UP
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FCOMP2: sty DEST+1
|
|
|
|
ldy #0 ; GET EXPONENT OF COMPARAND
|
|
|
|
lda (DEST),y
|
|
|
|
iny ; POINT AT NEXT BYTE
|
|
|
|
tax ; EXPONENT TO X-REG
|
|
|
|
beq SIGN ; IF COMPARAND=0, "SIGN" COMPARES FAC
|
|
|
|
lda (DEST),y ; GET HI-BYTE OF MANTISSA
|
|
|
|
eor FACSIGN ; COMPARE WITH FAC SIGN
|
|
|
|
bmi SIGN1 ; DIFFERENT SIGNS, "SIGN" GIVES ANSWER
|
|
|
|
cpx FAC ; SAME SIGN, SO COMPARE EXPONENTS
|
|
|
|
bne @1 ; DIFFERENT, SO SUFFICIENT TEST
|
|
|
|
lda (DEST),y ; SAME EXPONENT, COMPARE MANTISSA
|
|
|
|
ora #$80 ; SET INVISIBLE NORMALIZED BIT
|
|
|
|
cmp FAC+1
|
|
|
|
bne @1 ; NOT SAME, SO SUFFICIENT
|
|
|
|
iny ; SAME, COMPARE MORE MANTISSA
|
|
|
|
lda (DEST),y
|
|
|
|
cmp FAC+2
|
|
|
|
bne @1 ; NOT SAME, SO SUFFICIENT
|
|
|
|
iny ; SAME, COMPARE MORE MANTISSA
|
|
|
|
lda (DEST),y
|
|
|
|
cmp FAC+3
|
|
|
|
bne @1 ; NOT SAME, SO SUFFICIENT
|
|
|
|
iny ; SAME, COMPARE REST OF MANTISSA
|
|
|
|
lda #$7F ; ARTIFICIAL EXTENSION BYTE FOR COMPARAND
|
|
|
|
cmp FACEXTENSION
|
|
|
|
lda (DEST),y
|
|
|
|
sbc FAC+4
|
|
|
|
beq RTS16 ; NUMBERS ARE EQUAL, RETURN (A)=0
|
|
|
|
@1: ror ; PUT CARRY INTO SIGN BIT
|
|
|
|
eor FACSIGN ; TOGGLE WITH SIGN OF FAC
|
|
|
|
@2: jmp SIGN2 ; CONVERT +1 OR -1
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; QUICK INTEGER FUNCTION
|
|
|
|
;
|
|
|
|
; CONVERTS FP VALUE IN FAC TO INTEGER VALUE
|
|
|
|
; IN FAC+1...FAC+4, BY SHIFTING RIGHT WITH SIGN
|
|
|
|
; EXTENSION UNTIL FRACTIONAL BITS ARE OUT.
|
|
|
|
;
|
|
|
|
; THIS SUBROUTINE ASSUMES THE EXPONENT < 32.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
QINT: lda FAC ; LOOK AT FAC EXPONENT
|
|
|
|
beq QINT3 ; FAC=0, SO FINISHED
|
|
|
|
sec ; GET -(NUMBER OF FRACTIONAL BITS)
|
|
|
|
sbc #$A0 ; IN A-REG FOR SHIFT COUNT
|
|
|
|
bit FACSIGN ; CHECK SIGN OF FAC
|
|
|
|
bpl @1 ; POSITIVE, CONTINUE
|
|
|
|
tax ; NEGATIVE, SO COMPLEMENT MANTISSA
|
|
|
|
lda #$FF ; AND SET SIGN EXTENSION FOR SHIFT
|
|
|
|
sta SHIFTSIGNEXT
|
|
|
|
jsr COMPLEMENT_FAC_MANTISSA
|
|
|
|
txa ; RESTORE BIT COUNT TO A-REG
|
|
|
|
@1: ldx #FAC ; POINT SHIFT SUBROUTINE AT FAC
|
|
|
|
cmp #$F9 ; MORE THAN 7 BITS TO SHIFT?
|
|
|
|
bpl QINT2 ; NO, SHORT SHIFT
|
|
|
|
jsr SHIFT_RIGHT ; YES, USE GENERAL ROUTINE
|
|
|
|
sty SHIFTSIGNEXT ; Y=0, CLEAR SIGN EXTENSION
|
|
|
|
RTS16: rts
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
QINT2: tay ; SAVE SHIFT COUNT
|
|
|
|
lda FACSIGN ; GET SIGN BIT
|
|
|
|
and #$80
|
|
|
|
lsr FAC+1 ; START RIGHT SHIFT
|
|
|
|
ora FAC+1 ; AND MERGE WITH SIGN
|
|
|
|
sta FAC+1
|
|
|
|
jsr SHIFT_RIGHT4 ; JUMP INTO MIDDLE OF SHIFTER
|
|
|
|
sty SHIFTSIGNEXT ; Y=0, CLEAR SIGN EXTENSION
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "INT" FUNCTION
|
|
|
|
;
|
|
|
|
; USES QINT TO CONVERT (FAC) TO INTEGER FORM,
|
|
|
|
; AND THEN REFLOATS THE INTEGER.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
INT: lda FAC ; CHECK IF EXPONENT < 32
|
|
|
|
cmp #$A0 ; BECAUSE IF > 31 THERE IS NO FRACTION
|
|
|
|
bcs RTS17 ; NO FRACTION, WE ARE FINISHED
|
|
|
|
jsr QINT ; USE GENERAL INTEGER CONVERSION
|
|
|
|
sty FACEXTENSION ; Y=0, CLEAR EXTENSION
|
|
|
|
lda FACSIGN ; GET SIGN OF VALUE
|
|
|
|
sty FACSIGN ; Y=0, CLEAR SIGN
|
|
|
|
eor #$80 ; TOGGLE ACTUAL SIGN
|
|
|
|
rol a ; AND SAVE IN CARRY
|
|
|
|
lda #$A0 ; SET EXPONENT TO 32
|
|
|
|
sta FAC ; BECAUSE 4-BYTE INTEGER NOW
|
|
|
|
lda FAC+4 ; SAVE LOW 8-BITS OF INTEGER FORM
|
|
|
|
sta CHARAC ; FOR EXP AND POWER
|
|
|
|
jmp NORMALIZE_FAC1 ; NORMALIZE TO FINISH CONVERSION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
QINT3: sta FAC+1 ; FAC=0, SO CLEAR ALL 4 BYTES FOR
|
|
|
|
sta FAC+2 ; INTEGER VERSION
|
|
|
|
sta FAC+3
|
|
|
|
sta FAC+4
|
|
|
|
tay ; Y=0 TOO
|
|
|
|
RTS17: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; CONVERT STRING TO FP VALUE IN FAC
|
|
|
|
;
|
|
|
|
; STRING POINTED TO BY TXTPTR
|
|
|
|
; FIRST CHAR ALREADY SCANNED BY CHRGET
|
|
|
|
; (A) = FIRST CHAR, C=0 IF DIGIT.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN: ldy #0 ; CLEAR WORKING AREA ($99...$A3)
|
|
|
|
ldx #10 ; TMPEXP, EXPON, DPFLG, EXPSGN, FAC, SERLEN
|
|
|
|
@1: sty TMPEXP,x
|
|
|
|
dex
|
|
|
|
bpl @1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
bcc FIN2 ; FIRST CHAR IS A DIGIT
|
|
|
|
cmp #'-' ; CHECK FOR LEADING SIGN
|
|
|
|
bne @2 ; NOT MINUS
|
|
|
|
stx SERLEN ; MINUS, SET SERLEN = $FF FOR FLAG
|
|
|
|
beq FIN1 ; ...ALWAYS
|
|
|
|
@2: cmp #'+' ; MIGHT BE PLUS
|
|
|
|
bne FIN3 ; NOT PLUS EITHER, CHECK DECIMAL POINT
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN1: jsr CHRGET ; GET NEXT CHAR OF STRING
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN2: bcc FIN9 ; INSERT THIS DIGIT
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN3: cmp #'.' ; CHECK FOR DECIMAL POINT
|
|
|
|
beq FIN10 ; YES
|
|
|
|
cmp #'E' ; CHECK FOR EXPONENT PART
|
|
|
|
bne FIN7 ; NO, END OF NUMBER
|
|
|
|
jsr CHRGET ; YES, START CONVERTING EXPONENT
|
|
|
|
bcc FIN5 ; EXPONENT DIGIT
|
|
|
|
cmp #TOKEN_MINUS ; NEGATIVE EXPONENT?
|
|
|
|
beq @1 ; YES
|
|
|
|
cmp #'-' ; MIGHT NOT BE TOKENIZED YET
|
|
|
|
beq @1 ; YES, IT IS NEGATIVE
|
|
|
|
cmp #TOKEN_PLUS ; OPTIONAL "+"
|
|
|
|
beq FIN4 ; YES
|
|
|
|
cmp #'+' ; MIGHT NOT BE TOKENIZED YET
|
|
|
|
beq FIN4 ; YES, FOUND "+"
|
|
|
|
bne FIN6 ; ...ALWAYS, NUMBER COMPLETED
|
|
|
|
@1: ror EXPSGN ; C=1, SET FLAG NEGATIVE
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN4: jsr CHRGET ; GET NEXT DIGIT OF EXPONENT
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN5: bcc GETEXP ; CHAR IS A DIGIT OF EXPONENT
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN6: bit EXPSGN ; END OF NUMBER, CHECK EXP SIGN
|
|
|
|
bpl FIN7 ; POSITIVE EXPONENT
|
|
|
|
lda #0 ; NEGATIVE EXPONENT
|
|
|
|
sec ; MAKE 2'S COMPLEMENT OF EXPONENT
|
|
|
|
sbc EXPON
|
|
|
|
jmp FIN8
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FOUND A DECIMAL POINT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN10: ror DPFLG ; C=1, SET DPFLG FOR DECIMAL POINT
|
|
|
|
bit DPFLG ; CHECK IF PREVIOUS DEC. PT.
|
|
|
|
bvc FIN1 ; NO PREVIOUS DECIMAL POINT
|
|
|
|
; A SECOND DECIMAL POINT IS TAKEN AS A TERMINATOR
|
|
|
|
; TO THE NUMERIC STRING.
|
|
|
|
; "A=11..22" WILL GIVE A SYNTAX ERROR, BECAUSE
|
|
|
|
; IT IS TWO NUMBERS WITH NO OPERATOR BETWEEN.
|
|
|
|
; "PRINT 11..22" GIVES NO ERROR, BECAUSE IT IS
|
|
|
|
; JUST THE CONCATENATION OF TWO NUMBERS.
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NUMBER TERMINATED, ADJUST EXPONENT NOW
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN7: lda EXPON ; E-VALUE
|
|
|
|
FIN8: sec ; MODIFY WITH COUNT OF DIGITS
|
|
|
|
sbc TMPEXP ; AFTER THE DECIMAL POINT
|
|
|
|
sta EXPON ; COMPLETE CURRENT EXPONENT
|
|
|
|
beq @15 ; NO ADJUST NEEDED IF EXP=0
|
|
|
|
bpl @14 ; EXP>0, MULTIPLY BY TEN
|
|
|
|
@13: jsr DIV10 ; EXP<0, DIVIDE BY TEN
|
|
|
|
inc EXPON ; UNTIL EXP=0
|
|
|
|
bne @13
|
|
|
|
beq @15 ; ...ALWAYS, WE ARE FINISHED
|
|
|
|
@14: jsr MUL10 ; EXP>0, MULTIPLY BKY TEN
|
|
|
|
dec EXPON ; UNTIL EXP=0
|
|
|
|
bne @14
|
|
|
|
@15: lda SERLEN ; IS WHOLE NUMBER NEGATIVE?
|
|
|
|
bmi @16 ; YES
|
|
|
|
rts ; NO, RETURN, WHOLE JOB DONE!
|
|
|
|
@16: jmp NEGOP ; NEGATIVE NUMBER, SO NEGATE FAC
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ACCUMULATE A DIGIT INTO FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FIN9: pha ; SAVE DIGIT
|
|
|
|
bit DPFLG ; SEEN A DECIMAL POINT YET?
|
|
|
|
bpl @1 ; NO, STILL IN INTEGER PART
|
|
|
|
inc TMPEXP ; YES, COUNT THE FRACTIONAL DIGIT
|
|
|
|
@1: jsr MUL10 ; FAC = FAC * 10
|
|
|
|
pla ; CURRENT DIGIT
|
|
|
|
and #$0F
|
|
|
|
jsr ADDACC ; ADD THE DIGIT
|
|
|
|
jmp FIN1 ; GO BACK FOR MORE
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ADD (A) TO FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ADDACC: pha ; SAVE ADDEND
|
|
|
|
jsr COPY_FAC_TO_ARG_ROUNDED
|
|
|
|
pla ; GET ADDEND AGAIN
|
|
|
|
jsr FLOAT ; CONVERT TO FP VALUE IN FAC
|
|
|
|
lda ARGSIGN
|
|
|
|
eor FACSIGN
|
|
|
|
sta SGNCPR
|
|
|
|
ldx FAC ; TO SIGNAL IF FAC=0
|
|
|
|
jmp FADDT ; PERFORM THE ADDITION
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ACCUMULATE DIGIT OF EXPONENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GETEXP: lda EXPON ; CHECK CURRENT VALUE
|
|
|
|
cmp #10 ; FOR MORE THAN 2 DIGITS
|
|
|
|
bcc @1 ; NO, THIS IS 1ST OR 2ND DIGIT
|
|
|
|
lda #100 ; EXPONENT TOO BIG
|
|
|
|
bit EXPSGN ; UNLESS IT IS NEGATIVE
|
|
|
|
bmi @2 ; LARGE NEGATIVE EXPONENT MAKES FAC=0
|
|
|
|
jmp OVERFLOW ; LARGE POSITIVE EXPONENT IS ERROR
|
|
|
|
@1: asl a ; EXPONENT TIMES 10
|
|
|
|
asl a
|
|
|
|
clc
|
|
|
|
adc EXPON
|
|
|
|
asl a
|
|
|
|
ldy #0 ; ADD THE NEW DIGIT
|
|
|
|
adc (TXTPTR),y ; BUT THIS IS IN ASCII,
|
|
|
|
sec ; SO ADJUST BACK TO BINARY
|
|
|
|
sbc #'0'
|
|
|
|
@2: sta EXPON ; NEW VALUE
|
|
|
|
jmp FIN4 ; BACK FOR MORE
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CON_99999999_9:
|
|
|
|
.byte $9B,$3E,$BC,$1F,$FD ; 99,999,999.9
|
|
|
|
|
|
|
|
CON_999999999:
|
|
|
|
.byte $9E,$6E,$6B,$27,$FD ; 999,999,999
|
|
|
|
|
|
|
|
CON_BILLION:
|
|
|
|
.byte $9E,$6E,$6B,$28,$00 ; 1,000,000,000
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; PRINT "IN <LINE #>"
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
INPRT: lda #<QT_IN ; PRINT " IN "
|
|
|
|
ldy #>QT_IN
|
|
|
|
jsr STROUT
|
|
|
|
lda CURLIN+1
|
|
|
|
ldx CURLIN
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; PRINT A,X AS DECIMAL INTEGER
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
LINPRT: sta FAC+1 ; PRINT A,X IN DECIMAL
|
|
|
|
stx FAC+2
|
|
|
|
ldx #$90 ; EXPONENT = 2^16
|
|
|
|
sec ; CONVERT UNSIGNED
|
|
|
|
jsr FLOAT2 ; CONVERT LINE # TO FP
|
|
|
|
jsr FOUT ; CONVERT (FAC) TO STRING AT STACK
|
|
|
|
jmp STROUT ; PRINT STRING AT A,Y
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; CONVERT (FAC) TO STRING STARTING AT STACK
|
|
|
|
; RETURN WITH (Y,A) POINTING AT STRING
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FOUT: ldy #1 ; NORMAL ENTRY PUTS STRING AT STACK...
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "STR$" FUNCTION ENTERS HERE, WITH (Y)=0
|
|
|
|
; SO THAT RESULT STRING STARTS AT STACK-1
|
|
|
|
; (THIS IS USED AS A FLAG)
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FOUT1: lda #'-' ; IN CASE VALUE NEGATIVE
|
|
|
|
dey ; BACK UP PNTR
|
|
|
|
bit FACSIGN
|
|
|
|
bpl @1 ; VALUE IS +
|
|
|
|
iny ; VALUE IS -
|
|
|
|
sta STACK-1,y ; EMIT "-"
|
|
|
|
@1: sta FACSIGN ; MAKE FAC.SIGN POSITIVE ($2D)
|
|
|
|
sty STRNG2 ; SAVE STRING PNTR
|
|
|
|
iny
|
|
|
|
lda #'0' ; IN CASE (FAC)=0
|
|
|
|
ldx FAC ; NUMBER=0?
|
|
|
|
bne @2 ; NO, (FAC) NOT ZERO
|
|
|
|
jmp FOUT4 ; YES, FINISHED
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@2: lda #0 ; STARTING VALUE FOR TMPEXP
|
|
|
|
cpx #$80 ; ANY INTEGER PART?
|
|
|
|
beq @3 ; NO, BTWN .5 AND .999999999
|
|
|
|
bcs @4 ; YES
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@3: lda #<CON_BILLION ; MULTIPLY BY 1E9
|
|
|
|
ldy #>CON_BILLION ; TO GIVE ADJUSTMENT A HEAD START
|
|
|
|
jsr FMULT
|
2021-01-16 00:08:36 +00:00
|
|
|
lda #247 ; EXPONENT ADJUSTMENT
|
2017-05-11 20:42:22 +00:00
|
|
|
@4: sta TMPEXP ; 0 OR -9
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ADJUST UNTIL 1E8 <= (FAC) <1E9
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@5: lda #<CON_999999999
|
|
|
|
ldy #>CON_999999999
|
|
|
|
jsr FCOMP ; COMPARE TO 1E9-1
|
|
|
|
beq @10 ; (FAC) = 1E9-1
|
|
|
|
bpl @8 ; TOO LARGE, DIVIDE BY TEN
|
|
|
|
@6: lda #<CON_99999999_9 ; COMPARE TO 1E8-.1
|
|
|
|
ldy #>CON_99999999_9
|
|
|
|
jsr FCOMP ; COMPARE TO 1E8-.1
|
|
|
|
beq @7 ; (FAC) = 1E8-.1
|
|
|
|
bpl @9 ; IN RANGE, ADJUSTMENT FINISHED
|
|
|
|
@7: jsr MUL10 ; TOO SMALL, MULTIPLY BY TEN
|
|
|
|
dec TMPEXP ; KEEP TRACK OF MULTIPLIES
|
|
|
|
bne @6 ; ...ALWAYS
|
|
|
|
@8: jsr DIV10 ; TOO LARGE, DIVIDE BY TEN
|
|
|
|
inc TMPEXP ; KEEP TRACK OF DIVISIONS
|
|
|
|
bne @5 ; ...ALWAYS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@9: jsr FADDH ; ROUND ADJUSTED RESULT
|
|
|
|
@10: jsr QINT ; CONVERT ADJUSTED VALUE TO 32-BIT INTEGER
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FAC+1...FAC+4 IS NOW IN INTEGER FORM
|
|
|
|
; WITH POWER OF TEN ADJUSTMENT IN TMPEXP
|
|
|
|
;
|
|
|
|
; IF -10 < TMPEXP > 1, PRINT IN DECIMAL FORM
|
|
|
|
; OTHERWISE, PRINT IN EXPONENTIAL FORM
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FOUT2: ldx #1 ; ASSUME 1 DIGIT BEFORE "."
|
|
|
|
lda TMPEXP ; CHECK RANGE
|
|
|
|
clc
|
|
|
|
adc #10
|
|
|
|
bmi @1 ; < .01, USE EXPONENTIAL FORM
|
|
|
|
cmp #11
|
|
|
|
bcs @2 ; >= 1E10, USE EXPONENTIAL FORM
|
|
|
|
adc #$FF ; LESS 1 GIVES INDEX FOR "."
|
|
|
|
tax
|
|
|
|
lda #2 ; SET REMAINING EXPONENT = 0
|
|
|
|
@1: sec ; COMPUTE REMAINING EXPONENT
|
|
|
|
@2: sbc #2
|
|
|
|
sta EXPON ; VALUE FOR "E+XX" OR "E-XX"
|
|
|
|
stx TMPEXP ; INDEX FOR DECIMAL POINT
|
|
|
|
txa ; SEE IF "." COMES FIRST
|
|
|
|
beq @3 ; YES
|
|
|
|
bpl @5 ; NO, LATER
|
|
|
|
@3: ldy STRNG2 ; GET INDEX INTO STRING BEING BUILT
|
|
|
|
lda #'.' ; STORE A DECIMAL POINT
|
|
|
|
iny
|
|
|
|
sta STACK-1,y
|
|
|
|
txa ; SEE IF NEED ".0"
|
|
|
|
beq @4 ; NO
|
|
|
|
lda #'0' ; YES, STORE "0"
|
|
|
|
iny
|
|
|
|
sta STACK-1,y
|
|
|
|
@4: sty STRNG2 ; SAVE OUTPUT INDEX AGAIN
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NOW DIVIDE BY POWERS OF TEN TO GET SUCCESSIVE DIGITS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
@5: ldy #0 ; INDEX TO TABLE OF POWERS OF TEN
|
|
|
|
ldx #$80 ; STARTING VALUE FOR DIGIT WITH DIRECTION
|
|
|
|
@6: lda FAC+4 ; START BY ADDING -100000000 UNTIL
|
|
|
|
clc ; OVERSHOOT. THEN ADD +10000000,
|
|
|
|
adc DECTBL+3,y ; THEN ADD -1000000, THEN ADD
|
|
|
|
sta FAC+4 ; +100000, AND SO ON.
|
|
|
|
lda FAC+3 ; THE # OF TIMES EACH POWER IS ADDED
|
|
|
|
adc DECTBL+2,y ; IS 1 MORE THAN CORRESPONDING DIGIT
|
|
|
|
sta FAC+3
|
|
|
|
lda FAC+2
|
|
|
|
adc DECTBL+1,y
|
|
|
|
sta FAC+2
|
|
|
|
lda FAC+1
|
|
|
|
adc DECTBL,y
|
|
|
|
sta FAC+1
|
|
|
|
inx ; COUNT THE ADD
|
|
|
|
bcs @7 ; IF C=1 AND X NEGATIVE, KEEP ADDING
|
|
|
|
bpl @6 ; IF C=0 AND X POSITIVE, KEEP ADDING
|
|
|
|
bmi @8 ; IF C=0 AND X NEGATIVE, WE OVERSHOT
|
|
|
|
@7: bmi @6 ; IF C=1 AND X POSITIVE, WE OVERSHOT
|
|
|
|
@8: txa ; OVERSHOT, SO MAKE X INTO A DIGIT
|
|
|
|
bcc @9 ; HOW DEPENDS ON DIRECTION WE WERE GOING
|
|
|
|
eor #$FF ; DIGIT = 9-X
|
|
|
|
adc #10
|
|
|
|
@9: adc #'0'-1 ; MAKE DIGIT INTO ASCII
|
|
|
|
iny ; ADVANCE TO NEXT SMALLER POWER OF TEN
|
|
|
|
iny
|
|
|
|
iny
|
|
|
|
iny
|
|
|
|
sty VARPNT ; SAVE PNTR TO POWERS
|
|
|
|
ldy STRNG2 ; GET OUTPUT PNTR
|
|
|
|
iny ; STORE THE DIGIT
|
|
|
|
tax ; SAVE DIGIT, HI-BIT IS DIRECTION
|
|
|
|
and #$7F ; MAKE SURE $30...$39 FOR STRING
|
|
|
|
sta STACK-1,y
|
|
|
|
dec TMPEXP ; COUNT THE DIGIT
|
|
|
|
bne @10 ; NOT TIME FOR "." YET
|
|
|
|
lda #'.' ; TIME, SO STORE THE DECIMAL POINT
|
|
|
|
iny
|
|
|
|
sta STACK-1,y
|
|
|
|
@10: sty STRNG2 ; SAVE OUTPUT PNTR AGAIN
|
|
|
|
ldy VARPNT ; GET PNTR TO POWERS
|
|
|
|
txa ; GET DIGIT WITH HI-BIT = DIRECTION
|
|
|
|
eor #$FF ; CHANGE DIRECTION
|
|
|
|
and #$80 ; $00 IF ADDING, $80 IF SUBTRACTING
|
|
|
|
tax
|
|
|
|
cpy #DECTBL_END-DECTBL
|
|
|
|
bne @6 ; NOT FINISHED YET
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NINE DIGITS HAVE BEEN STORED IN STRING. NOW LOOK
|
|
|
|
; BACK AND LOP OFF TRAILING ZEROES AND A TRAILING
|
|
|
|
; DECIMAL POINT.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FOUT3: ldy STRNG2 ; POINTS AT LAST STORED CHAR
|
|
|
|
@1: lda STACK-1,y ; SEE IF LOPPABLE
|
|
|
|
dey
|
|
|
|
cmp #'0' ; SUPPRESS TRAILING ZEROES
|
|
|
|
beq @1 ; YES, KEEP LOOPING
|
|
|
|
cmp #'.' ; SUPPRESS TRAILING DECIMAL POINT
|
|
|
|
beq @2 ; ".", SO WRITE OVER IT
|
|
|
|
iny ; NOT ".", SO INCLUDE IN STRING AGAIN
|
|
|
|
@2: lda #'+' ; PREPARE FOR POSITIVE EXPONENT "E+XX"
|
|
|
|
ldx EXPON ; SEE IF ANY E-VALUE
|
|
|
|
beq FOUT5 ; NO, JUST MARK END OF STRING
|
|
|
|
bpl @3 ; YES, AND IT IS POSITIVE
|
|
|
|
lda #0 ; YES, AND IT IS NEGATIVE
|
|
|
|
sec ; COMPLEMENT THE VALUE
|
|
|
|
sbc EXPON
|
|
|
|
tax ; GET MAGNITUDE IN X
|
|
|
|
lda #'-' ; E SIGN
|
|
|
|
@3: sta STACK+1,y ; STORE SIGN IN STRING
|
|
|
|
lda #'E' ; STORE "E" IN STRING BEFORE SIGN
|
|
|
|
sta STACK,y
|
|
|
|
txa ; EXPONENT MAGNITUDE IN A-REG
|
|
|
|
ldx #'0'-1 ; SEED FOR EXPONENT DIGIT
|
|
|
|
sec ; CONVERT TO DECIMAL
|
|
|
|
@4: inx ; COUNT THE SUBTRACTION
|
|
|
|
sbc #10 ; TEN'S DIGIT
|
|
|
|
bcs @4 ; MORE TENS TO SUBTRACT
|
|
|
|
adc #'0'+10 ; CONVERT REMAINDER TO ONE'S DIGIT
|
|
|
|
sta STACK+3,y ; STORE ONE'S DIGIT
|
|
|
|
txa
|
|
|
|
sta STACK+2,y ; STORE TEN'S DIGIT
|
|
|
|
lda #0 ; MARK END OF STRING WITH $00
|
|
|
|
sta STACK+4,y
|
|
|
|
beq FOUT6 ; ...ALWAYS
|
|
|
|
FOUT4: sta STACK-1,y ; STORE "0" IN ASCII
|
|
|
|
FOUT5: lda #0 ; STORE $00 ON END OF STRING
|
|
|
|
sta STACK,y
|
|
|
|
FOUT6: lda #<STACK ; POINT Y,A AT BEGINNING OF STRING
|
|
|
|
ldy #>STACK ; (STR$ STARTED STRING AT STACK-1, BUT
|
|
|
|
rts ; STR$ DOESN'T USE Y,A ANYWAY.)
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CON_HALF:
|
|
|
|
.byte $80,$00,$00,$00,$00 ; FP CONSTANT 0.5
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; POWERS OF 10 FROM 1E8 DOWN TO 1,
|
|
|
|
; AS 32-BIT INTEGERS, WITH ALTERNATING SIGNS
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
DECTBL: .byte $FA,$0A,$1F,$00 ; -100000000
|
|
|
|
.byte $00,$98,$96,$80 ; 10000000
|
|
|
|
.byte $FF,$F0,$BD,$C0 ; -1000000
|
|
|
|
.byte $00,$01,$86,$A0 ; 100000
|
|
|
|
.byte $FF,$FF,$D8,$F0 ; -10000
|
|
|
|
.byte $00,$00,$03,$E8 ; 1000
|
|
|
|
.byte $FF,$FF,$FF,$9C ; -100
|
|
|
|
.byte $00,$00,$00,$0A ; 10
|
|
|
|
.byte $FF,$FF,$FF,$FF ; -1
|
|
|
|
DECTBL_END:
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "SQR" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SQR: jsr COPY_FAC_TO_ARG_ROUNDED
|
|
|
|
lda #<CON_HALF ; SET UP POWER OF 0.5
|
|
|
|
ldy #>CON_HALF
|
|
|
|
jsr LOAD_FAC_FROM_YA
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; EXPONENTIATION OPERATION
|
|
|
|
;
|
|
|
|
; ARG ^ FAC = EXP( LOG(ARG) * FAC )
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
FPWRT: beq EXP ; IF FAC=0, ARG^FAC=EXP(0)
|
|
|
|
lda ARG ; IF ARG=0, ARG^FAC=0
|
|
|
|
bne @1 ; NEITHER IS ZERO
|
|
|
|
jmp STA_IN_FAC_SIGN_AND_EXP ; SET FAC = 0
|
|
|
|
@1: ldx #TEMP3 ; SAVE FAC IN TEMP3
|
|
|
|
ldy #0
|
|
|
|
jsr STORE_FAC_AT_YX_ROUNDED
|
|
|
|
lda ARGSIGN ; NORMALLY, ARG MUST BE POSITIVE
|
|
|
|
bpl @2 ; IT IS POSITIVE, SO ALL IS WELL
|
|
|
|
jsr INT ; NEGATIVE, BUT OK IF INTEGRAL POWER
|
|
|
|
lda #TEMP3 ; SEE IF INT(FAC)=FAC
|
|
|
|
ldy #0
|
|
|
|
jsr FCOMP ; IS IT AN INTEGER POWER?
|
|
|
|
bne @2 ; NOT INTEGRAL, WILL CAUSE ERROR LATER
|
|
|
|
tya ; MAKE ARG SIGN + AS IT IS MOVED TO FAC
|
|
|
|
ldy CHARAC ; INTEGRAL, SO ALLOW NEGATIVE ARG
|
|
|
|
@2: jsr MFA ; MOVE ARGUMENT TO FAC
|
2021-01-16 00:08:36 +00:00
|
|
|
tya ; SAVE FLAG FOR NEGATIVE ARG (0=+)
|
2017-05-11 20:42:22 +00:00
|
|
|
pha
|
|
|
|
jsr LOG ; GET LOG(ARG)
|
|
|
|
lda #TEMP3 ; MULTIPLY BY POWER
|
|
|
|
ldy #0
|
|
|
|
jsr FMULT
|
|
|
|
jsr EXP ; E ^ LOG(FAC)
|
|
|
|
pla ; GET FLAG FOR NEGATIVE ARG
|
|
|
|
bpl RTS18 ; NOT NEGATIVE, FINISHED
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NEGATE VALUE IN FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
NEGOP: lda FAC ; IF FAC=0, NO NEED TO COMPLEMENT
|
|
|
|
beq RTS18 ; YES, FAC=0
|
|
|
|
lda FACSIGN ; NO, SO TOGGLE SIGN
|
|
|
|
eor #$FF
|
|
|
|
sta FACSIGN
|
|
|
|
RTS18: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CON_LOG_E:
|
|
|
|
.byte $81,$38,$AA,$3B,$29 ; LOG(E) TO BASE 2
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
POLY_EXP:
|
|
|
|
.byte $07 ; ( # OF TERMS IN POLYNOMIAL) - 1
|
|
|
|
.byte $71,$34,$58,$3E,$56 ; (LOG(2)^7)/8!
|
|
|
|
.byte $74,$16,$7E,$B3,$1B ; (LOG(2)^6)/7!
|
|
|
|
.byte $77,$2F,$EE,$E3,$85 ; (LOG(2)^5)/6!
|
|
|
|
.byte $7A,$1D,$84,$1C,$2A ; (LOG(2)^4)/5!
|
|
|
|
.byte $7C,$63,$59,$58,$0A ; (LOG(2)^3)/4!
|
|
|
|
.byte $7E,$75,$FD,$E7,$C6 ; (LOG(2)^2)/3!
|
|
|
|
.byte $80,$31,$72,$18,$10 ; LOG(2)/2!
|
|
|
|
.byte $81,$00,$00,$00,$00 ; 1
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "EXP" FUNCTION
|
|
|
|
;
|
|
|
|
; FAC = E ^ FAC
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
EXP: lda #<CON_LOG_E ; CONVERT TO POWER OF TWO PROBLEM
|
|
|
|
ldy #>CON_LOG_E ; E^X = 2^(LOG2(E)*X)
|
|
|
|
jsr FMULT
|
|
|
|
lda FACEXTENSION ; NON-STANDARD ROUNDING HERE
|
|
|
|
adc #$50 ; ROUND UP IF EXTENSION > $AF
|
|
|
|
bcc @1 ; NO, DON'T ROUND UP
|
|
|
|
jsr INCREMENT_MANTISSA
|
|
|
|
@1: sta ARGEXTENSION ; STRANGE VALUE
|
|
|
|
jsr MAF ; COPY FAC INTO ARG
|
|
|
|
lda FAC ; MAXIMUM EXPONENT IS < 128
|
|
|
|
cmp #$88 ; WITHIN RANGE?
|
|
|
|
bcc @3 ; YES
|
|
|
|
@2: jsr OUTOFRNG ; OVERFLOW IF +, RETURN 0.0 IF -
|
|
|
|
@3: jsr INT ; GET INT(FAC)
|
|
|
|
lda CHARAC ; THIS IS THE INETGRAL PART OF THE POWER
|
|
|
|
clc ; ADD TO EXPONENT BIAS + 1
|
|
|
|
adc #$81
|
|
|
|
beq @2 ; OVERFLOW
|
|
|
|
sec ; BACK OFF TO NORMAL BIAS
|
|
|
|
sbc #1
|
|
|
|
pha ; SAVE EXPONENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ldx #5 ; SWAP ARG AND FAC
|
|
|
|
@4: lda ARG,x
|
|
|
|
ldy FAC,x
|
|
|
|
sta FAC,x
|
|
|
|
sty ARG,x
|
|
|
|
dex
|
|
|
|
bpl @4
|
|
|
|
lda ARGEXTENSION
|
|
|
|
sta FACEXTENSION
|
|
|
|
jsr FSUBT ; POWER-INT(POWER) --> FRACTIONAL PART
|
|
|
|
jsr NEGOP
|
|
|
|
lda #<POLY_EXP
|
|
|
|
ldy #>POLY_EXP
|
|
|
|
jsr POLYNOMIAL ; COMPUTE F(X) ON FRACTIONAL PART
|
|
|
|
lda #0
|
|
|
|
sta SGNCPR
|
|
|
|
pla ; GET EXPONENT
|
|
|
|
jmp ADD_EXPONENTS1
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ODD POLYNOMIAL SUBROUTINE
|
|
|
|
;
|
|
|
|
; F(X) = X * P(X^2)
|
|
|
|
;
|
|
|
|
; WHERE: X IS VALUE IN FAC
|
|
|
|
; Y,A POINTS AT COEFFICIENT TABLE
|
|
|
|
; FIRST BYTE OF COEFF. TABLE IS N
|
|
|
|
; COEFFICIENTS FOLLOW, HIGHEST POWER FIRST
|
|
|
|
;
|
|
|
|
; P(X^2) COMPUTED USING NORMAL POLYNOMIAL SUBROUTINE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
POLYNOMIAL_ODD:
|
|
|
|
sta SERPNT ; SAVE ADDRESS OF COEFFICIENT TABLE
|
|
|
|
sty SERPNT+1
|
|
|
|
jsr STORE_FAC_IN_TEMP1_ROUNDED
|
|
|
|
lda #TEMP1 ; Y=0 ALREADY, SO Y,A POINTS AT TEMP1
|
|
|
|
jsr FMULT ; FORM X^2
|
|
|
|
jsr SERMAIN ; DO SERIES IN X^2
|
|
|
|
lda #<TEMP1 ; GET X AGAIN
|
|
|
|
ldy #>TEMP1
|
|
|
|
jmp FMULT ; MULTIPLY X BY P(X^2) AND EXIT
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; NORMAL POLYNOMIAL SUBROUTINE
|
|
|
|
;
|
|
|
|
; P(X) = C(0)*X^N + C(1)*X^(N-1) + ... + C(N)
|
|
|
|
;
|
|
|
|
; WHERE: X IS VALUE IN FAC
|
|
|
|
; Y,A POINTS AT COEFFICIENT TABLE
|
|
|
|
; FIRST BYTE OF COEFF. TABLE IS N
|
|
|
|
; COEFFICIENTS FOLLOW, HIGHEST POWER FIRST
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
POLYNOMIAL:
|
|
|
|
sta SERPNT ; POINTER TO COEFFICIENT TABLE
|
|
|
|
sty SERPNT+1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
SERMAIN:
|
|
|
|
jsr STORE_FAC_IN_TEMP2_ROUNDED
|
|
|
|
lda (SERPNT),y ; GET N
|
|
|
|
sta SERLEN ; SAVE N
|
|
|
|
ldy SERPNT ; BUMP PNTR TO HIGHEST COEFFICIENT
|
|
|
|
iny ; AND GET PNTR INTO Y,A
|
|
|
|
tya
|
|
|
|
bne @1
|
|
|
|
inc SERPNT+1
|
|
|
|
@1: sta SERPNT
|
|
|
|
ldy SERPNT+1
|
|
|
|
@2: jsr FMULT ; ACCUMULATE SERIES TERMS
|
|
|
|
lda SERPNT ; BUMP PNTR TO NEXT COEFFICIENT
|
|
|
|
ldy SERPNT+1
|
|
|
|
clc
|
|
|
|
adc #5
|
|
|
|
bcc @3
|
|
|
|
iny
|
|
|
|
@3: sta SERPNT
|
|
|
|
sty SERPNT+1
|
|
|
|
jsr FADD ; ADD NEXT COEFFICIENT
|
|
|
|
lda #TEMP2 ; POINT AT X AGAIN
|
|
|
|
ldy #0
|
|
|
|
dec SERLEN ; IF SERIES NOT FINISHED,
|
|
|
|
bne @2 ; THEN ADD ANOTHER TERM
|
|
|
|
RTS19: rts ; FINISHED
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CONRND1:
|
|
|
|
.byte $98,$35,$44,$7A ; THESE ARE MISSING ONE BYTE FOR FP VALUES
|
|
|
|
|
|
|
|
CONRND2:
|
|
|
|
.byte $68,$28,$B1,$46
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "RND" FUNCTION
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
RND: jsr SIGN ; REDUCE ARGUMENT TO -1, 0, OR +1
|
|
|
|
tax ; SAVE ARGUMENT
|
|
|
|
bmi @1 ; = -1, USE CURRENT ARGUMENT FOR SEED
|
|
|
|
lda #<RNDSEED ; USE CURRENT SEED
|
|
|
|
ldy #>RNDSEED
|
|
|
|
jsr LOAD_FAC_FROM_YA
|
|
|
|
txa ; RECALL SIGN OF ARGUMENT
|
|
|
|
beq RTS19 ; =0, RETURN SEED UNCHANGED
|
|
|
|
lda #<CONRND1 ; VERY POOR RND ALGORITHM
|
|
|
|
ldy #>CONRND1
|
|
|
|
jsr FMULT
|
|
|
|
lda #<CONRND2 ; ALSO, CONSTANTS ARE TRUNCATED
|
|
|
|
ldy #>CONRND2
|
|
|
|
jsr FADD
|
|
|
|
@1: ldx FAC+4 ; SHUFFLE HI AND LO BYTES
|
|
|
|
lda FAC+1 ; TO SUPPOSEDLY MAKE IT MORE RANDOM
|
|
|
|
sta FAC+4
|
|
|
|
stx FAC+1
|
|
|
|
lda #0 ; MAKE IT POSITIVE
|
|
|
|
sta FACSIGN
|
|
|
|
lda FAC ; A SOMEWHAT RANDOM EXTENSION
|
|
|
|
sta FACEXTENSION
|
|
|
|
lda #$80 ; EXPONENT TO MAKE VALUE < 1.0
|
|
|
|
sta FAC
|
|
|
|
jsr NORMALIZE_FAC2
|
|
|
|
ldx #<RNDSEED ; MOVE FAC TO RND SEED
|
|
|
|
ldy #>RNDSEED
|
|
|
|
jmp STORE_FAC_AT_YX_ROUNDED
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; GENERIC COPY OF CHRGET SUBROUTINE, WHICH
|
|
|
|
; IS COPIED INTO $00B1...$00C8 DURING INITIALIZATION
|
|
|
|
;
|
2021-01-16 00:08:36 +00:00
|
|
|
; CORNELIS BONGERS DESCRIBED SEVERAL IMPROVEMENTS
|
2017-05-11 20:42:22 +00:00
|
|
|
; TO CHRGET IN MICRO MAGAZINE OR CALL A.P.P.L.E.
|
|
|
|
; (I DON'T REMEMBER WHICH OR EXACTLY WHEN)
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
GENERIC_CHRGET:
|
|
|
|
inc TXTPTR
|
|
|
|
bne @1
|
|
|
|
inc TXTPTR+1
|
|
|
|
@1: lda $EA60 ; ACTUAL ADDRESS FILLED IN LATER
|
|
|
|
cmp #':' ; EOS, ALSO TOP OF NUMERIC RANGE
|
|
|
|
bcs @2 ; NOT NUMBER, MIGHT BE EOS
|
|
|
|
cmp #' ' ; IGNORE BLANKS
|
|
|
|
beq GENERIC_CHRGET
|
|
|
|
sec ; TEST FOR NUMERIC RANGE IN WAY THAT
|
|
|
|
sbc #'0' ; CLEARS CARRY IF CHAR IS DIGIT
|
|
|
|
sec ; AND LEAVES CHAR IN A-REG
|
2021-01-16 00:08:36 +00:00
|
|
|
sbc #-'0'+256
|
2017-05-11 20:42:22 +00:00
|
|
|
@2: rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; INITIAL VALUE FOR RANDOM NUMBER, ALSO COPIED
|
|
|
|
; IN ALONG WITH CHRGET, BUT ERRONEOUSLY:
|
|
|
|
; THE LAST BYTE IS NOT COPIED
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
.byte $80,$4F,$C7,$52,$58 ; APPROX. = .811635157
|
|
|
|
GENERIC_END:
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
COLDSTART:
|
|
|
|
ldx #$FF ; SET DIRECT MODE FLAG
|
|
|
|
stx CURLIN+1
|
|
|
|
ldx #$FB ; SET STACK POINTER, LEAVING ROOM FOR
|
|
|
|
txs ; LINE BUFFER DURING PARSING
|
|
|
|
lda #<COLDSTART ; SET RESTART TO COLD.START
|
|
|
|
ldy #>COLDSTART ; UNTIL COLDSTART IS COMPLETED
|
|
|
|
sta GOWARM+1
|
|
|
|
sty GOWARM+2
|
|
|
|
sta GOSTROUTZ+1 ; ALSO SECOND USER VECTOR...
|
|
|
|
sty GOSTROUTZ+2 ; ..WE SIMPLY MUST FINISH COLD.START!
|
|
|
|
lda #$4C ; "JMP" OPCODE FOR 4 VECTORS
|
|
|
|
sta GOWARM ; WARM START
|
|
|
|
sta GOSTROUTZ ; ANYONE EVER USE THIS ONE?
|
|
|
|
sta JMPADRS ; USED BY FUNCTIONS (JSR JMPADRS)
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MOVE GENERIC CHRGET AND RANDOM SEED INTO PLACE
|
|
|
|
;
|
2021-01-16 00:08:36 +00:00
|
|
|
; NOTE THAT LOOP VALUE IS WRONG!
|
2017-05-11 20:42:22 +00:00
|
|
|
; THE LAST BYTE OF THE RANDOM SEED IS NOT
|
|
|
|
; COPIED INTO PAGE ZERO!
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ldx #GENERIC_END-GENERIC_CHRGET-1
|
|
|
|
@1: lda GENERIC_CHRGET-1,x
|
|
|
|
sta CHRGET-1,x
|
|
|
|
dex
|
|
|
|
bne @1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
txa ; A=0
|
|
|
|
sta SHIFTSIGNEXT
|
|
|
|
sta LASTPT+1
|
|
|
|
pha ; PUT $00 ON STACK (WHAT FOR?)
|
|
|
|
lda #3 ; SET LENGTH OF TEMP. STRING DESCRIPTORS
|
|
|
|
sta DSCLEN ; FOR GARBAGE COLLECTION SUBROUTINE
|
|
|
|
jsr CRDO ; PRINT <RETURN>
|
|
|
|
lda #1 ; SET UP FAKE FORWARD LINK
|
|
|
|
sta INPUTBUFFER-3
|
|
|
|
sta INPUTBUFFER-4
|
|
|
|
ldx #TEMPST ; INIT INDEX TO TEMP STRING DESCRIPTORS
|
|
|
|
stx TEMPPT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; FIND HIGH END OF RAM
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
lda #<$0800 ; SET UP POINTER TO LOW END OF RAM
|
|
|
|
ldy #>$0800
|
|
|
|
sta LINNUM
|
|
|
|
sty LINNUM+1
|
|
|
|
ldy #0
|
|
|
|
@2: inc LINNUM+1 ; TEST FIRST BYTE OF EACH PAGE
|
|
|
|
lda (LINNUM),y ; BY COMPLEMENTING IT AND WATCHING
|
|
|
|
eor #$FF ; IT CHANGE THE SAME WAY
|
|
|
|
sta (LINNUM),y
|
|
|
|
cmp (LINNUM),y ; ROM OR EMPTY SOCKETS WON'T TRACK
|
|
|
|
bne @3 ; NOT RAM HERE
|
|
|
|
eor #$FF ; RESTORE ORIGINAL VALUE
|
|
|
|
sta (LINNUM),y
|
|
|
|
cmp (LINNUM),y ; DID IT TRACK AGAIN?
|
|
|
|
beq @2 ; YES, STILL IN RAM
|
|
|
|
@3: ldy LINNUM ; NO, END OF RAM
|
|
|
|
lda LINNUM+1
|
|
|
|
and #$F0 ; FORCE A MULTIPLE OF 4096 BYTES
|
|
|
|
sty MEMSIZ ; (BAD RAM MAY HAVE YIELDED NON-MULTIPLE)
|
|
|
|
sta MEMSIZ+1
|
|
|
|
sty FRETOP ; SET HIMEM AND BOTTOM OF STRINGS
|
|
|
|
sta FRETOP+1
|
|
|
|
ldx #<$0800 ; SET PROGRAM POINTER TO $0800
|
|
|
|
ldy #>$0800
|
|
|
|
stx TXTTAB
|
|
|
|
sty TXTTAB+1
|
|
|
|
ldy #0 ; TURN OFF SEMI-SECRET LOCK FLAG
|
|
|
|
sty LOCK
|
|
|
|
tya ; A=0 TOO
|
|
|
|
sta (TXTTAB),y ; FIRST BYTE IN PROGRAM SPACE = 0
|
|
|
|
inc TXTTAB ; ADVANCE PAST THE $00
|
|
|
|
bne @4
|
|
|
|
inc TXTTAB+1
|
|
|
|
@4: lda TXTTAB
|
|
|
|
ldy TXTTAB+1
|
|
|
|
jsr REASON ; SET REST OF POINTERS UP
|
|
|
|
jsr SCRTCH ; MORE POINTERS
|
|
|
|
lda #<STROUT ; PUT CORRECT ADDRESSES IN TWO
|
|
|
|
ldy #>STROUT ; USER VECTORS
|
|
|
|
sta GOSTROUTZ+1
|
|
|
|
sty GOSTROUTZ+2
|
|
|
|
lda #<RESTART
|
|
|
|
ldy #>RESTART
|
|
|
|
sta GOWARM+1
|
|
|
|
sty GOWARM+2
|
|
|
|
jmp (GOWARM+1) ; SILLY, WHY NOT JUST "JMP RESTART"
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "CALL" STATEMENT
|
|
|
|
;
|
|
|
|
; EFFECTIVELY PERFORMS A "JSR" TO THE SPECIFIED
|
|
|
|
; ADDRESS, WITH THE FOLLOWING REGISTER CONTENTS:
|
|
|
|
; (A,Y) = CALL ADDRESS
|
|
|
|
; (X) = $9D
|
|
|
|
;
|
|
|
|
; THE CALLED ROUTINE CAN RETURN WITH "RTS",
|
|
|
|
; AND APPLESOFT WILL CONTINUE WITH THE NEXT
|
|
|
|
; STATEMENT.
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
CALL: jsr FRMNUM ; EVALUATE EXPRESSION FOR CALL ADDRESS
|
|
|
|
jsr GETADR ; CONVERT EXPRESSION TO 16-BIT INTEGER
|
|
|
|
jmp (LINNUM) ; IN LINNUM, AND JUMP THERE.
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "HIMEM:" STATEMENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
HIMEM: jsr FRMNUM ; GET VALUE SPECIFIED FOR HIMEM
|
|
|
|
jsr GETADR ; AS 16-BIT INTEGER
|
|
|
|
lda LINNUM ; MUST BE ABOVE VARIABLES AND ARRAYS
|
|
|
|
cmp STREND
|
|
|
|
lda LINNUM+1
|
|
|
|
sbc STREND+1
|
|
|
|
bcs SETHI ; IT IS ABOVE THEM
|
|
|
|
JMM: jmp MEMERR ; NOT ENOUGH MEMORY
|
|
|
|
SETHI: lda LINNUM ; STORE NEW HIMEM: VALUE
|
|
|
|
sta MEMSIZ
|
|
|
|
sta FRETOP ; NOTE THAT "HIMEM:" DOES NOT
|
|
|
|
lda LINNUM+1 ; CLEAR STRING VARIABLES.
|
|
|
|
sta MEMSIZ+1 ; THIS COULD BE DISASTROUS.
|
|
|
|
sta FRETOP+1
|
|
|
|
rts
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "LOMEM:" STATEMENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
LOMEM: jsr FRMNUM ; GET VALUE SPECIFIED FOR LOMEM
|
|
|
|
jsr GETADR ; AS 16-BIT INTEGER IN LINNUM
|
|
|
|
lda LINNUM ; MUST BE BELOW HIMEM
|
|
|
|
cmp MEMSIZ
|
|
|
|
lda LINNUM+1
|
|
|
|
sbc MEMSIZ+1
|
|
|
|
bcs JMM ; ABOVE HIMEM, MEMORY ERROR
|
|
|
|
lda LINNUM ; MUST BE ABOVE PROGRAM
|
|
|
|
cmp VARTAB
|
|
|
|
lda LINNUM+1
|
|
|
|
sbc VARTAB+1
|
|
|
|
bcc JMM ; NOT ABOVE PROGRAM, ERROR
|
|
|
|
lda LINNUM ; STORE NEW LOMEM VALUE
|
|
|
|
sta VARTAB
|
|
|
|
lda LINNUM+1
|
|
|
|
sta VARTAB+1
|
|
|
|
jmp CLEARC ; LOMEM CLEARS VARIABLES AND ARRAYS
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "ON ERR GO TO" STATEMENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ONERR: lda #TOKEN_GOTO ; MUST BE "GOTO" NEXT
|
|
|
|
jsr SYNCHR
|
|
|
|
lda TXTPTR ; SAVE TXTPTR FOR HANDLERR
|
|
|
|
sta TXTPSV
|
|
|
|
lda TXTPTR+1
|
|
|
|
sta TXTPSV+1
|
|
|
|
sec ; SET SIGN BIT OF ERRFLG
|
|
|
|
ror ERRFLG
|
|
|
|
lda CURLIN ; SAVE LINE # OF CURRENT LINE
|
|
|
|
sta CURLSV
|
|
|
|
lda CURLIN+1
|
|
|
|
sta CURLSV+1
|
|
|
|
jsr REMN ; IGNORE REST OF LINE <<<WHY?>>>
|
|
|
|
jmp ADDON ; CONTINUE PROGRAM
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; ROUTINE TO HANDLE ERRORS IF ONERR GOTO ACTIVE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
HANDLERR:
|
|
|
|
stx ERRNUM ; SAVE ERROR CODE NUMBER
|
|
|
|
ldx REMSTK ; GET STACK PNTR SAVED AT NEWSTT
|
|
|
|
stx ERRSTK ; REMEMBER IT
|
|
|
|
lda CURLIN ; GET LINE # OF OFFENDING STATEMENT
|
|
|
|
sta ERRLIN ; SO USER CAN SEE IT IF DESIRED
|
|
|
|
lda CURLIN+1
|
|
|
|
sta ERRLIN+1
|
|
|
|
lda OLDTEXT ; ALSO THE POSITION IN THE LINE
|
|
|
|
sta ERRPOS ; IN CASE USER WANTS TO "RESUME"
|
|
|
|
lda OLDTEXT+1
|
|
|
|
sta ERRPOS+1
|
|
|
|
lda TXTPSV ; SET UP TXTPTR TO READ TARGET LINE #
|
|
|
|
sta TXTPTR ; IN "ON ERR GO TO XXXX"
|
|
|
|
lda TXTPSV+1
|
|
|
|
sta TXTPTR+1
|
|
|
|
lda CURLSV
|
|
|
|
sta CURLIN ; LINE # OF "ON ERR" STATEMENT
|
|
|
|
lda CURLSV+1
|
|
|
|
sta CURLIN+1
|
|
|
|
jsr CHRGOT ; START CONVERSION
|
|
|
|
jsr GOTO ; GOTO SPECIFIED ONERR LINE
|
|
|
|
jmp NEWSTT
|
|
|
|
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; "RESUME" STATEMENT
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
RESUME: lda ERRLIN ; RESTORE LINE # AND TXTPTR
|
|
|
|
sta CURLIN ; TO RE-TRY OFFENDING LINE
|
|
|
|
lda ERRLIN+1
|
|
|
|
sta CURLIN+1
|
|
|
|
lda ERRPOS
|
|
|
|
sta TXTPTR
|
|
|
|
lda ERRPOS+1
|
|
|
|
sta TXTPTR+1
|
|
|
|
ldx ERRSTK ; RETRIEVE STACK PNTR AS IT WAS
|
|
|
|
txs ; BEFORE STATEMENT SCANNED
|
|
|
|
jmp NEWSTT ; DO STATEMENT AGAIN
|
2021-01-28 22:28:59 +00:00
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; START FROM CARTRIDGE ROUTINE
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
STARTFROMCART:
|
|
|
|
ldx #$FF ; SET DIRECT MODE FLAG
|
|
|
|
stx CURLIN+1
|
|
|
|
ldx #$FB ; SET STACK POINTER, LEAVING ROOM FOR
|
|
|
|
txs ; LINE BUFFER DURING PARSING
|
|
|
|
lda #<COLDSTART ; SET RESTART TO COLD.START
|
|
|
|
ldy #>COLDSTART ; UNTIL COLDSTART IS COMPLETED
|
|
|
|
sta GOWARM+1
|
|
|
|
sty GOWARM+2
|
|
|
|
sta GOSTROUTZ+1 ; ALSO SECOND USER VECTOR...
|
|
|
|
sty GOSTROUTZ+2 ; ..WE SIMPLY MUST FINISH COLD.START!
|
|
|
|
lda #$4C ; "JMP" OPCODE FOR 4 VECTORS
|
|
|
|
sta GOWARM ; WARM START
|
|
|
|
sta GOSTROUTZ ; ANYONE EVER USE THIS ONE?
|
|
|
|
sta JMPADRS ; USED BY FUNCTIONS (JSR JMPADRS)
|
|
|
|
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
; MOVE GENERIC CHRGET AND RANDOM SEED INTO PLACE
|
|
|
|
;
|
|
|
|
; NOTE THAT LOOP VALUE IS WRONG!
|
|
|
|
; THE LAST BYTE OF THE RANDOM SEED IS NOT
|
|
|
|
; COPIED INTO PAGE ZERO!
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
ldx #GENERIC_END-GENERIC_CHRGET-1
|
|
|
|
@1: lda GENERIC_CHRGET-1,x
|
|
|
|
sta CHRGET-1,x
|
|
|
|
dex
|
|
|
|
bne @1
|
|
|
|
; ----------------------------------------------------------------------------
|
|
|
|
txa ; A=0
|
|
|
|
sta SHIFTSIGNEXT
|
|
|
|
sta LASTPT+1
|
|
|
|
pha ; PUT $00 ON STACK (WHAT FOR?)
|
|
|
|
lda #3 ; SET LENGTH OF TEMP. STRING DESCRIPTORS
|
|
|
|
sta DSCLEN ; FOR GARBAGE COLLECTION SUBROUTINE
|
|
|
|
jsr CRDO ; PRINT <RETURN>
|
|
|
|
lda #1 ; SET UP FAKE FORWARD LINK
|
|
|
|
sta INPUTBUFFER-3
|
|
|
|
sta INPUTBUFFER-4
|
|
|
|
ldx #TEMPST ; INIT INDEX TO TEMP STRING DESCRIPTORS
|
|
|
|
stx TEMPPT
|
|
|
|
jsr STXTPT ; SET TXTPTR TO TXTTAB-1
|
|
|
|
ldy #0
|
|
|
|
lda #0
|
|
|
|
sta (TXTPTR),y ; ZERO THE TXTPTR - FOR SAKE OF RUN STATEMENT
|
|
|
|
lda #<STROUT ; PUT CORRECT ADDRESSES IN TWO
|
|
|
|
ldy #>STROUT ; USER VECTORS
|
|
|
|
sta GOSTROUTZ+1
|
|
|
|
sty GOSTROUTZ+2
|
|
|
|
lda #<RESTART
|
|
|
|
ldy #>RESTART
|
|
|
|
sta GOWARM+1
|
|
|
|
sty GOWARM+2
|
|
|
|
lda #$00
|
|
|
|
sta CURLIN
|
|
|
|
sta CURLIN+1
|
|
|
|
jmp FIX_LINKS ; FIX LINKS FOR PROGRAM
|