applesoft-lite/applesoft-lite.s

5564 lines
158 KiB
ArmAsm

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