Apple-2-Tools/Steve2
1
0
Fork 0
mirror of https://github.com/trudnai/Steve2.git synced 2024-12-27 09:30:26 +00:00
Code Issues Projects Releases Wiki Activity
80col
Steve2/Apple_II_ROM.s
Tamas Rudnai 8a6f1654ee Refactoring instruction handler in switch 
Fixed some issues
2019-09-11 00:11:45 -07:00

6915 lines
282 KiB
ArmAsm
Raw Permalink Blame History

include(`asm.m4h')
; --------------------------------
;
; Applesoft BASIC, V2
;
; Written by Marc McDonald and Randy Wigginton.
;
; Original copyright 1976 by Microsoft,
; 1977 by Apple Computer.
;
; Disassembled by (unknown).
; Fixed by Chris Mosher.
;
; For the cc65.org Assembler (ca65)
;
; Applesoft BASIC was first written by
; Marc McDonald, the first employee of Microsoft,
; in mid-1976. That version was bought by Apple
; and released (on casette) in Nov. 1977.
;
; Version 2 was written by Randy Wigginton and
; others at Apple in spring 1978. This version
; was released in several different forms. The
; one reproduced by this source assembly file is
; the main-board ROM form, which appeared in the
; Apple ][ plus ROM at $D000-$F7FF.
;
; --------------------------------
; --------------------------------
; ZERO PAGE LOCATIONS:
; --------------------------------
GOWARM = $00 ; GETS "JMP RESTART"
GOSTROUT = $03 ; GETS "JMP STROUT"
USR = $0A ; GETS "JMP <USER ADDR>"
; (INITIALLY $E199)
CHARAC = $0D ; ALTERNATE STRING TERMINATOR
ENDCHR = $0E ; STRING TERMINATOR
TKN_CNTR = $0F ; USED IN PARSE
EOL_PNTR = $0F ; USED IN NXLIN
NUMDIM = $0F ; USED IN ARRAY ROUTINES
DIMFLG = $10 ;
VALTYP = $11 ; $:VALTYP=$FF; %:VALTYP+1=$80
DATAFLG = $13 ; USED IN PARSE
GARFLG = $13 ; USED IN GARBAG
SUBFLG = $14 ;
INPUTFLG = $15 ; = $40 FOR GET, $98 FOR READ
CPRMASK = $16 ; RECEIVES CPRTYP IN FRMEVL
SIGNFLG = $16 ; FLAGS SIGN IN TAN
HGR_SHAPE = $1A ;
HGR_BITS = $1C ;
HGR_COUNT = $1D ;
MON_CH = $24 ;
MON_GBASL = $26 ;
MON_GBASH = $27 ;
MON_H2 = $2C ;
MON_V2 = $2D ;
MON_HMASK = $30 ;
MON_INVFLG = $32 ;
MON_PROMPT = $33 ;
MON_A1L = $3C ; USED BY TAPE I/O ROUTINES
MON_A1H = $3D ; "
MON_A2L = $3E ; "
MON_A2H = $3F ; "
LINNUM = $50 ; CONVERTED LINE #
TEMPPT = $52 ; LAST USED TEMP STRING DESC
LASTPT = $53 ; LAST USED TEMP STRING PNTR
TEMPST = $55 ; HOLDS UP TO 3 DESCRIPTORS
INDEX = $5E ;
DEST = $60 ;
RESULT = $62 ; RESULT OF LAST * OR /
TXTTAB = $67 ; START OF PROGRAM TEXT
VARTAB = $69 ; START OF VARIABLE STORAGE
ARYTAB = $6B ; START OF ARRAY STORAGE
STREND = $6D ; END OF ARRAY STORAGE
FRETOP = $6F ; START OF STRING STORAGE
FRESPC = $71 ; TEMP PNTR, STRING ROUTINES
MEMSIZ = $73 ; END OF STRING SPACE (HIMEM)
CURLIN = $75 ; CURRENT LINE NUMBER
; ( = $FFXX IF IN DIRECT MODE)
OLDLIN = $77 ; ADDR. OF LAST LINE EXECUTED
OLDTEXT = $79 ;
DATLIN = $7B ; LINE # OF CURRENT DATA STT.
DATPTR = $7D ; ADDR OF CURRENT DATA STT.
INPTR = $7F ;
VARNAM = $81 ; NAME OF VARIABLE
VARPNT = $83 ; ADDR OF VARIABLE
FORPNT = $85 ;
TXPSV = $87 ; USED IN INPUT
LASTOP = $87 ; SCRATCH FLAG USED IN FRMEVL
CPRTYP = $89 ; >,=,< FLAG IN FRMEVL
TEMP3 = $8A ;
FNCNAM = $8A ;
DSCPTR = $8C ;
DSCLEN = $8F ; USED IN GARBAG
JMPADRS = $90 ; GETS "JMP ...."
LENGTH = $91 ; USED IN GARBAG
ARG_EXTENSION = $92 ; FP EXTRA PRECISION
TEMP1 = $93 ; SAVE AREAS FOR FAC
ARYPNT = $94 ; USED IN GARBAG
HIGHDS = $94 ; PNTR FOR BLTU
HIGHTR = $96 ; PNTR FOR BLTU
TEMP2 = $98 ;
TMPEXP = $99 ; USED IN FIN (EVAL)
INDX = $99 ; USED BY ARRAY RTNS
EXPON = $9A ; "
DPFLG = $9B ; FLAGS DEC PNT IN FIN
LOWTR = $9B ;
EXPSGN = $9C ;
FAC = $9D ; MAIN FLT PT ACCUMULATOR
DSCTMP = $9D ;
VPNT = $A0 ; TEMP VAR PTR
FAC_SIGN = $A2 ; HOLDS UNPACKED SIGN
SERLEN = $A3 ; HOLDS LENGTH OF SERIES-1
SHIFT_SIGN_EXT = $A4 ; SIGN EXTENSION, RIGHT SHIFTS
ARG = $A5 ; SECONDARY FP ACC
ARG_SIGN = $AA ;
SGNCPR = $AB ; FLAGS OPP SIGN IN FP ROUT.
FAC_EXTENSION = $AC ; FAC EXTENSION BYTE
SERPNT = $AD ; PNTR TO SERIES DATA IN FP
STRNG1 = $AB ;
STRNG2 = $AD ;
PRGEND = $AF ;
CHRGET = $B1 ;
CHRGOT = $B7 ;
TXTPTR = $B8 ;
RNDSEED = $C9 ;
HGR_DX = $D0 ;
HGR_DY = $D2 ;
HGR_QUADRANT = $D3 ;
HGR_E = $D4 ;
LOCK = $D6 ; NO USER ACCESS IF > 127
ERRFLG = $D8 ; $80 IF ON ERR ACTIVE
ERRLIN = $DA ; LINE # WHERE ERROR OCCURRED
ERRPOS = $DC ; TXTPTR SAVE FOR HANDLERR
ERRNUM = $DE ; WHICH ERROR OCCURRED
ERRSTK = $DF ; STACK PNTR BEFORE ERROR
HGR_X = $E0 ;
HGR_Y = $E2 ;
HGR_COLOR = $E4 ;
HGR_HORIZ = $E5 ; BYTE INDEX FROM GBASH,L
HGR_PAGE = $E6 ; HGR=$20, HGR2=$40
HGR_SCALE = $E7 ;
HGR_SHAPE_PNTR = $E8 ;
HGR_COLLISIONS = $EA ;
FIRST = $F0 ;
SPEEDZ = $F1 ; OUTPUT SPEED
TRCFLG = $F2 ;
FLASH_BIT = $F3 ; = $40 FOR FLASH, ELSE =$00
TXTPSV = $F4 ;
CURLSV = $F6 ;
REMSTK = $F8 ; STACK PNTR BEFORE EACH STT.
HGR_ROTATION = $F9 ;
; $FF IS ALSO USED BY THE STRING OUT ROUTINES
; --------------------------------
STACK = $0100
INPUT_BUFFER = $0200
AMPERSAND_VECTOR = $03F5 ; - 3F7 GETS "JMP ...."
; --------------------------------
; I/O & SOFT SWITCHES
; --------------------------------
KEYBOARD = $C000
SW_TXTCLR = $C050
SW_MIXCLR = $C052
SW_MIXSET = $C053
SW_LOWSCR = $C054
SW_HISCR = $C055
SW_LORES = $C056
SW_HIRES = $C057
; --------------------------------
; MONITOR SUBROUTINES
; --------------------------------
MON_PLOT = $F800
MON_HLINE = $F819
MON_VLINE = $F828
MON_SETCOL = $F864
MON_SCRN = $F871
MON_PREAD = $FB1E
MON_SETTXT = $FB39
MON_SETGR = $FB40
MON_TABV = $FB5B
MON_HOME = $FC58
MON_WAIT = $FCA8
MON_RD2BIT = $FCFA
MON_RDKEY = $FD0C
MON_GETLN = $FD6A
MON_COUT = $FDED
MON_INPORT = $FE8B
MON_OUTPORT = $FE95
MON_WRITE = $FECD
MON_READ = $FEFD
MON_READ2 = $FF02
; --------------------------------
; --------------------------------
; APPLESOFT TOKENS
; --------------------------------
TOKEN_FOR = $81
TOKENDWTA = $83
TOKEN_POP = $A1
TOKEN_GOTO = $AB
TOKEN_GOSUB = $B0
TOKEN_REM = $B2
TOKEN_PRINT = $BA
TOKEN_TAB = $C0
TOKEN_TO = $C1
TOKEN_FN = $C2
TOKEN_SPC = $C3
TOKEN_THEN = $C4
TOKENDB = $C5
TOKEN_NOT = $C6
TOKEN_STEP = $C7
TOKEN_PLUS = $C8
TOKEN_MINUS = $C9
TOKEN_GREATER = $CF
TOKENEQUUAL = $D0
TOKEN_SGN = $D2
TOKEN_SCRN = $D7
TOKEN_LEFTSTR = $E8
; --------------------------------
; BRANCH TABLE FOR TOKENS
; --------------------------------
TOKEN_ADDRESS_TABLE ASM_ADDR(`ENDX-1') ; $80...128...END
ASM_ADDR(`FOR-1') ; $81...129...FOR
ASM_ADDR(`NEXT-1') ; $82...130...NEXT
ASM_ADDR(`DATA-1') ; $83...131..DWTA
ASM_ADDR(`INPUT-1') ; $84...132...INPUT
ASM_ADDR(`DEL-1') ; $85...133...DEL
ASM_ADDR(`DIM-1') ; $86...134...DIM
ASM_ADDR(`READ-1') ; $87...135...READ
ASM_ADDR(`GR-1') ; $88...136...GR
ASM_ADDR(`TEXT-1') ; $89...137...TEXT
ASM_ADDR(`PR_NUMBER-1') ; $8A...138...PR#
ASM_ADDR(`IN_NUMBER-1') ; $8B...139...IN#
ASM_ADDR(`CALL-1') ; $8C...140...CALL
ASM_ADDR(`PLOT-1') ; $8D...141...PLOT
ASM_ADDR(`HLIN-1') ; $8E...142...HLIN
ASM_ADDR(`VLIN-1') ; $8F...143...VLIN
ASM_ADDR(`HGR2-1') ; $90...144...HGR2
ASM_ADDR(`HGR-1') ; $91...145...HGR
ASM_ADDR(`HCOLOR-1') ; $92...146...HCOLOR=
ASM_ADDR(`HPLOT-1') ; $93...147...HPLOT
ASM_ADDR(`DRAW-1') ; $94...148...DRAW
ASM_ADDR(`XDRAW-1') ; $95...149...XDRAW
ASM_ADDR(`HTAB-1') ; $96...150...HTAB
ASM_ADDR(`MON_HOME-1') ; $97...151...HOME
ASM_ADDR(`ROT-1') ; $98...152...ROT=
ASM_ADDR(`SCALE-1') ; $99...153...SCALE=
ASM_ADDR(`SHLOAD-1') ; $9A...154...SHLOAD
ASM_ADDR(`TRACE-1') ; $9B...155...TRACE
ASM_ADDR(`NOTRACE-1') ; $9C...156...NOTRACE
ASM_ADDR(`NORMAL-1') ; $9D...157...NORMAL
ASM_ADDR(`INVERSE-1') ; $9E...158...INVERSE
ASM_ADDR(`FLASH-1') ; $9F...159...FLASH
ASM_ADDR(`COLOR-1') ; $A0...160...COLOR=
ASM_ADDR(`POP-1') ; $A1...161...POP
ASM_ADDR(`VTAB-1') ; $A2...162...VTAB
ASM_ADDR(`HIMEM-1') ; $A3...163...HIMEM:
ASM_ADDR(`LOMEM-1') ; $A4...164...LOMEM:
ASM_ADDR(`ONERR-1') ; $A5...165...ONERR
ASM_ADDR(`RESUME-1') ; $A6...166...RESUME
ASM_ADDR(`RECALL-1') ; $A7...167...RECALL
ASM_ADDR(`STORE-1') ; $A8...168...STORE
ASM_ADDR(`SPEED-1') ; $A9...169...SPEED=
ASM_ADDR(`LET-1') ; $AA...170...LET
ASM_ADDR(`GOTO-1') ; $AB...171...GOTO
ASM_ADDR(`RUN-1') ; $AC...172...RUN
ASM_ADDR(`IF-1') ; $AD...173...IF
ASM_ADDR(`RESTORE-1') ; $AE...174...RESTORE
ASM_ADDR(`AMPERSAND_VECTOR-1') ; $AF...175...&
ASM_ADDR(`GOSUB-1') ; $B0...176...GOSUB
ASM_ADDR(`POP-1') ; $B1...177...RETURN
ASM_ADDR(`REM-1') ; $B2...178...REM
ASM_ADDR(`STOP-1') ; $B3...179...STOP
ASM_ADDR(`ONGOTO-1') ; $B4...180...ON
ASM_ADDR(`WAIT-1') ; $B5...181...WAIT
ASM_ADDR(`LOAD-1') ; $B6...182...LOAD
ASM_ADDR(`SAVE-1') ; $B7...183...SAVE
ASM_ADDR(`DEF-1') ; $B8...184...DEF
ASM_ADDR(`POKE-1') ; $B9...185...POKE
ASM_ADDR(`PRINT-1') ; $BA...186...PRINT
ASM_ADDR(`CONT-1') ; $BB...187...CONT
ASM_ADDR(`LIST-1') ; $BC...188...LIST
ASM_ADDR(`CLEAR-1') ; $BD...189...CLEAR
ASM_ADDR(`GET-1') ; $BE...190...GET
ASM_ADDR(`NEW-1') ; $BF...191...NEW
; --------------------------------
UNFNC ASM_ADDR(`SGN') ; $D2...210...SGN
ASM_ADDR(`INT') ; $D3...211...INT
ASM_ADDR(`ABS') ; $D4...212...ABS
ASM_ADDR(`USR') ; $D5...213...USR
ASM_ADDR(`FRE') ; $D6...214...FRE
ASM_ADDR(`ERROR') ; $D7...215...SCRN(
ASM_ADDR(`PDL') ; $D8...216...PDL
ASM_ADDR(`POS') ; $D9...217...POS
ASM_ADDR(`SQR') ; $DA...218...SQR
ASM_ADDR(`RND') ; $DB...219...RND
ASM_ADDR(`LOG') ; $DC...220...LOG
ASM_ADDR(`EXP') ; $DD...221...EXP
ASM_ADDR(`COS') ; $DE...222...COS
ASM_ADDR(`SIN') ; $DF...223...SIN
ASM_ADDR(`TAN') ; $E0...224...TAN
ASM_ADDR(`ATN') ; $E1...225...ATN
ASM_ADDR(`PEEK') ; $E2...226...PEEK
ASM_ADDR(`LEN') ; $E3...227...LEN
ASM_ADDR(`STR') ; $E4...228...STR$
ASM_ADDR(`VAL') ; $E5...229...VAL
ASM_ADDR(`ASC') ; $E6...230...ASC
ASM_ADDR(`CHRSTR') ; $E7...231...CHR$
ASM_ADDR(`LEFTSTR') ; $E8...232...LEFT$
ASM_ADDR(`RIGHTSTR') ; $E9...233...RIGHT$
ASM_ADDR(`MIDSTR') ; $EA...234...MID$
; --------------------------------
; MATH OPERATOR BRANCH TABLE
;
; ONE-BYTE PRECEDENCE CODE
; TWO-BYTE ADDRESS
; --------------------------------
P_OR = $46 ; "OR" IS LOWEST PRECEDENCE
P_AND = $50 ;
P_REL = $64 ; RELATIONAL OPERATORS
P_ADD = $79 ; BINARY + AND -
P_MUL = $7B ; * AND /
P_PWR = $7D ; EXPONENTIATION
P_NEQ = $7F ; UNARY - AND COMPARISON =
; --------------------------------
MATHTBL ASM_DATA(`P_ADD')
ASM_ADDR(`FADDT-1') ; $C8...200...+
ASM_DATA(`P_ADD')
ASM_ADDR(`FSUBT-1') ; $C9...201...-
ASM_DATA(`P_MUL')
ASM_ADDR(`FMULTT-1') ; $CA...202...*
ASM_DATA(`P_MUL')
ASM_ADDR(`FDIVT-1') ; $CB...203.../
ASM_DATA(`P_PWR')
ASM_ADDR(`FPWRT-1') ; $CC...204...^
ASM_DATA(`P_AND')
ASM_ADDR(`ANDOP-1') ; $CD...205...AND
ASM_DATA(`P_OR')
ASM_ADDR(`OR-1') ; $CE...206...OR
M_NEG ASM_DATA(`P_NEQ')
ASM_ADDR(`NEGOP-1') ; $CF...207...>
MEQUU ASM_DATA(`P_NEQ')
ASM_ADDR(`EQUOP-1') ; $D0...208...=
M_REL ASM_DATA(`P_REL')
ASM_ADDR(`RELOPS-1') ; $D1...209...<
; --------------------------------
; TOKEN NAME TABLE
; --------------------------------
;
TOKEN_NAME_TABLE LHASCII(`END') ; $80...128
LHASCII(`FOR') ; $81...129
LHASCII(`NEXT') ; $82...130
LHASCII(`DATA') ; $83...131
LHASCII(`INPUT') ; $84...132
LHASCII(`DEL') ; $85...133
LHASCII(`DIM') ; $86...134
LHASCII(`READ') ; $87...135
LHASCII(`GR') ; $88...136
LHASCII(`TEXT') ; $89...137
LHASCII(`PR#') ; $8A...138
LHASCII(`IN#') ; $8B...139
LHASCII(`CALL') ; $8C...140
LHASCII(`PLOT') ; $8D...141
LHASCII(`HLIN') ; $8E...142
LHASCII(`VLIN') ; $8F...143
LHASCII(`HGR2') ; $90...144
LHASCII(`HGR') ; $91...145
LHASCII(`HCOLOR=') ; $92...146
LHASCII(`HPLOT') ; $93...147
LHASCII(`DRAW') ; $94...148
LHASCII(`XDRAW') ; $95...149
LHASCII(`HTAB') ; $96...150
LHASCII(`HOME') ; $97...151
LHASCII(`ROT=') ; $98...152
LHASCII(`SCALE=') ; $99...153
LHASCII(`SHLOAD') ; $9A...154
LHASCII(`TRACE') ; $9B...155
LHASCII(`NOTRACE') ; $9C...156
LHASCII(`NORMAL') ; $9D...157
LHASCII(`INVERSE') ; $9E...158
LHASCII(`FLASH') ; $9F...159
LHASCII(`COLOR=') ; $A0...160
LHASCII(`POP') ; $A1...161
LHASCII(`VTAB') ; $A2...162
LHASCII(`HIMEM:') ; $A3...163
LHASCII(`LOMEM:') ; $A4...164
LHASCII(`ONERR') ; $A5...165
LHASCII(`RESUME') ; $A6...166
LHASCII(`RECALL') ; $A7...167
LHASCII(`STORE') ; $A8...168
LHASCII(`SPEED=') ; $A9...169
LHASCII(`LET') ; $AA...170
LHASCII(`GOTO') ; $AB...171
LHASCII(`RUN') ; $AC...172
LHASCII(`IF') ; $AD...173
LHASCII(`RESTORE') ; $AE...174
LHASCII(`&') ; $AF...175
LHASCII(`GOSUB') ; $B0...176
LHASCII(`RETURN') ; $B1...177
LHASCII(`REM') ; $B2...178
LHASCII(`STOP') ; $B3...179
LHASCII(`ON') ; $B4...180
LHASCII(`WAIT') ; $B5...181
LHASCII(`LOAD') ; $B6...182
LHASCII(`SAVE') ; $B7...183
LHASCII(`DEF') ; $B8...184
LHASCII(`POKE') ; $B9...185
LHASCII(`PRINT') ; $BA...186
LHASCII(`CONT') ; $BB...187
LHASCII(`LIST') ; $BC...188
LHASCII(`CLEAR') ; $BD...189
LHASCII(`GET') ; $BE...190
LHASCII(`NEW') ; $BF...191
LOASCII(`TAB') ; $C0...192
ASM_DATA($A8)
LHASCII(`TO') ; $C1...193
LHASCII(`FN') ; $C2...194
LOASCII(`SPC') ; $C3...195
ASM_DATA($A8)
LHASCII(`THEN') ; $C4...196
LHASCII(`AT') ; $C5...197
LHASCII(`NOT') ; $C6...198
LHASCII(`STEP') ; $C7...199
LHASCII(`+') ; $C8...200
LHASCII(`-') ; $C9...201
LHASCII(`*') ; $CA...202
LHASCII(`/') ; $CB...203
ASM_DATA($DE)
; LHASCII(`^') ; $CC...204
LHASCII(`AND') ; $CD...205
LHASCII(`OR') ; $CE...206
LHASCII(`>') ; $CF...207
LHASCII(`=') ; $D0...208
LHASCII(`<') ; $D1...209
LHASCII(`SGN') ; $D2...210
LHASCII(`INT') ; $D3...211
LHASCII(`ABS') ; $D4...212
LHASCII(`USR') ; $D5...213
LHASCII(`FRE') ; $D6...214
LOASCII(`SCRN') ; $D7...215
ASM_DATA($A8)
LHASCII(`PDL') ; $D8...216
LHASCII(`POS') ; $D9...217
LHASCII(`SQR') ; $DA...218
LHASCII(`RND') ; $DB...219
LHASCII(`LOG') ; $DC...220
LHASCII(`EXP') ; $DD...221
LHASCII(`COS') ; $DE...222
LHASCII(`SIN') ; $DF...223
LHASCII(`TAN') ; $E0...224
LHASCII(`ATN') ; $E1...225
LHASCII(`PEEK') ; $E2...226
LHASCII(`LEN') ; $E3...227
LHASCII(`STR$') ; $E4...228
LHASCII(`VAL') ; $E5...229
LHASCII(`ASC') ; $E6...230
LHASCII(`CHR$') ; $E7...231
LHASCII(`LEFT$') ; $E8...232
LHASCII(`RIGHT$') ; $E9...233
LHASCII(`MID$') ; $EA...234
ASM_DATA(0) ; END OF TOKEN NAME TABLE
; --------------------------------
; --------------------------------
; ERROR MESSAGES
; --------------------------------
ERROR_MESSAGES
ERR_NOFOR = *-ERROR_MESSAGES
LHASCII(`NEXT WITHOUT FOR')
ERR_SYNTAX = *-ERROR_MESSAGES
LHASCII(`SYNTAX')
ERR_NOGOSUB = *-ERROR_MESSAGES
LHASCII(`RETURN WITHOUT GOSUB')
ERR_NODATA = *-ERROR_MESSAGES
LHASCII(`OUT OF DATA')
ERR_ILLQTY = *-ERROR_MESSAGES
LHASCII(`ILLEGAL QUANTITY')
ERR_OVERFLOW = *-ERROR_MESSAGES
LHASCII(`OVERFLOW')
ERR_MEMFULL = *-ERROR_MESSAGES
LHASCII(`OUT OF MEMORY')
ERR_UNDEFSTAT = *-ERROR_MESSAGES
LOASCII(`UNDEF')
ASM_DATA($27)
LHASCII(`D STATEMENT')
ERR_BADSUBS = *-ERROR_MESSAGES
LHASCII(`BAD SUBSCRIPT')
ERR_REDIMD = *-ERROR_MESSAGES
LOASCII(`REDIM')
ASM_DATA($27)
LHASCII(`D ARRAY')
ERR_ZERODIV = *-ERROR_MESSAGES
LHASCII(`DIVISION BY ZERO')
ERR_ILLDIR = *-ERROR_MESSAGES
LHASCII(`ILLEGAL DIRECT')
ERR_BADTYPE = *-ERROR_MESSAGES
LHASCII(`TYPE MISMATCH')
ERR_STRLONG = *-ERROR_MESSAGES
LHASCII(`STRING TOO LONG')
ERR_FRMCPX = *-ERROR_MESSAGES
LHASCII(`FORMULA TOO COMPLEX')
ERR_CANTCONT = *-ERROR_MESSAGES
LOASCII(`CAN')
ASM_DATA($27)
LHASCII(`T CONTINUE')
ERR_UNDEFFUNC = *-ERROR_MESSAGES
LOASCII(`UNDEF')
ASM_DATA($27)
LHASCII(`D FUNCTION')
; --------------------------------
QT_ERROR LOASCII(` ERROR')
ASM_DATA($07,0)
QT_IN LOASCII(` IN ')
ASM_DATA(0)
QT_BREAK ASM_DATA($0D)
LOASCII(`BREAK')
ASM_DATA($07,0)
; --------------------------------
; 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
;
; EQU. IF FOUND
; (X) = STACK PNTR OF FRAME FOUND
; --------------------------------
GTFORPNT
TSX
INX
INX
INX
INX
L_GTFORPNT_1 LDA STACK+1,X ; "FOR" FRAME HERE?
CMP #TOKEN_FOR ;
BNE L_GTFORPNT_4 ; NO
LDA FORPNT+1 ; YES -- "NEXT" WITH NO VARIABLE?
BNE L_GTFORPNT_2 ; NO, VARIABLE SPECIFIED
LDA STACK+2,X ; YES, SO USE THIS FRAME
STA FORPNT ;
LDA STACK+3,X ;
STA FORPNT+1 ;
L_GTFORPNT_2 CMP STACK+3,X ; IS VARIABLE IN THIS FRAME?
BNE L_GTFORPNT_3 ; NO
LDA FORPNT ; LOOK AT 2ND BYTE TOO
CMP STACK+2,X ; SAME VARIABLE?
BEQ L_GTFORPNT_4 ; YES
L_GTFORPNT_3 TXA ; NO, SO TRY NEXT FRAME (IF ANY)
CLC ; 18 BYTES PER FRAME
ADC #18 ;
TAX
BNE L_GTFORPNT_1 ; ...ALWAYS?
L_GTFORPNT_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 L_BLTU2_4 ; NO PARTIAL PAGE
LDA HIGHTR ; BACK UP HIGHTR # BYTES IN PARTIAL PAGE
SEC ;
SBC INDEX ;
STA HIGHTR ;
BCS L_BLTU2_1 ;
DEC HIGHTR+1 ;
SEC ;
L_BLTU2_1 LDA HIGHDS ; BACK UP HIGHDS # BYTES IN PARTIAL PAGE
SBC INDEX ;
STA HIGHDS ;
BCS L_BLTU2_3 ;
DEC HIGHDS+1 ;
BCC L_BLTU2_3 ; ...ALWAYS
L_BLTU2_2 LDA (HIGHTR),Y ; MOVE THE BYTES
STA (HIGHDS),Y
L_BLTU2_3 DEY
BNE L_BLTU2_2 ; LOOP TO END OF THIS 256 BYTES
LDA (HIGHTR),Y ; MOVE ONE MORE BYTE
STA (HIGHDS),Y
L_BLTU2_4 DEC HIGHTR+1 ; DOWN TO NEXT BLOCK OF 256
DEC HIGHDS+1
DEX ; ANOTHER BLOCK OF 256 TO MOVE?
BNE L_BLTU2_3 ; YES
RTS ; NO, FINISHED
; --------------------------------
; CHECK IF ENOUGH ROOM LEFT ON STACK
; FOR "FOR", "GOSUB", OR EXPRESSION EVALUATION
; --------------------------------
CHKMEM ASL
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 L_REASON_4 ; PLENTY OF ROOM
BNE L_REASON_1 ; NOT ENOUGH, TRY GARBAGE COLLECTION
CMP FRETOP ; LOW BYTE
BCC L_REASON_4 ; ENOUGH ROOM
; --------------------------------
L_REASON_1 PHA ; SAVE (Y,A), TEMP1, AND TEMP2
LDX #FAC-TEMP1-1
TYA
L_REASON_2 PHA
LDA TEMP1,X
DEX
BPL L_REASON_2
JSR GARBAG ; MAKE AS MUCH ROOM AS POSSIBLE
LDX #TEMP1+256-FAC+1 ; RESTORE TEMP1 AND TEMP2
L_REASON_3 PLA ; AND (Y,A)
STA FAC,X
INX
BMI L_REASON_3
PLA
TAY
PLA ; DID WE FIND ENOUGH ROOM?
CPY FRETOP+1 ; HIGH BYTE
BCC L_REASON_4 ; YES, AT LEAST A PAGE
BNE MEMERR ; NO, MEM FULL ERR
CMP FRETOP ; LOW BYTE
BCS MEMERR ; NO, MEM FULL ERR
L_REASON_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 L_ERROR_1 ; NO
JMP HANDLERR ; YES
L_ERROR_1 JSR CRDO ; PRINT <RETURN>
JSR OUTQUES ; PRINT "?"
L_ERROR_2 LDA ERROR_MESSAGES,X
PHA ; PRINT MESSAGE
JSR OUTDO
INX
PLA
BPL L_ERROR_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 #HICHAR(`]') ; 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 TRACE_ ; 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 EOL_PNTR ; 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 L_NUMBERED_LINE_1
INX
DEC DEST+1
L_NUMBERED_LINE_1 CLC
ADC INDEX
BCC L_NUMBERED_LINE_2
DEC INDEX+1
CLC
; --------------------------------
L_NUMBERED_LINE_2 LDA (INDEX),Y ; MOVE HIGHER LINES OF PROGRAM
STA (DEST),Y ; DOWN OVER THE DELETED LINE.
INY
BNE L_NUMBERED_LINE_2
INC INDEX+1
INC DEST+1
DEX
BNE L_NUMBERED_LINE_2
; --------------------------------
PUT_NEW_LINE
LDA INPUT_BUFFER ; 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 EOL_PNTR
STA HIGHDS
LDY VARTAB+1
STY HIGHTR+1
BCC L_PUT_NEW_LINE_1
INY
L_PUT_NEW_LINE_1 STY HIGHDS+1
JSR BLTU ; MAKE ROOM FOR THE LINE
LDA LINNUM ; PUT LINE NUMBER IN LINE IMAGE
LDY LINNUM+1
STA INPUT_BUFFER-2
STY INPUT_BUFFER-1
LDA STREND
LDY STREND+1
STA VARTAB
STY VARTAB+1
LDY EOL_PNTR
; ---COPY LINE INTO PROGRAM-------
L_PUT_NEW_LINE_2 LDA INPUT_BUFFER-5,Y
DEY
STA (LOWTR),Y
BNE L_PUT_NEW_LINE_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
L_FIX_LINKS_1 LDY #1 ; HI-BYTE OF NEXT FORWARD PNTR
LDA (INDEX),Y ; END OF PROGRAM YET?
BNE L_FIX_LINKS_2 ; NO, KEEP GOING
LDA VARTAB ; YES
STA PRGEND
LDA VARTAB+1
STA PRGEND+1
JMP RESTART
L_FIX_LINKS_2 LDY #4 ; FIND END OF THIS LINE
L_FIX_LINKS_3 INY ; (NOTE MAXIMUM LENGTH < 256)
LDA (INDEX),Y ;
BNE L_FIX_LINKS_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 L_FIX_LINKS_1 ; ...ALWAYS
; --------------------------------
; --------------------------------
; READ A LINE, AND STRIP OFF SIGN BITS
; --------------------------------
INLIN LDX #$80 ; NULL PROMPT
INLIN2 STX MON_PROMPT
JSR MON_GETLN
CPX #239 ; MAXIMUM LINE LENGTH
BCC L_INLIN2_1
LDX #239 ; TRUNCATE AT 239 CHARS
L_INLIN2_1 LDA #0 ; MARK END OF LINE WITH $00 BYTE
STA INPUT_BUFFER,X
TXA
BEQ L_INLIN2_3 ; NULL INPUT LINE
L_INLIN2_2 LDA INPUT_BUFFER-1,X ; DROP SIGN BITS
AND #$7F
STA INPUT_BUFFER-1,X
DEX
BNE L_INLIN2_2
L_INLIN2_3 LDA #0 ; (Y,X) POINTS AT BUFFER-1
LDX #<(INPUT_BUFFER-1)
LDY #>(INPUT_BUFFER-1)
RTS
; --------------------------------
INCHR JSR MON_RDKEY ; *** OUGHT TO BE "BIT $C010" ***
AND #$7F
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
L_PARSE_1 LDA INPUT_BUFFER,X
BIT DATAFLG ; IN A "DATA" STATEMENT?
BVS L_PARSE_2 ; YES (DATAFLG = $49)
CMP #LOCHAR(` ') ; IGNORE BLANKS
BEQ PARSE ;
L_PARSE_2 STA ENDCHR ;
CMP #$22 ; START OF QUOTATION?
BEQ L_PARSE_13 ;
BVS L_PARSE_9 ; BRANCH IF IN "DATA" STATEMENT
CMP #LOCHAR(`?') ; SHORTHAND FOR "PRINT"?
BNE L_PARSE_3 ; NO
LDA #TOKEN_PRINT ; YES, REPLACE WITH "PRINT" TOKEN
BNE L_PARSE_9 ; ...ALWAYS
L_PARSE_3 CMP #LOCHAR(`0') ; IS IT A DIGIT, COLON, OR SEMI-COLON?
BCC L_PARSE_4 ; NO, PUNCTUATION !"#$%&'()*+,-./
CMP #LOCHAR(`;')+1
BCC L_PARSE_9 ; YES, NOT A TOKEN
; --------------------------------
; SEARCH TOKEN NAME TABLE FOR MATCH STARTING
; WITH CURRENT CHAR FROM INPUT LINE
; --------------------------------
L_PARSE_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 TKN_CNTR ; 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
L_PARSE_5 INY ; ADVANCE POINTER TO TOKEN TABLE
BNE L_PARSE_6 ; Y=Y+1 IS ENOUGH
INC FAC+1 ; ALSO NEED TO BUMP THE PAGE
L_PARSE_6 INX ; ADVANCE POINTER TO INPUT LINE
L_PARSE_7 LDA INPUT_BUFFER,X ; NEXT CHAR FROM INPUT LINE
CMP #LOCHAR(` ') ; THIS CHAR A BLANK?
BEQ L_PARSE_6 ; YES, IGNORE ALL BLANKS
SEC ; NO, COMPARE TO CHAR IN TABLE
SBC (FAC),Y ; SAME AS NEXT CHAR OF TOKEN NAME?
BEQ L_PARSE_5 ; YES, CONTINUE MATCHING
CMP #$80 ; MAYBE; WAS IT SAME EXCEPT FOR BIT 7?
BNE L_PARSE_14 ; NO, SKIP TO NEXT TOKEN
ORA TKN_CNTR ; YES, END OF TOKEN; GET TOKEN #
CMP #TOKENDB ; DID WE MATCH "AT"?
BNE L_PARSE_8 ; NO, SO NO AMBIGUITY
LDA INPUT_BUFFER+1,X ; "AT" COULD BE "ATN" OR "A TO"
CMP #LOCHAR(`N') ; "ATN" HAS PRECEDENCE OVER "AT"
BEQ L_PARSE_14 ; IT IS "ATN", FIND IT THE HARD WAY
CMP #LOCHAR(`O') ; "TO" HAS PRECEDENCE OVER "AT"
BEQ L_PARSE_14 ; IT IS "A TO", FIN IT THE HARD WAY
LDA #TOKENDB ; NOT "ATN" OR "A TO", SO USE "AT"
; --------------------------------
; STORE CHARACTER OR TOKEN IN OUTPUT LINE
; --------------------------------
L_PARSE_8 LDY STRNG2 ; GET INDEX TO OUTPUT LINE IN Y-REG
L_PARSE_9 INX ; ADVANCE INPUT INDEX
INY ; ADVANCE OUTPUT INDEX
STA INPUT_BUFFER-5,Y ; STORE CHAR OR TOKEN
LDA INPUT_BUFFER-5,Y ; TEST FOR EOL OR EOS
BEQ L_PARSE_17 ; END OF LINE
SEC ;
SBC #LOCHAR(`:') ; END OF STATEMENT?
BEQ L_PARSE_10 ; YES, CLEAR DATAFLG
CMP #TOKENDWTA+128-$BA ; "DATA" TOKEN?
BNE L_PARSE_11 ; NO, LEAVE DATAFLG ALONE
L_PARSE_10 STA DATAFLG ; DATAFLG = 0 OR $83-$3A = $49
L_PARSE_11 SEC ; IS IT A "REM" TOKEN?
SBC #TOKEN_REM+128-$BA
BNE L_PARSE_1 ; NO, CONTINUE PARSING LINE
STA ENDCHR ; YES, CLEAR LITERAL FLAG
; --------------------------------
; HANDLE LITERAL (BETWEEN QUOTES) OR REMARK,
; BY COPYING CHARS UP TO ENDCHR.
; --------------------------------
L_PARSE_12 LDA INPUT_BUFFER,X
BEQ L_PARSE_9 ; END OF LINE
CMP ENDCHR
BEQ L_PARSE_9 ; FOUND ENDCHR
L_PARSE_13 INY ; NEXT OUTPUT CHAR
STA INPUT_BUFFER-5,Y
INX ; NEXT INPUT CHAR
BNE L_PARSE_12 ; ...ALWAYS
; --------------------------------
; ADVANCE POINTER TO NEXT TOKEN NAME
; --------------------------------
L_PARSE_14 LDX TXTPTR ; GET POINTER TO INPUT LINE IN X-REG
INC TKN_CNTR ; BUMP (TOKEN # - $80)
L_PARSE_15 LDA (FAC),Y ; SCAN THROUGH TABLE FOR BIT7 = 1
INY ; NEXT TOKEN ONE BEYOND THAT
BNE L_PARSE_16 ; ...USUALLY ENOUGH TO BUMP Y-REG
INC FAC+1 ; NEXT SET OF 256 TOKEN CHARS
L_PARSE_16 ASL ; SEE IF SIGN BIT SET ON CHAR
BCC L_PARSE_15 ; NO, MORE IN THIS NAME
LDA (FAC),Y ; YES, AT NEXT NAME. END OF TABLE?
BNE L_PARSE_7 ; NO, NOT END OF TABLE
LDA INPUT_BUFFER,X ; YES, SO NOT A KEYWORD
BPL L_PARSE_8 ; ...ALWAYS, COPY CHAR AS IS
; ---END OF LINE------------------
L_PARSE_17 STA INPUT_BUFFER-3,Y ; STORE ANOTHER 00 ON END
DEC TXTPTR+1 ; SET TXTPTR = INPUT.BUFFER-1
LDA #<(INPUT_BUFFER-1)
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 L_FL1_3 ; END OF PROGRAM, AND NOT FOUND
INY ;
INY ;
LDA LINNUM+1 ;
CMP (LOWTR),Y ;
BCC RTS_1 ; IF NOT FOUND
BEQ L_FL1_1 ;
DEY ;
BNE L_FL1_2 ;
L_FL1_1 LDA LINNUM ;
DEY ;
CMP (LOWTR),Y ;
BCC RTS_1 ; PAST LINE, NOT FOUND
BEQ RTS_1 ; IF FOUND
L_FL1_2 DEY ;
LDA (LOWTR),Y ;
TAX ;
DEY ;
LDA (LOWTR),Y ;
BCS FL1 ; ALWAYS
L_FL1_3 CLC ; RETURN CARRY = 0
RTS_1 RTS
; --------------------------------
; "NEW" STATEMENT
; --------------------------------
NEW BNE RTS_1 ; 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 ".HS 2C")
; --------------------------------
; "CLEAR" STATEMENT
; --------------------------------
CLEAR BNE RTS_2 ; 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
RTS_2 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 L_LIST_1 ; NO LINE # SPECIFIED
BEQ L_LIST_1 ; ---DITTO---
CMP #TOKEN_MINUS ; IF DASH OR COMMA, START AT LINE 0
BEQ L_LIST_1 ; IS IS A DASH
CMP #LOCHAR(`,') ; COMMA?
BNE RTS_2 ; NO, ERROR
L_LIST_1 JSR LINGET ; CONVERT LINE NUMBER IF ANY
JSR FNDLIN ; POINT LOWTR TO 1ST LINE
JSR CHRGOT ; RANGE SPECIFIED?
BEQ L_LIST_3 ; NO
CMP #TOKEN_MINUS
BEQ L_LIST_2
CMP #LOCHAR(`,')
BNE RTS_1
L_LIST_2 JSR CHRGET ; GET NEXT CHAR
JSR LINGET ; CONVERT SECOND LINE #
BNE RTS_2 ; BRANCH IF SYNTAX ERR
L_LIST_3 PLA ; POP RETURN ADRESS
PLA ; (GET BACK BY "JMP NEWSTT")
LDA LINNUM ; IF NO SECOND NUMBER, USE $FFFF
ORA LINNUM+1 ;
BNE LIST_0 ; THERE WAS A SECOND NUMBER
LDA #$FF ; MAX END RANGE
STA LINNUM ;
STA LINNUM+1 ;
LIST_0 LDY #1 ;
LDA (LOWTR),Y ; HIGH BYTE OF LINK
BEQ LIST_3 ; 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 L_LIST_0_5 ;
CPX LINNUM ;
BEQ L_LIST_0_6 ; ON LAST LINE OF RANGE
L_LIST_0_5 BCS LIST_3 ; FINISHED THE RANGE
; ---LIST ONE LINE----------------
L_LIST_0_6 STY FORPNT ;
JSR LINPRT ; PRINT LINE # FROM X,A
LDA #LOCHAR(` ') ; PRINT SPACE AFTER LINE #
LIST_1 LDY FORPNT ;
AND #$7F ;
LIST_2 JSR OUTDO ;
LDA MON_CH ; IF PAST COLUMN 33, START A NEW LINE
CMP #33 ;
BCC L_LIST_2_1 ; < 33
JSR CRDO ; PRINT <RETURN>
LDA #5 ; AND TAB OVER 5
STA MON_CH ;
L_LIST_2_1 INY ;
LDA (LOWTR),Y ;
BNE LIST_4 ; 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 LIST_0 ; BRANCH IF NOT END OF PROGRAM
LIST_3 LDA #$0D ; PRINT <RETURN>
JSR OUTDO ;
JMP NEWSTT ; TO NEXT STATEMENT
; --------------------------------
GETCHR INY ; PICK UP CHAR FROM TABLE
BNE L_GETCHR_1 ;
INC FAC+1 ;
L_GETCHR_1 LDA (FAC),Y ;
RTS ;
; --------------------------------
LIST_4 BPL LIST_2 ; 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
L_LIST_4_1 DEX ; SKIP KEYWORDS UNTIL REACH THIS ONE
BEQ L_LIST_4_3 ;
L_LIST_4_2 JSR GETCHR ; BUMP Y, GET CHAR FROM TABLE
BPL L_LIST_4_2 ; NOT AT END OF KEYWORD YET
BMI L_LIST_4_1 ; END OF KEYWORD, ALWAYS BRANCHES
L_LIST_4_3 LDA #LOCHAR(` ') ; FOUND THE RIGHT KEYWORD
JSR OUTDO ; PRINT LEADING SPACE
L_LIST_4_4 JSR GETCHR ; PRINT THE KEYWORD
BMI L_LIST_4_5 ; LAST CHAR OF KEYWORD
JSR OUTDO ;
BNE L_LIST_4_4 ; ...ALWAYS
L_LIST_4_5 JSR OUTDO ; PRINT LAST CHAR OF KEYWORD
LDA #LOCHAR(` ') ; PRINT TRAILING SPACE
BNE LIST_1 ; ...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 L_FOR_1 ; NO
TXA ; YES, CANCEL IT AND ENCLOSED LOOPS
ADC #15 ; CARRY=1, THIS ADDS 16
TAX ; X WAS ALREADY S+2
TXS ;
L_FOR_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 FAC_SIGN ; 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_STACK_3 ; 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 L_STEP_1 ; USE DEFAULT VALUE OF 1.0
JSR CHRGET ; STEP SPECIFIED, GET IT
JSR FRMNUM
L_STEP_1 JSR SIGN
JSR FRM_STACK_2
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 L_NEWSTT_1 ; IN DIRECT MODE
STA OLDTEXT ; IN RUNNING MODE
STY OLDTEXT+1 ;
L_NEWSTT_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 L_NEWSTT_2
INC TXTPTR+1
L_NEWSTT_2
; --------------------------------
TRACE_ BIT TRCFLG ; IS TRACE ON?
BPL L_TRACE__1 ; NO
LDX CURLIN+1 ; YES, ARE WE RUNNING?
INX ;
BEQ L_TRACE__1 ; NOT RUNNING, SO DON'T TRACE
LDA #LOCHAR(`#') ; PRINT "#"
JSR OUTDO ;
LDX CURLIN ;
LDA CURLIN+1 ;
JSR LINPRT ; PRINT LINE NUMBER
JSR OUTSP ; PRINT TRAILING SPACE
L_TRACE__1 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 RTS_3 ; END OF LINE, NULL STATEMENT
EXECUTE_STATEMENT_1 ;
SBC #$80 ; FIRST CHAR A TOKEN?
BCC L_EXECUTE_STATEMENT_1_1 ; NOT TOKEN, MUST BE "LET"
CMP #$40 ; STATEMENT-TYPE TOKEN?
BCS SYNERR_1 ; NO, SYNTAX ERROR
ASL ; 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
; --------------------------------
L_EXECUTE_STATEMENT_1_1 JMP LET ; MUST BE <VAR> = <EXP>
; --------------------------------
COLON_ CMP #LOCHAR(`:')
BEQ TRACE_
SYNERR_1 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
RTS_3 RTS
; --------------------------------
; SEE IF CONTROL-C TYPED
; --------------------------------
ISCNTC LDA KEYBOARD
CMP #$83
BEQ L_ISCNTC_1
RTS
L_ISCNTC_1 JSR INCHR ; <<< SHOULD BE "BIT $C010" >>>
CONTROL_C_TYPED
LDX #$FF ; CONTROL C ATTEMPTED
BIT ERRFLG ; "ON ERR" ENABLED?
BPL L_CONTROL_C_TYPED_2 ; NO
JMP HANDLERR ; YES, RETURN ERR CODE = 255
L_CONTROL_C_TYPED_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
; --------------------------------
ENDX CLC ; CARRY=0 TO AVOID PRINTING MESSAGE
END2 BNE RTS_4 ; IF NOT END OF STATEMENT, DO NOTHING
LDA TXTPTR
LDY TXTPTR+1
LDX CURLIN+1
INX ; RUNNING?
BEQ L_END2_1 ; NO, DIRECT MODE
STA OLDTEXT
STY OLDTEXT+1
LDA CURLIN
LDY CURLIN+1
STA OLDLIN
STY OLDLIN+1
L_END2_1 PLA
PLA
END4 LDA #<QT_BREAK ; " BREAK" AND BELL
LDY #>QT_BREAK
BCC L_END4_1
JMP PRINT_ERROR_LINNUM
L_END4_1 JMP RESTART
; --------------------------------
; "CONT" COMMAND
; --------------------------------
CONT BNE RTS_4 ; IF NOT END OF STATEMENT, DO NOTHING
LDX #ERR_CANTCONT
LDY OLDTEXT+1 ; MEANINGFUL RE-ENTRY?
BNE L_CONT_1 ; YES
JMP ERROR ; NO
L_CONT_1 LDA OLDTEXT ; RESTORE TXTPTR
STA TXTPTR ;
STY TXTPTR+1 ;
LDA OLDLIN ; RESTORE LINE NUMBER
LDY OLDLIN+1
STA CURLIN
STY CURLIN+1
RTS_4 RTS
; --------------------------------
; "SAVE" COMMAND
; WRITES PROGRAM ON CASSETTE TAPE
; --------------------------------
SAVE SEC
LDA PRGEND ; COMPUTE PROGRAM LENGTH
SBC TXTTAB
STA LINNUM
LDA PRGEND+1
SBC TXTTAB+1
STA LINNUM+1
JSR VARTIO ; SET UP TO WRITE 3 BYTE HEADER
JSR MON_WRITE ; WRITE 'EM
JSR PROGIO ; SET UP TO WRITE THE PROGRAM
JMP MON_WRITE ; WRITE IT
; --------------------------------
; "LOAD" COMMAND
; READS A PROGRAM FROM CASSETTE TAPE
; --------------------------------
LOAD JSR VARTIO ; SET UP TO READ 3 BYTE HEADER
JSR MON_READ ; READ LENGTH, LOCK BYTE
CLC ;
LDA TXTTAB ; COMPUTE END ADDRESS
ADC LINNUM ;
STA VARTAB ;
LDA TXTTAB+1 ;
ADC LINNUM+1 ;
STA VARTAB+1 ;
LDA TEMPPT ; LOCK BYTE
STA LOCK ;
JSR PROGIO ; SET UP TO READ PROGRAM
JSR MON_READ ; READ IT
BIT LOCK ; IF LOCKED, START RUNNING NOW
BPL L_LOAD_1 ; NOT LOCKED
JMP SETPTRS ; LOCKED, START RUNNING
L_LOAD_1 JMP FIX_LINKS ; JUST FIX FORWARD POINTERS
; --------------------------------
VARTIO LDA #LINNUM ; SET UP TO READ/WRITE 3 BYTE HEADER
LDY #0
STA MON_A1L
STY MON_A1H
LDA #TEMPPT
STA MON_A2L
STY MON_A2H
STY LOCK
RTS
; --------------------------------
PROGIO LDA TXTTAB ; SET UP TO READ/WRITE PROGRAM
LDY TXTTAB+1
STA MON_A1L
STY MON_A1H
LDA VARTAB
LDY VARTAB+1
STA MON_A2L
STY MON_A2H
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 L_RUN_1 ; PROBABLY A LINE NUMBER
JMP SETPTRS ; START AT BEGINNING OF PROGRAM
L_RUN_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 ($B0)
; --------------------------------
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 L_GOTO_1 ; SEARCH FROM PROG START IF NOT
TYA ; OTHERWISE SEARCH FROM NEXT LINE
SEC ;
ADC TXTPTR ;
LDX TXTPTR+1 ;
BCC L_GOTO_2 ;
INX ;
BCS L_GOTO_2 ;
L_GOTO_1 LDA TXTTAB ; GET PROGRAM BEGINNING
LDX TXTTAB+1 ;
L_GOTO_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 ;
RTS_5 RTS ; RETURN TO NEWSTT OR GOSUB
; --------------------------------
; "POP" AND "RETURN" STATEMENTS
; --------------------------------
POP BNE RTS_5
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
ASM_DATA($2C) ; FAKE
UNDERR LDX #ERR_UNDEFSTAT
JMP ERROR
; --------------------------------
SYNERR_2 JMP SYNERR
; --------------------------------
RETURN PLA ; DISCARD GOSUB TOKEN
PLA
CPY #<(TOKEN_POP*2)
BEQ PULL3 ; BRANCH IF A POP
STA CURLIN ; PULL LINE #
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 L_ADDON_1
INC TXTPTR+1
L_ADDON_1
RTS_6 RTS
; --------------------------------
; SCAN AHEAD TO NEXT ":" OR EOL
; --------------------------------
DATAN LDX #LOCHAR(`:') ; GET OFFSET IN Y TO EOL OR ":"
ASM_DATA($2C) ; FAKE
; --------------------------------
REMN LDX #0 ; TO EOL ONLY
STX CHARAC
LDY #0
STY ENDCHR
L_REMN_1 LDA ENDCHR ; TRICK TO COUNT QUOTE PARITY
LDX CHARAC
STA CHARAC
STX ENDCHR
L_REMN_2 LDA (TXTPTR),Y
BEQ RTS_6 ; END OF LINE
CMP ENDCHR
BEQ RTS_6 ; COLON IF LOOKING FOR COLONS
INY
CMP #$22
BNE L_REMN_2
BEQ L_REMN_1 ; ...ALWAYS
; --------------------------------
PULL3 PLA
PLA
PLA
RTS
; --------------------------------
; "IF" STATEMENT
; --------------------------------
IF JSR FRMEVL
JSR CHRGOT
CMP #TOKEN_GOTO
BEQ L_IF_1
LDA #TOKEN_THEN
JSR SYNCHR
L_IF_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 L_IF_TRUE_1 ; COMMAND
JMP GOTO ; NUMBER
L_IF_TRUE_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 ON_2
ON_1 CMP #TOKEN_GOTO
BNE SYNERR_2
ON_2 DEC FAC+4 ; COUNTED TO RIGHT ONE YET?
BNE L_ON_2_3 ; NO, KEEP LOOKING
PLA ; YES, RETRIEVE CMD
JMP EXECUTE_STATEMENT_1 ; AND GO.
L_ON_2_3 JSR CHRGET ; PRIME CONVERT SUBROUTINE
JSR LINGET ; CONVERT LINE #
CMP #LOCHAR(`,') ; TERMINATE WITH COMMA?
BEQ ON_2 ; YES
PLA ; NO, END OF LIST, SO IGNORE
RTS_7 RTS
; --------------------------------
; CONVERT LINE NUMBER
; --------------------------------
LINGET LDX #0 ; ASC # TO HEX ADDRESS
STX LINNUM ; IN LINNUM.
STX LINNUM+1 ;
L_LINGET_1 BCS RTS_7 ; NOT A DIGIT
SBC #LOCHAR(`0')-1 ; CONVERT DIGIT TO BINARY
STA CHARAC ; SAVE THE DIGIT
LDA LINNUM+1 ; CHECK RANGE
STA INDEX ;
CMP #>6400 ; LINE # TOO LARGE?
BCS ON_1 ; YES, > 63999, GO INDIRECTLY TO
; "SYNTAX ERROR".
; <<<<<DANGEROUS CODE>>>>>
; NOTE THAT IF (A) = $AB ON THE LINE ABOVE,
; ON_1 WILL COMPARE = AND CAUSE A CATASTROPHIC
; JUMP TO $22D9 (FOR GOTO), OR OTHER LOCATIONS
; FOR OTHER CALLS TO LINGET.
;
; YOU CAN SEE THIS IS YOU FIRST PUT "BRK" IN $22D9,
; THEN TYPE "GO TO 437761".
;
; ANY VALUE FROM 437760 THROUGH 440319 WILL CAUSE
; THE PROBLEM. ($AB00 - $ABFF)
; <<<<<DANGEROUS CODE>>>>>
LDA LINNUM ; MULTIPLY BY TEN
ASL
ROL INDEX
ASL
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 L_LINGET_2
INC LINNUM+1
L_LINGET_2 JSR CHRGET ; GET NEXT CHAR
JMP L_LINGET_1 ; MORE CONVERTING
; --------------------------------
; "LET" STATEMENT
;
; LET <VAR> = <EXP>
; <VAR> = <EXP>
; --------------------------------
LET JSR PTRGET ; GET <VAR>
STA FORPNT
STY FORPNT+1
LDA #TOKENEQUUAL
JSR SYNCHR
LDA VALTYP+1 ; SAVE VARIABLE TYPE
PHA
LDA VALTYP
PHA
JSR FRMEVL ; EVALUATE <EXP>
PLA
ROL
JSR CHKVAL
BNE LET_STRING
PLA
; --------------------------------
LET2 BPL L_LET2_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
; --------------------------------
L_LET2_1 JMP SETFOR
; --------------------------------
LET_STRING
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 L_PUTSTR_2 ; YES, DATA ALREADY UP THERE
BNE L_PUTSTR_1 ; NO
DEY ; MAYBE, TEST LOW BYTE OF POINTER
LDA (FAC+3),Y ;
CMP FRETOP ;
BCC L_PUTSTR_2 ; YES, ALREADY THERE
L_PUTSTR_1 LDY FAC+4 ; NO. DESCRIPTOR ALREADY AMONG VARIABLES?
CPY VARTAB+1 ;
BCC L_PUTSTR_2 ; NO
BNE L_PUTSTR_3 ; YES
LDA FAC+3 ; MAYBE, COMPARE LO-BYTE
CMP VARTAB ;
BCS L_PUTSTR_3 ; YES, DESCRIPTOR IS AMONG VARIABLES
L_PUTSTR_2 LDA FAC+3 ; EITHER STRING ALREADY ON TOP, OR
LDY FAC+4 ; DESCRIPTOR IS NOT A VARIABLE
JMP L_PUTSTR_4 ; SO JUST STORE THE DESCRIPTOR
; --------------------------------
; STRING NOT YET IN STRING AREA,
; AND DESCRIPTOR IS A VARIABLE
; --------------------------------
L_PUTSTR_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 ;
L_PUTSTR_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
RTS
; --------------------------------
PR_STRING
JSR STRPRT
JSR CHRGOT
; --------------------------------
; "PRINT" STATEMENT
; --------------------------------
PRINT BEQ CRDO ; NO MORE LIST, PRINT <RETURN>
; --------------------------------
PRINT2 BEQ RTS_8 ; NO MORE LIST, DON'T PRINT <RETURN>
CMP #TOKEN_TAB
BEQ PR_TAB_OR_SPC ; C=1 FOR TAB(
CMP #TOKEN_SPC
CLC
BEQ PR_TAB_OR_SPC ; C=0 FOR SPC(
CMP #LOCHAR(`,')
CLC ; <<< NO PURPOSE TO THIS >>>
BEQ PR_COMMA ;
CMP #LOCHAR(`;')
BEQ PR_NEXT_CHAR ;
JSR FRMEVL ; EVALUATE EXPRESSION
BIT VALTYP ; STRING OR FP VALUE?
BMI PR_STRING ; STRING
JSR FOUT ; FP: CONVERT INTO BUFFER
JSR STRLIT ; MAKE BUFFER INTO STRING
JMP PR_STRING ; PRINT THE STRING
; --------------------------------
CRDO LDA #$0D ; PRINT <RETURN>
JSR OUTDO
NEGATE EOR #$FF ; <<< WHY??? >>>
RTS_8 RTS
; --------------------------------
; TAB TO NEXT COMMA COLUMN
; <<< NOTE BUG IF WIDTH OF WINDOW LESS THAN 33 >>>
PR_COMMA
LDA MON_CH
CMP #24 ; <<< BUG: IT SHOULD BE 32 >>>
BCC L_PR_COMMA_1 ; NEXT COLUMN, SAME LINE
JSR CRDO ; FIRST COLUMN, NEXT LINT
BNE PR_NEXT_CHAR ; ...ALWAYS
L_PR_COMMA_1 ADC #16
AND #$F0 ; ROUND TO 16 OR 32
STA MON_CH
BCC PR_NEXT_CHAR ; ...ALWAYS
; --------------------------------
PR_TAB_OR_SPC
PHP ; C=0 FOR SPC(, C=1 FOR TAB(
JSR GTBYTC ; GET VALUE
CMP #LOCHAR(`)') ; TRAILING PARENTHESIS
BEQ L_PR_TAB_OR_SPC_1 ; GOOD
JMP SYNERR ; NO, SYNTAX ERROR
L_PR_TAB_OR_SPC_1 PLP ; TAB( OR SPC(
BCC L_PR_TAB_OR_SPC_2 ; SPC(
DEX ; TAB(
TXA ; CALCULATE SPACES NEEDED FOR TAB(
SBC MON_CH
BCC PR_NEXT_CHAR ; ALREADY PAST THAT COLUMN
TAX ; NOW DO A SPC( TO THE SPECIFIED COLUMN
L_PR_TAB_OR_SPC_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 ;
L_STRPRT_1 DEX ;
BEQ RTS_8 ; FINISHED
LDA (INDEX),Y ; NEXT CHAR FROM STRING
JSR OUTDO ; PRINT THE CHAR
INY ;
; <<< NEXT THREE LINES ARE USELESS >>>
CMP #$0D ; WAS IT <RETURN>?
BNE L_STRPRT_1 ; NO
JSR NEGATE ; EOR #$FF WOULD DO IT, BUT WHY?
; <<< ABOVE THREE LINES ARE USELESS >>>
JMP L_STRPRT_1
; --------------------------------
OUTSP LDA #LOCHAR(` ') ; PRINT A SPACE
ASM_DATA($2C) ; SKIP OVER NEXT LINE
OUTQUES LDA #LOCHAR(`?') ; PRINT QUESTION MARK
; --------------------------------
; PRINT CHAR FROM (A)
;
; NOTE: POKE 243,32 ($20 IN $F3) WILL CONVERT
; OUTPUT TO LOWER CASE. THIS CAN BE CANCELLED
; BY NORMAL, INVERSE, OR FLASH OR POKE 243,0.
; --------------------------------
OUTDO ORA #$80 ; PRINT (A)
CMP #$A0 ; CONTROL CHR?
BCC L_OUTDO_1 ; SKIP IF SO
ORA FLASH_BIT ; =$40 FOR FLASH, ELSE $00
L_OUTDO_1 JSR MON_COUT ; "AND"S WITH $3F (INVERSE), $7F (FLASH)
AND #$7F ;
PHA ;
LDA SPEEDZ ; COMPLEMENT OF SPEED #
JSR MON_WAIT ; SO SPEED=255 BECOMES (A)=1
PLA
RTS
; --------------------------------
; 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 L_RESPERR_1 ; NO, GIVE REENTRY A TRY
LDX #254 ; ERROR CODE = 254
JMP HANDLERR
L_RESPERR_1 LDA #<ERR_REENTRY ; "?REENTER"
LDY #>ERR_REENTRY
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 #<(INPUT_BUFFER+1) ; SIMULATE INPUT
LDY #>(INPUT_BUFFER+1)
LDA #0
STA INPUT_BUFFER+1
LDA #$40 ; SET UP INPUTFLG
JSR PROCESS_INPUT_LIST ; <<< CAN SAVE 1 BYTE HERE>>>
RTS ; <<<BY "JMP PROCESS.INPUT.LIST">>>
; --------------------------------
; "INPUT" STATEMENT
; --------------------------------
INPUT CMP #$22 ; CHECK FOR OPTIONAL PROMPT STRING
BNE L_INPUT_1 ; NO, PRINT "?" PROMPT
JSR STRTXT ; MAKE A PRINTABLE STRING OUT OF IT
LDA #LOCHAR(`;') ; MUST HAVE ; NOW
JSR SYNCHR ;
JSR STRPRT ; PRINT THE STRING
JMP L_INPUT_2 ;
L_INPUT_1 JSR OUTQUES ; NO STRING, PRINT "?"
L_INPUT_2 JSR ERRDIR ; ILLEGAL IF IN DIRECT MODE
LDA #LOCHAR(`,') ; PRIME THE BUFFER
STA INPUT_BUFFER-1
JSR INLIN
LDA INPUT_BUFFER
CMP #$03 ; CONTROL C?
BNE INPUT_FLAG_ZERO ; 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
ASM_DATA($2C) ; TRICK TO PROCESS.INPUT.LIST
; --------------------------------
INPUT_FLAG_ZERO 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 L_PROCESS_INPUT_ITEM_1 ; NO
JSR MON_RDKEY ; YES, GET CHAR
AND #$7F
STA INPUT_BUFFER
LDX #<(INPUT_BUFFER-1)
LDY #>(INPUT_BUFFER-1)
BNE L_PROCESS_INPUT_ITEM_2 ; ...ALWAYS
; --------------------------------
L_PROCESS_INPUT_ITEM_1 BMI FINDATA ; DOING A "READ"
JSR OUTQUES ; DOING AN "INPUT", PRINT "?"
JSR NXIN ; PRINT ANOTHER "?", AND INPUT A LINE
L_PROCESS_INPUT_ITEM_2 STX TXTPTR
STY TXTPTR+1
; --------------------------------
INSTART
JSR CHRGET ; GET NEXT INPUT CHAR
BIT VALTYP ; STRING OR NUMERIC?
BPL L_INSTART_5 ; NUMERIC
BIT INPUTFLG ; STRING -- NOW WHAT INPUT TYPE?
BVC L_INSTART_1 ; NOT A "GET"
INX ; "GET"
STX TXTPTR
LDA #0
STA CHARAC ; NO OTHER TERMINATORS THAN $00
BEQ L_INSTART_2 ; ...ALWAYS
; --------------------------------
L_INSTART_1 STA CHARAC
CMP #$22 ; TERMINATE ON $00 OR QUOTE
BEQ L_INSTART_3
LDA #LOCHAR(`:') ; TERMINATE ON $00, COLON, OR COMMA
STA CHARAC
LDA #LOCHAR(`,')
L_INSTART_2 CLC
L_INSTART_3 STA ENDCHR
LDA TXTPTR
LDY TXTPTR+1
ADC #0 ; SKIP OVER QUOTATION MARK, IF
BCC L_INSTART_4 ; THERE WAS ONE
INY
L_INSTART_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
; --------------------------------
L_INSTART_5 PHA
LDA INPUT_BUFFER ; ANYTHING IN BUFFER?
BEQ INPFIN ; NO, SEE IF READ OR INPUT
; --------------------------------
INPUTDWTA
PLA ; "READ"
JSR FIN ; GET FP NUMBER AT TXTPTR
LDA VALTYP+1 ;
JSR LET2 ; STORE RESULT IN VARIABLE
; --------------------------------
INPUT_MORE
JSR CHRGOT
BEQ L_INPUT_MORE_1 ; END OF LINE OR COLON
CMP #LOCHAR(`,') ; COMMA IN INPUT?
BEQ L_INPUT_MORE_1 ; YES
JMP INPUTERR ; NOTHING ELSE WILL DO
L_INPUT_MORE_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 INPUTDWTA ; "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 L_FINDATA_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
L_FINDATA_1 LDA (TXTPTR),Y ; GET 1ST TOKEN OF STATEMENT
TAX ; SAVE TOKEN IN X-REG
JSR ADDON ; ADD (Y) TO TXTPTR
CPX #TOKENDWTA ; 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 L_INPDONE_1 ; "INPUT"
JMP SETDA ; "DATA", SO STORE (Y,X) AT DATPTR
L_INPDONE_1 LDY #0 ; "INPUT": ANY MORE CHARS ON LINE?
LDA (INPTR),Y
BEQ L_INPDONE_2 ; NO, ALL IS WELL
LDA #<ERR_EXTRA ; YES, ERROR
LDY #>ERR_EXTRA ; "EXTRA IGNORED"
JMP STROUT
L_INPDONE_2 RTS
; --------------------------------
ERR_EXTRA LOASCII(`?EXTRA IGNORED')
ASM_DATA($0D,0)
ERR_REENTRY LOASCII(`?REENTER')
ASM_DATA($0D,0)
; --------------------------------
; --------------------------------
; "NEXT" STATEMENT
; --------------------------------
NEXT BNE NEXT_1 ; VARIABLE AFTER "NEXT"
LDY #0 ; FLAG BY SETTING FORPNT+1 = 0
BEQ NEXT_2 ; ...ALWAYS
; --------------------------------
NEXT_1 JSR PTRGET ; GET PNTR TO VARIABLE IN (Y,A)
NEXT_2 STA FORPNT
STY FORPNT+1
JSR GTFORPNT ; FIND FOR-FRAME FOR THIS VARIABLE
BEQ NEXT_3 ; FOUND IT
LDX #ERR_NOFOR ; NOT THERE, ABORT
GERR BEQ JERROR ; ...ALWAYS
NEXT_3 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 FAC_SIGN
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 L_NEXT_3_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
L_NEXT_3_1 JMP NEWSTT
L_NEXT_3_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 #LOCHAR(`,') ; ANOTHER VARIABLE IN NEXT_
BNE L_NEXT_3_1 ; NO, GO TO NEXT STATEMENT
JSR CHRGET ; YES, PRIME FOR NEXT VARIABLE
JSR NEXT_1 ; (DOES NOT RETURN)
; --------------------------------
; EVALUATE EXPRESSION, MAKE SURE IT IS NUMERIC
; --------------------------------
FRMNUM JSR FRMEVL
; --------------------------------
; MAKE SURE (FAC) IS NUMERIC
; --------------------------------
CHKNUM CLC
ASM_DATA($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 L_CHKVAL_2 ; TYPE IS STRING
BCS L_CHKVAL_3 ; NOT STRING, BUT WE NEED STRING
L_CHKVAL_1 RTS ; TYPE IS CORRECT
L_CHKVAL_2 BCS L_CHKVAL_1 ; IS STRING AND WE WANTED STRING
L_CHKVAL_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 L_FRMEVL_1
DEC TXTPTR+1
L_FRMEVL_1 DEC TXTPTR
LDX #0 ; START WITH PRECEDENCE = 0
ASM_DATA($24) ; TRICK TO SKIP FOLLOWING "PHA"
; --------------------------------
FRMEVL_1
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
; --------------------------------
FRMEVL_2
JSR CHRGOT ; CHECK FOR RELATIONAL OPERATORS
L_FRMEVL_2_1 SEC ; > IS $CF, = IS $D0, < IS $D1
SBC #TOKEN_GREATER ; > IS 0, = IS 1, < IS 2
BCC L_FRMEVL_2_2 ; NOT RELATIONAL OPERATOR
CMP #3 ;
BCS L_FRMEVL_2_2 ; NOT RELATIONAL OPERATOR
CMP #1 ; SET CARRY IF "=" OR "<"
ROL ; 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 L_FRMEVL_2_1 ; CHECK FOR <,=,> AGAIN
; --------------------------------
L_FRMEVL_2_2 LDX CPRTYP ; DID WE FIND A RELATIONAL OPERATOR?
BNE FRM_RELATIONAL ; YES
BCS NOTMATH ; NO, AND NEXT TOKEN IS > $D1
ADC #$CF-TOKEN_PLUS ; NO, AND NEXT TOKEN < $CF
BCC NOTMATH ; IF NEXT TOKEN < "+"
ADC VALTYP ; + AND LAST RESULT A STRING?
BNE L_FRMEVL_2_3 ; BRANCH IF NOT
JMP CAT ; CONCATENATE IF SO.
; --------------------------------
L_FRMEVL_2_3 ADC #$FF ; +-*/ IS 0123
STA INDEX
ASL ; MULTIPLY BY 3
ADC INDEX ; +-*/ IS 0,3,6,9
TAY
; --------------------------------
FRM_PRECEDENCE_TEST
PLA ; GET LAST PRECEDENCE
CMP MATHTBL,Y
BCS FRM_PERFORM_1 ; 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_PERFORM_2 ; ...ALWAYS
; --------------------------------
; FOUND ONE OR MORE RELATIONAL OPERATORS <,=,>
; --------------------------------
FRM_RELATIONAL
LSR VALTYP ; (VALTYP) = 0 (NUMERIC), = $FF (STRING)
TXA ; SET CPRTYP TO 0000<=>C
ROL ; WHERE C=0 IF #, C=1 IF STRING
LDX TXTPTR ; BACK UP TXTPTR
BNE L_FRM_RELATIONAL_1
DEC TXTPTR+1
L_FRM_RELATIONAL_1 DEC TXTPTR
LDY #M_REL-MATHTBL ; POINT AT RELOPS ENTRY
STA CPRTYP
BNE FRM_PRECEDENCE_TEST ; ...ALWAYS
; --------------------------------
PREFNC CMP MATHTBL,Y
BCS FRM_PERFORM_2 ; 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_STACK_1 ; STACK FAC.SIGN AND FAC
LDA CPRTYP ; A=RELOP FLAGS, X=PRECEDENCE BYTE
JMP FRMEVL_1 ; RECURSIVELY CALL FRMEVL
; --------------------------------
SNTXERR JMP SYNERR
; --------------------------------
; STACK (FAC)
;
; THREE ENTRY POINTS:
; L_SNTXERR_1, FROM FRMEVL
; L_SNTXERR_2, FROM "STEP"
; L_SNTXERR_3, FROM "FOR"
; --------------------------------
FRM_STACK_1
LDA FAC_SIGN ; GET FAC.SIGN TO PUSH IT
; Note: XA65 assembler (Andre Fachat) requires ! here when asm with "xa -R -bt 0" for some reason:
LDX !MATHTBL,Y ; PRECEDENCE BYTE FROM MATHTBL
; --------------------------------
; ENTER HERE FROM "STEP", TO PUSH STEP SIGN AND VALUE
; --------------------------------
FRM_STACK_2
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_STACK_3
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_PERFORM_1
CMP #P_REL ; WAS IT RELATIONAL OPERATOR?
BEQ L_FRM_PERFORM_1_1 ; YES, ALLOW STRING COMPARE
JSR CHKNUM ; MUST BE NUMERIC VALUE
L_FRM_PERFORM_1_1 STY LASTOP ;
; --------------------------------
FRM_PERFORM_2 ;
PLA ; GET 0000<=>C FROM STACK
LSR ; 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 FAC_SIGN ; SAVE EOR OF SIGNS OF THE OPERANDS,
STA SGNCPR ; IN CASE OF MULTIPLY OR DIVIDE
EXIT LDA FAC ; FAC EXPONENT IN A-REG
RTS ; STATUS EQU. IF (FAC)=0
; 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 ;
L_FRM_ELEMENT_1 JSR CHRGET ;
BCS L_FRM_ELEMENT_3 ; NOT A DIGIT
L_FRM_ELEMENT_2 JMP FIN ; NUMERIC CONSTANT
L_FRM_ELEMENT_3 JSR ISLETC ; VARIABLE NAME?
BCS FRM_VARIABLE ; YES
CMP #LOCHAR(`.') ; DECIMAL POINT
BEQ L_FRM_ELEMENT_2 ; YES, NUMERIC CONSTANT
CMP #TOKEN_MINUS ; UNARY MINUS?
BEQ MIN ; YES
CMP #TOKEN_PLUS ; UNARY PLUS
BEQ L_FRM_ELEMENT_1 ; YES
CMP #$22 ; 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 L_STRTXT_1 ;
INY ;
L_STRTXT_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 FN_ ; NOT "NOT", TRY "FN"
LDY #MEQUU-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 L_EQUOP_1 ; FALSE
LDY #1 ; TRUE
ASM_DATA($2C) ; TRICK TO SKIP NEXT 2 BYTES
L_EQUOP_1 LDY #0 ; FALSE
JMP SNGFLT ;
; --------------------------------
FN_ CMP #TOKEN_FN
BNE SGN_
JMP FUNCT
; --------------------------------
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 #$29 ; CHECK FOR ')'
ASM_DATA($2C) ; TRICK
; --------------------------------
CHKOPN LDA #$28 ;
ASM_DATA($2C) ; TRICK
; --------------------------------
CHKCOM LDA #LOCHAR(`,') ; 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 L_FRM_VARIABLE_CALL_1 ; NUMERIC
LDX #0 ; STRING
STX STRNG1+1 ;
RTS ;
L_FRM_VARIABLE_CALL_1 LDX VALTYP+1 ; NUMERIC, WHICH TYPE?
BPL L_FRM_VARIABLE_CALL_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
L_FRM_VARIABLE_CALL_2 JMP LOAD_FAC_FROM_YA
; --------------------------------
; --------------------------------
; "SCRN(" FUNCTION
; --------------------------------
SCREEN JSR CHRGET
JSR PLOTFNS ; GET COLUMN AND ROW
TXA ; ROW
LDY FIRST ; COLUMN
JSR MON_SCRN ; GET 4-BIT COLOR THERE
TAY ;
JSR SNGFLT ; CONVERT (Y) TO REAL IN FAC
JMP CHKCLS ; REQUIRE ")"
; --------------------------------
; PROCESS UNARY OPERATORS (FUNCTIONS)
; --------------------------------
UNARY CMP #TOKEN_SCRN ; NOT UNARY, DO SPECIAL
BEQ SCREEN
ASL ; DOUBLE TOKEN TO GET INDEX
PHA
TAX
JSR CHRGET
CPX #<(TOKEN_LEFTSTR*2-1) ; LEFT$, RIGHT$, AND MID$
BCC L_UNARY_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 L_UNARY_2 ; JOIN UNARY FUNCTIONS
L_UNARY_1 JSR PARCHK ; REQUIRE "(EXPRESSION)"
PLA
TAY ; INDEX INTO FUNCTION ADDRESS TABLE
L_UNARY_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 ;
; --------------------------------
ANDOP LDA ARG ; "AND" OPERATOR
BEQ FALSE ; IF EITHER IS ZERO, RESULT IS FALSE
LDA FAC ;
BNE TRUE ;
; --------------------------------
FALSE LDY #0 ; RETURN FAC=0
ASM_DATA($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 ARG_SIGN ; 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 L_STRCMP_1 ;
LDA #1 ;
BCC L_STRCMP_1 ;
LDX FAC ;
LDA #$FF ;
L_STRCMP_1 STA FAC_SIGN ; FLAG WHICH SHORTER
LDY #$FF ;
INX ;
STRCMP_1 ;
INY ;
DEX ;
BNE STRCMP_2 ; MORE CHARS IN BOTH STRINGS
LDX FAC_SIGN ; IF = SO FAR, DECIDE BY LENGTH
; --------------------------------
NUMCMP BMI CMPDONE ;
CLC ;
BCC CMPDONE ; ...ALWAYS
; --------------------------------
STRCMP_2 ;
LDA (ARG+3),Y ;
CMP (FAC+1),Y ;
BEQ STRCMP_1 ; 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 ; AND TO 0,2,4 IF C=0, ELSE 1,2,5
AND CPRMASK ; 00000<=>
BEQ L_CMPDONE_1 ; IF NO MATCH: FALSE
LDA #1 ; AT LEAST ONE MATCH: TRUE
L_CMPDONE_1 JMP FLOAT ;
; --------------------------------
; "PDL" FUNCTION
; <<< NOTE: ARG<4 IS NOT CHECKED >>>
; --------------------------------
PDL JSR CONINT ; GET # IN X
JSR MON_PREAD ; READ PADDLE
JMP SNGFLT ; FLOAT RESULT
; --------------------------------
; "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"
; = $80 IF CALLED FROM "DEF FN"
; = $C1-DA IF CALLED FROM "FN"
; --------------------------------
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 ;
JMP PTRGET4 ; TO BRANCH ACROSS $E000 VECTORS
; --------------------------------
; DOS AND MONITOR CALL BASIC AT $E000 AND $E003
; --------------------------------
BASIC JMP COLD_START
BASIC2 JMP RESTART
BRK ; <<< WASTED BYTE >>>
; --------------------------------
PTRGET4
JSR CHRGET ; SECOND CHAR OF VARIABLE NAME
BCC L_PTRGET4_1 ; NUMERIC
JSR ISLETC ; LETTER?
BCC L_PTRGET4_3 ; NO, END OF NAME
L_PTRGET4_1 TAX ; SAVE SECOND CHAR OF NAME IN X
L_PTRGET4_2 JSR CHRGET ; SCAN TO END OF VARIABLE NAME
BCC L_PTRGET4_2 ; NUMERIC
JSR ISLETC ;
BCS L_PTRGET4_2 ; ALPHA
L_PTRGET4_3 CMP #LOCHAR(`$') ; STRING?
BNE L_PTRGET4_4 ; NO
LDA #$FF ;
STA VALTYP ;
BNE L_PTRGET4_5 ; ...ALWAYS
L_PTRGET4_4 CMP #LOCHAR(`%') ; INTEGER?
BNE L_PTRGET4_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
L_PTRGET4_5 TXA ; SECOND CHAR OF NAME
ORA #$80 ; SET SIGN
TAX ;
JSR CHRGET ; GET TERMINATING CHAR
L_PTRGET4_6 STX VARNAM+1 ; STORE SECOND CHAR OF NAME
SEC ;
ORA SUBFLG ; $00 OR $40 IF SUBSCRIPTS OK, ELSE $80
SBC #$28 ; IF SUBFLG=$00 AND CHAR="("...
BNE L_PTRGET4_8 ; NOPE
L_PTRGET4_7 JMP ARRAY ; YES
L_PTRGET4_8 BIT SUBFLG ; CHECK TOP TWO BITS OF SUBFLG
BMI L_PTRGET4_9 ; $80
BVS L_PTRGET4_7 ; $40, CALLED FROM GETARYPT
L_PTRGET4_9 LDA #0 ; CLEAR SUBFLG
STA SUBFLG ;
LDA VARTAB ; START LOWTR AT SIMPLE VARIABLE TABLE
LDX VARTAB+1 ;
LDY #0 ;
L_PTRGET4_10 STX LOWTR+1 ;
L_PTRGET4_11 STA LOWTR ;
CPX ARYTAB+1 ; END OF SIMPLE VARIABLES?
BNE L_PTRGET4_12 ; NO, GO ON
CMP ARYTAB ; YES; END OF ARRAYS?
BEQ NAME_NOT_FOUND ; YES, MAKE ONE
L_PTRGET4_12 LDA VARNAM ; SAME FIRST LETTER?
CMP (LOWTR),Y ;
BNE L_PTRGET4_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
L_PTRGET4_13 CLC
LDA LOWTR
ADC #7
BCC L_PTRGET4_11
INX
BNE L_PTRGET4_10 ; ...ALWAYS
; --------------------------------
; CHECK IF (A) IS ASCII LETTER A-Z
;
; RETURN CARRY = 1 IF A-Z
; = 0 IF NOT
;
; <<<NOTE FASTER AND SHORTER CODE: >>>
; <<< CMP #LOCHAR(`Z')+1 COMPARE HI END
; <<< BCS L_PTRGET4_1 ABOVE A-Z
; <<< CMP #LOCHAR(`A') COMPARE LO END
; <<< RTS C=0 IF LO, C=1 IF A-Z
; <<<L_PTRGET4_1 CLC C=0 IF HI
; <<< RTS
; --------------------------------
ISLETC CMP #LOCHAR(`A') ; COMPARE LO END
BCC L_ISLETC_1 ; C=0 IF LOW
SBC #LOCHAR(`Z')+1 ; PREPARE HI END TEST
SEC ; TEST HI END, RESTORING (A)
SBC #255-'Z' ; C=0 IF LO, C=1 IF A-Z
L_ISLETC_1 RTS
; --------------------------------
; VARIABLE NOT FOUND, SO MAKE ONE
; --------------------------------
NAME_NOT_FOUND
PLA ; LOOK AT RETURN ADDRESS ON STACK TO
PHA ; SEE IF CALLED FROM FRM.VARIABLE
CMP #<FRM_VARIABLE_CALL
BNE MAKE_NEW_VARIABLE ; NO
TSX
LDA STACK+2,X
CMP #>FRM_VARIABLE_CALL
BNE MAKE_NEW_VARIABLE ; 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 ASM_DATA(00,00) ; 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
; --------------------------------
MAKE_NEW_VARIABLE
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 L_MAKE_NEW_VARIABLE_1 ;
INY ;
L_MAKE_NEW_VARIABLE_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 L_SET_VARPNT_AND_YA_1 ;
INY ;
L_SET_VARPNT_AND_YA_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
; --------------------------------
GETARY2 ;
ASL ; #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 L_GETARY2_1 ;
INY ;
L_GETARY2_1 STA ARYPNT ; ADDRESS OF FIRST VALUE IN ARRAY
STY ARYPNT+1 ;
RTS ;
; --------------------------------
NEG32768 ASM_DATA($90,$80,$00,$00) ; -32768.00049 IN FLOATING POINT
; <<< MEANT TO BE -32768, WHICH WOULD BE 9080000000 >>>
; <<< 1 BYTE SHORT, SO PICKS UP $20 FROM NEXT INSTRUCTION
; --------------------------------
; 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 FAC_SIGN ; 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; NEXT FEW LINES ARE SUPPOSED TO
LDY #>NEG32768 ; ALLOW -32768 ($8000), BUT DO NOT!
JSR FCOMP ; BECAUSE COMPARED TO -32768.00049
; <<< BUG: A=-32768.00049:A%=A IS ACCEPTED >>>
; <<< BUT PRINT A,A% SHOWS THAT >>>
; <<< A=-32768.0005 (OK), A%=32767 >>>
; <<< WRONG! WRONG! WRONG! >>>
; --------------------------------
MI1 BNE IQERR ; ILLEGAL QUANTITY
MI2 JMP QINT ; CONVERT TO INTEGER
; --------------------------------
; LOCATE ARRAY ELEMENT OR CREATE AN ARRAY
; --------------------------------
ARRAY LDA SUBFLG ; SUBSCRIPTS GIVEN?
BNE L_ARRAY_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
L_ARRAY_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 #LOCHAR(`,') ;
BEQ L_ARRAY_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
; --------------------------------
L_ARRAY_2 LDX ARYTAB ; (A,X) = START OF ARRAY TABLE
LDA ARYTAB+1 ;
L_ARRAY_3 STX LOWTR ; USE LOWTR FOR RUNNING POINTER
STA LOWTR+1 ;
CMP STREND+1 ; DID WE REACH THE END OF ARRAYS YET?
BNE L_ARRAY_4 ; NO, KEEP SEARCHING
CPX STREND ;
BEQ MAKE_NEW_ARRAY ; YES, THIS IS A NEW ARRAY NAME
L_ARRAY_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 L_ARRAY_5 ; NO, MOVE TO NEXT ARRAY
LDA VARNAM+1 ; YES, TRY 2ND CHAR
CMP (LOWTR),Y ; SAME?
BEQ USE_OLD_ARRAY ; YES, ARRAY FOUND
L_ARRAY_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 L_ARRAY_3 ; ...ALWAYS
; --------------------------------
; ERROR: BAD SUBSCRIPTS
; --------------------------------
SUBERR LDX #ERR_BADSUBS
ASM_DATA($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 L_USE_OLD_ARRAY_1 ; YES, NEED TO CHECK THE NUMBER
SEC ; NO, SIGNAL ARRAY FOUND
RTS
; --------------------------------
L_USE_OLD_ARRAY_1 JSR GETARY ; SET (ARYPNT) = ADDR OF FIRST ELEMENT
LDA NUMDIM ; 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 L_MAKE_NEW_ARRAY_1 ; NO
LDX #ERR_NODATA ; YES, GIVE "OUT OF DATA" ERROR
JMP ERROR
L_MAKE_NEW_ARRAY_1 JSR GETARY ; PUT ADDR OF 1ST ELEMENT IN ARYPNT
JSR REASON ; MAKE SURE ENOUGH MEMORY LEFT
; --------------------------------
; <<< NEXT 3 LINES COULD BE WRITTEN: >>>
; LDY #0
; STY STRNG2+1
; --------------------------------
LDA #0 ; POINT Y-REG AT VARIABLE NAME SLOT
TAY ;
STA STRNG2+1 ; START SIZE COMPUTATION
LDX #5 ; ASSUME 5-BYTES PER ELEMENT
LDA VARNAM ; STUFF VARIABLE NAME IN ARRAY
STA (LOWTR),Y ;
BPL L_MAKE_NEW_ARRAY_2 ; NOT INTEGER ARRAY
DEX ; INTEGER ARRAY, DECR. SIZE TO 4-BYTES
L_MAKE_NEW_ARRAY_2 INY ; POINT Y-REG AT NEXT CHAR OF NAME
LDA VARNAM+1 ; REST OF ARRAY NAME
STA (LOWTR),Y ;
BPL L_MAKE_NEW_ARRAY_3 ; REAL ARRAY, STICK WITH SIZE = 5 BYTES
DEX ; INTEGER OR STRING ARRAY, ADJUST SIZE
DEX ; TO INTEGER=3, STRING=2 BYTES
L_MAKE_NEW_ARRAY_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 ;
L_MAKE_NEW_ARRAY_4 LDX #11 ; DEFAULT DIMENSION = 11 ELEMENTS
LDA #0 ; FOR HI-BYTE OF DIMENSION IF DEFAULT
BIT DIMFLG ; DIMENSIONED ARRAY?
BVC L_MAKE_NEW_ARRAY_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 ;
L_MAKE_NEW_ARRAY_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 L_MAKE_NEW_ARRAY_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 L_MAKE_NEW_ARRAY_6 ;
INY ;
BEQ GME ; ...TOO LARGE, ERROR
L_MAKE_NEW_ARRAY_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 L_MAKE_NEW_ARRAY_8 ; FULL PAGE
L_MAKE_NEW_ARRAY_7 DEY ; CLEAR PAGE FULL
STA (ARYPNT),Y
BNE L_MAKE_NEW_ARRAY_7
L_MAKE_NEW_ARRAY_8 DEC ARYPNT+1 ; POINT TO NEXT PAGE
DEC STRNG2+1 ; COUNT THE PAGES
BNE L_MAKE_NEW_ARRAY_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 RTS_9 ; 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 ;
FAE_1 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 FAE_2 ; SUBSCRIPT NOT TOO LARGE
BNE GSE ; SUBSCRIPT IS TOO LARGE
INY ; CHECK LOW-BYTE OF SUBSCRIPT
TXA ;
CMP (LOWTR),Y ;
BCC FAE_3 ; NOT TOO LARGE
; --------------------------------
GSE JMP SUBERR ; BAD SUBSCRIPTS ERROR
GME JMP MEMERR ; MEM FULL ERROR
; --------------------------------
FAE_2 INY ; BUMP POINTER INTO DESCRIPTOR
FAE_3 LDA STRNG2+1 ; BYPASS MULTIPLICATION IF VALUE SO
ORA STRNG2 ; FAR = 0
CLC ;
BEQ L_FAE_3_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
L_FAE_3_1 ADC FAC+4 ; FINISH ADDING CURRENT SUBSCRIPT
STX STRNG2 ; STORE ACCUMULATED OFFSET
DEC NUMDIM ; LAST SUBSCRIPT YET?
BNE FAE_1 ; 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 L_FAE_3_2 ; NOT INTEGER
DEX ; INTEGER, BACK DOWN SIZE TO 4 BYTES
L_FAE_3_2 LDA VARNAM+1 ; DISCRIMINATE BETWEEN REAL AND STR
BPL L_FAE_3_3 ; IT IS REAL
DEX ; SIZE = 3 IF STRING, =2 IF INTEGER
DEX ;
L_FAE_3_3 STX RESULT+2 ; SET UP MULTIPLIER
LDA #0 ; HI-BYTE OF MULTIPLIER
JSR MULTIPLY_SUBS_1 ; (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
RTS_9 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_SUBS_1 ;
STA RESULT+3 ; LOW BYTE OF MULTIPLIER
LDA #16 ; MULTIPLY 16 BITS
STA INDX ;
LDX #0 ; PRODUCT = 0 INITIALLY
LDY #0 ;
L_MULTIPLY_SUBS_1_1 TXA ; DOUBLE PRODUCT
ASL ; LOW BYTE
TAX ;
TYA ; HIGH BYTE
ROL ; 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 L_MULTIPLY_SUBS_1_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"
L_MULTIPLY_SUBS_1_2 DEC INDX ; 16-BITS YET?
BNE L_MULTIPLY_SUBS_1_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 L_FRE_1 ; =0 MEANS REAL, =$FF MEANS STRING
JSR FREFAC ; STRING, SO SET IT FREE IS TEMP
L_FRE_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 FLOAT_1 ; CONVERT TO SIGNED FP
; --------------------------------
; "POS" FUNCTION
;
; RETURNS CURRENT LINE POSITION FROM MON.CH
; --------------------------------
POS LDY MON_CH ; GET A,Y = (MON.CH, GO TO GIVAYF
; --------------------------------
; FLOAT (Y) INTO FAC, GIVING VALUE 0-255
; --------------------------------
SNGFLT LDA #0 ; MSB = 0
SEC ; <<< NO PURPOSE WHATSOEVER >>>
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 RTS_9 ; RETURN IF RUNNING MODE
LDX #ERR_ILLDIR ; DIRECT MODE, GIVE ERROR
ASM_DATA($2C) ; TRICK TO SKIP NEXT 2 BYTES
; --------------------------------
UNDFNC LDX #ERR_UNDEFFUNC ; UNDEFINDED FUNCTION ERROR
JMP ERROR
; --------------------------------
; "DEF" STATEMENT
; --------------------------------
DEF JSR FNC_ ; PARSE "FN", FUNCTION NAME
JSR ERRDIR ; ERROR IF IN DIRECT MODE
JSR CHKOPN ; NEED "("
LDA #$80 ; FLAG PTRGET THAT CALLED FROM "DEF FN"
STA SUBFLG ; ALLOW ONLY SIMPLE FP VARIABLE FOR ARG
JSR PTRGET ; GET PNTR TO ARGUMENT
JSR CHKNUM ; MUST BE NUMERIC
JSR CHKCLS ; MUST HAVE ")" NOW
LDA #TOKENEQUUAL ; NOW NEED "="
JSR SYNCHR ; OR ELSE SYNTAX ERROR
PHA ; SAVE CHAR AFTER "="
LDA VARPNT+1 ; SAVE PNTR TO ARGUMENT
PHA
LDA VARPNT
PHA
LDA TXTPTR+1 ; SAVE TXTPTR
PHA
LDA TXTPTR
PHA
JSR DATA ; SCAN TO NEXT STATEMENT
JMP FNCDATA ; STORE ABOVE 5 BYTES IN "VALUE"
; --------------------------------
; COMMON ROUTINE FOR "DEFFN" AND "FN", TO
; PARSE "FN" AND THE FUNCTION NAME
; --------------------------------
FNC_ LDA #TOKEN_FN ; MUST NOW SEE "FN" TOKEN
JSR SYNCHR ; OR ELSE SYNTAX ERROR
ORA #$80 ; SET SIGN BIT ON 1ST CHAR OF NAME,
STA SUBFLG ; MAKING $C0 < SUBFLG < $DB
JSR PTRGET3 ; WHICH TELLS PTRGET WHO CALLED
STA FNCNAM ; FOUND VALID FUNCTION NAME, SO
STY FNCNAM+1 ; SAVE ADDRESS
JMP CHKNUM ; MUST BE NUMERIC
; --------------------------------
; "FN" FUNCTION CALL
; --------------------------------
FUNCT JSR FNC_ ; PARSE "FN", FUNCTION NAME
LDA FNCNAM+1 ; STACK FUNCTION ADDRESS
PHA ; IN CASE OF A NESTED FN CALL
LDA FNCNAM ;
PHA ;
JSR PARCHK ; MUST NOW HAVE "(EXPRESSION)"
JSR CHKNUM ; MUST BE NUMERIC EXPRESSION
PLA ; GET FUNCTION ADDRESS BACK
STA FNCNAM ;
PLA ;
STA FNCNAM+1 ;
LDY #2 ; POINT AT ADD OF ARGUMENT VARIABLE
LDA (FNCNAM),Y
STA VARPNT
TAX
INY
LDA (FNCNAM),Y
BEQ UNDFNC ; UNDEFINED FUNCTION
STA VARPNT+1
INY ; Y=4 NOW
L_FUNCT_1 LDA (VARPNT),Y ; SAVE OLD VALUE OF ARGUMENT VARIABLE
PHA ; ON STACK, IN CASE ALSO USED AS
DEY ; A NORMAL VARIABLE!
BPL L_FUNCT_1
LDY VARPNT+1 ; (Y,X)= ADDRESS, STORE FAC IN VARIABLE
JSR STORE_FACDB_YX_ROUNDED
LDA TXTPTR+1 ; REMEMBER TXTPTR AFTER FN CALL
PHA
LDA TXTPTR
PHA
LDA (FNCNAM),Y ; Y=0 FROM MOVMF
STA TXTPTR ; POINT TO FUNCTION DEF'N
INY
LDA (FNCNAM),Y
STA TXTPTR+1
LDA VARPNT+1 ; SAVE ADDRESS OF ARGUMENT VARIABLE
PHA ;
LDA VARPNT ;
PHA ;
JSR FRMNUM ; EVALUATE THE FUNCTION EXPRESSION
PLA ; GET ADDRESS OF ARGUMENT VARIABLE
STA FNCNAM ; AND SAVE IT
PLA ;
STA FNCNAM+1 ;
JSR CHRGOT ; MUST BE AT ":" OR EOL
BEQ L_FUNCT_2 ; WE ARE
JMP SYNERR ; WE ARE NOT, SLYNTAX ERROR
L_FUNCT_2 PLA ; RETRIEVE TXTPTR AFTER "FN" CALL
STA TXTPTR
PLA
STA TXTPTR+1
; STACK NOW HAS 5-BYTE VALUE
; OF THE ARGUMENT VARIABLE,
; AND FNCNAM POINTS AT THE VARIABLE
; --------------------------------
; STORE FIVE BYTES FROM STACK AT (FNCNAM)
; --------------------------------
FNCDATA
LDY #0
PLA
STA (FNCNAM),Y
PLA
INY
STA (FNCNAM),Y
PLA
INY
STA (FNCNAM),Y
PLA
INY
STA (FNCNAM),Y
PLA
INY
STA (FNCNAM),Y
RTS
; --------------------------------
; "STR$" FUNCTION
; --------------------------------
STR JSR CHKNUM ; EXPRESSION MUST BE NUMERIC
LDY #0 ; START STRING AT STACK-1 ($00FF)
; SO STRLIT CAN DIFFRENTIATE STR$ CALLS
JSR FOUT_1 ; CONVERT FAC TO STRING
PLA ; POP RETURN OFF STACK
PLA ;
LDA #<STACK-1 ; 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 #$22 ; 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 ;
L_STRLT2_1 INY ; FIND END OF STRING
LDA (STRNG1),Y ; NEXT STRING CHAR
BEQ L_STRLT2_3 ; END OF STRING
CMP CHARAC ; ALTERNATE TERMINATOR # 1?
BEQ L_STRLT2_2 ; YES
CMP ENDCHR ; ALTERNATE TERMINATOR # 2?
BNE L_STRLT2_1 ; NO, KEEP SCANNING
L_STRLT2_2 CMP #$22 ; IS STRING ENDED WITH QUOTE MARK?
BEQ L_STRLT2_4 ; YES, C=1 TO INCLUDE " IN STRING
L_STRLT2_3 CLC ;
L_STRLT2_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 L_STRLT2_5 ;
INX ;
L_STRLT2_5 STX STRNG2+1 ;
LDA STRNG1+1 ; WHERE DOES THE STRING START?
BEQ L_STRLT2_6 ; PAGE 0, MUST BE FROM STR$ FUNCTION
CMP #2 ; PAGE 2?
BNE PUTNEW ; NO, NOT PAGE 0 OR 2
L_STRLT2_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
L_GETSPA_1 PHA ; A HOLDS LENGTH
EOR #$FF ; GET -LENGTH
SEC ;
ADC FRETOP ; COMPUTE STARTING ADDRESS OF SPACE
LDY FRETOP+1 ; FOR THE STRING
BCS L_GETSPA_2 ;
DEY ;
L_GETSPA_2 CPY STREND+1 ; SEE IF FITS IN REMAINING MEMORY
BCC L_GETSPA_4 ; NO, TRY GARBAGE
BNE L_GETSPA_3 ; YES, IT FITS
CMP STREND ; HAVE TO CHECK LOWER BYTES
BCC L_GETSPA_4 ; NOT ENUF ROOM YET
L_GETSPA_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
L_GETSPA_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 L_GETSPA_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 ;
FIND_HIGHEST_STRING ;
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 ;
L_FIND_HIGHEST_STRING_1 CMP TEMPPT ; FINISHED WITH TEMPS YET?
BEQ L_FIND_HIGHEST_STRING_2 ; YES, NOW DO SIMPLE VARIABLES
JSR CHECK_VARIABLE ; DO A TEMP
BEQ L_FIND_HIGHEST_STRING_1 ; ...ALWAYS
; --------------------------------
; NOW COLLECT SIMPLE VARIABLES
; --------------------------------
L_FIND_HIGHEST_STRING_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
L_FIND_HIGHEST_STRING_3 CPX ARYTAB+1 ; FINISHED WITH SIMPLE VARIABLES?
BNE L_FIND_HIGHEST_STRING_4 ; NO
CMP ARYTAB ; MAYBE, CHECK LO-BYTE
BEQ L_FIND_HIGHEST_STRING_5 ; YES, NOW DO ARRAYS
L_FIND_HIGHEST_STRING_4 JSR CHECK_SIMPLE_VARIABLE
BEQ L_FIND_HIGHEST_STRING_3 ; ...ALWAYS
; --------------------------------
; NOW COLLECT ARRAY VARIABLES
; --------------------------------
L_FIND_HIGHEST_STRING_5 STA ARYPNT
STX ARYPNT+1
LDA #3 ; DESCRIPTORS IN ARRAYS ARE 3-BYTES EACH
STA DSCLEN ;
L_FIND_HIGHEST_STRING_6 LDA ARYPNT ; COMPARE TO END OF ARRAYS
LDX ARYPNT+1 ;
L_FIND_HIGHEST_STRING_7 CPX STREND+1 ; FINISHED WITH ARRAYS YET?
BNE L_FIND_HIGHEST_STRING_8 ; NOT YET
CMP STREND ; MAYBE, CHECK LO-BYTE
BNE L_FIND_HIGHEST_STRING_8 ; NOT FINISHED YET
JMP MOVE_HIGHEST_STRING_TO_TOP ; FINISHED
L_FIND_HIGHEST_STRING_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 L_FIND_HIGHEST_STRING_6 ; NOT A STRING ARRAY
TXA ; SET STATUS WITH 1ST CHAR OF NAME
BMI L_FIND_HIGHEST_STRING_6 ; NOT A STRING ARRAY
INY ;
LDA (INDEX),Y ; # OF DIMENSIONS FOR THIS ARRAY
LDY #0 ;
ASL ; PREAMBLE SIZE = 2*#DIMS + 5
ADC #5 ;
ADC INDEX ; MAKE INDEX POINT AT FIRST ELEMENT
STA INDEX ; IN THE ARRAY
BCC L_FIND_HIGHEST_STRING_9 ;
INC INDEX+1 ;
L_FIND_HIGHEST_STRING_9 ;
LDX INDEX+1 ; STEP THRU EACH STRING IN THIS ARRAY
L_FIND_HIGHEST_STRING_10 CPX ARYPNT+1 ; ARRAY DONE?
BNE L_FIND_HIGHEST_STRING_11 ; NO, PROCESS NEXT ELEMENT
CMP ARYPNT ; MAYBE, CHECK LO-BYTE
BEQ L_FIND_HIGHEST_STRING_7 ; YES, MOVE TO NEXT ARRAY
L_FIND_HIGHEST_STRING_11 JSR CHECK_VARIABLE ; PROCESS THE ARRAY
BEQ L_FIND_HIGHEST_STRING_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 L_CHECK_VARIABLE_1 ; NO, BELOW FRETOP
BNE CHECK_BUMP ; YES, ABOVE FRETOP
CPX FRETOP ; MAYBE, CHECK LO-BYTE
BCS CHECK_BUMP ; YES, ABOVE FRETOP
L_CHECK_VARIABLE_1 CMP LOWTR+1 ; ABOVE HIGHEST STRING FOUND?
BCC CHECK_BUMP ; NO, IGNORE FOR NOW
BNE L_CHECK_VARIABLE_2 ; YES, THIS IS THE NEW HIGHEST
CPX LOWTR ; MAYBE, TRY LO-BYTE
BCC CHECK_BUMP ; NO, IGNORE FOR NOW
L_CHECK_VARIABLE_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 ; 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 FIND_HIGHEST_STRING
; --------------------------------
; --------------------------------
; 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 L_CAT_1 ; OK IF < $100
LDX #ERR_STRLONG
JMP ERROR
L_CAT_1 JSR STRINI ; GET SPACE FOR CONCATENATED STRINGS
JSR MOVINS ; MOVE 1ST STRING
LDA DSCPTR ;
LDY DSCPTR+1 ;
JSR FRETMP ;
JSR MOVSTR_1 ; MOVE 2ND STRING
LDA STRNG1 ;
LDY STRNG1+1 ;
JSR FRETMP ;
JSR PUTNEW ; SET UP DESCRIPTOR
JMP FRMEVL_2 ; 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 ;
MOVSTR_1 ;
TAY ; LENGTH TO Y-REG
BEQ L_MOVSTR_1_2 ; IF LENGTH IS ZERO, FINISHED
PHA ; SAVE LENGTH ON STACK
L_MOVSTR_1_1 DEY ; MOVE BYTES FROM (INDEX) TO (FRESPC)
LDA (INDEX),Y
STA (FRESPC),Y
TYA ; TEST IF ANY LEFT TO MOVE
BNE L_MOVSTR_1_1 ; YES, KEEP MOVING
PLA ; NO, FINISHED. GET LENGTH
L_MOVSTR_1_2 CLC ; AND ADD TO FRESPC, SO
ADC FRESPC ; FRESPC POINTS TO NEXT HIGHER
STA FRESPC ; BYTE. (USED BY CONCATENATION)
BCC L_MOVSTR_1_3
INC FRESPC+1
L_MOVSTR_1_3 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 L_FRETMP_2 ; NOT A TEMPORARY STRING
CPY FRETOP+1 ; IS IT THE LOWEST STRING?
BNE L_FRETMP_2 ; NO
CPX FRETOP ;
BNE L_FRETMP_2 ; NO
PHA ; YES, PUSH LENGTH AGAIN
CLC ; RECOVER THE SPACE USED BY
ADC FRETOP ; THE STRING
STA FRETOP ;
BCC L_FRETMP_1 ;
INC FRETOP+1 ;
L_FRETMP_1 PLA ; RETRIEVE LENGTH AGAIN
L_FRETMP_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 L_FRETMS_1 ; NOT SAME ONE, CANNOT RELEASE
CMP LASTPT ;
BNE L_FRETMS_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
L_FRETMS_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
SUBSTRING_1 ;
BCC L_SUBSTRING_1_1 ; 1ST PARAMETER SMALLER, USE IT
LDA (DSCPTR),Y ; 1ST IS LONGER, USE STRING LENGTH
TAX ; IN X-REG
TYA ; Y=A=0 AGAIN
L_SUBSTRING_1_1 PHA ; PUSH LEFT END OF SUBSTRING
SUBSTRING_2 ;
TXA ;
SUBSTRING_3 ;
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 L_SUBSTRING_3_1 ;
INC INDEX+1 ;
L_SUBSTRING_3_1 TYA ; LENGTH
JSR MOVSTR_1 ; 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 SUBSTRING_1 ; JOIN LEFT$
; --------------------------------
; "MID$" FUNCTION
; --------------------------------
MIDSTR LDA #$FF ; FLAG WHETHER 2ND PARAMETER
STA FAC+4 ;
JSR CHRGOT ; SEE IF ")" YET
CMP #LOCHAR(`)') ;
BEQ L_MIDSTR_1 ; YES, NO 2ND PARAMETER
JSR CHKCOM ; NO, MUST HAVE COMMA
JSR GETBYT ; GET 2ND PARAM IN X-REG
L_MIDSTR_1 JSR SUBSTRING_SETUP
DEX ; 1ST PARAMETER - 1
TXA
PHA
CLC
LDX #0
SBC (DSCPTR),Y
BCS SUBSTRING_2
EOR #$FF
CMP FAC+4 ; USE SMALLER OF TWO
BCC SUBSTRING_3
LDA FAC+4
BCS SUBSTRING_3 ; ...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 L_VAL_1 ; LENGTH NON-ZERO
JMP ZERO_FAC ; RETURN 0 IF LENGTH=0
L_VAL_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 L_VAL_2 ;
INX ;
L_VAL_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 ;
; <<< THAT CAUSES A BUG IF HIMEM = $BFFF, >>>
; <<< BECAUSE STORING $00 AT $C000 IS NO >>>
; <<< USE; $C000 WILL ALWAYS BE LAST CHAR >>>
; <<< TYPED, SO FIN WON'T TERMINATE UNTIL >>>
; <<< IT SEES A ZERO AT $C010! >>>
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 ;
; RESTORE TXTPTR
; --------------------------------
; 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,
RTS ; AND THAT'S ALL FOR TODAY
; --------------------------------
; "WAIT" STATEMENT
; --------------------------------
WAIT JSR GTNUM ; GET ADDRESS IN LINNUM, MASK IN X
STX FORPNT ; SAVE MASK
LDX #0 ;
JSR CHRGOT ; ANOTHER PARAMETER?
BEQ L_WAIT_1 ; NO, USE $00 FOR EXCLUSIVE-OR
JSR COMBYTE ; GET XOR-MASK
L_WAIT_1 STX FORPNT+1 ; SAVE XOR-MASK HERE
LDY #0
L_WAIT_2 LDA (LINNUM),Y ; GET BYTE AT ADDRESS
EOR FORPNT+1 ; INVERT SPECIFIED BITS
AND FORPNT ; SELECT SPECIFIED BITS
BEQ L_WAIT_2 ; LOOP TILL NOT 0
RTS_10 RTS
; --------------------------------
; ADD 0L_RTS_10_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 FAC_SIGN ; COMPLEMENT FAC AND ADD
EOR #$FF ;
STA FAC_SIGN ;
EOR ARG_SIGN ; FIX SGNCPR TOO
STA SGNCPR ;
LDA FAC ; MAKE STATUS SHOW FAC EXPONENT
JMP FADDT ; JOIN FADD
; --------------------------------
; SHIFT SMALLER ARGUMENT MORE THAN 7 BITS
; --------------------------------
FADD_1 JSR SHIFT_RIGHT ; ALIGN RADIX BY SHIFTING
BCC FADD_3 ; ...ALWAYS
; --------------------------------
; FAC = (Y,A) + FAC
; --------------------------------
FADD JSR LOAD_ARG_FROM_YA
; --------------------------------
; FAC = ARG + FAC
; --------------------------------
FADDT BNE L_FADDT_1 ; FAC IS NON-ZERO
JMP COPY_ARG_TO_FAC ; FAC = 0 + ARG
L_FADDT_1 LDX FAC_EXTENSION
STX ARG_EXTENSION
LDX #ARG ; SET UP TO SHIFT ARG
LDA ARG ; EXPONENT
; --------------------------------
FADD_2 TAY
BEQ RTS_10 ; IF ARG=0, WE ARE FINISHED
SEC ;
SBC FAC ; GET DIFFNCE OF EXP
BEQ FADD_3 ; GO ADD IF SAME EXP
BCC L_FADD_2_1 ; ARG HAS SMALLER EXPONENT
STY FAC ; EXP HAS SMALLER EXPONENT
LDY ARG_SIGN ;
STY FAC_SIGN ;
EOR #$FF ; COMPLEMENT SHIFT COUNT
ADC #0 ; CARRY WAS SET
LDY #0
STY ARG_EXTENSION
LDX #FAC ; SET UP TO SHIFT FAC
BNE L_FADD_2_2 ; ...ALWAYS
L_FADD_2_1 LDY #0
STY FAC_EXTENSION
L_FADD_2_2 CMP #$F9 ; SHIFT MORE THAN 7 BITS?
BMI FADD_1 ; YES
TAY ; INDEX TO # OF SHIFTS
LDA FAC_EXTENSION
LSR 1,X ; START SHIFTING...
JSR SHIFT_RIGHT_4 ; ...COMPLETE SHIFTING
FADD_3 BIT SGNCPR ; DO FAC AND ARG HAVE SAME SIGNS?
BPL FADD_4 ; YES, ADD THE MANTISSAS
LDY #FAC ; NO, SUBTRACT SMALLER FROM LARGER
CPX #ARG ; WHICH WAS ADJUSTED?
BEQ L_FADD_3_1 ; IF ARG, DO FAC-ARG
LDY #ARG ; IF FAC, DO ARG-FAC
L_FADD_3_1 SEC ; SUBTRACT SMALLER FROM LARGER (WE HOPE)
EOR #$FF ; (IF EXPONENTS WERE EQUAL, WE MIGHT BE
ADC ARG_EXTENSION ; SUBTRACTING LARGER FROM SMALLER)
STA FAC_EXTENSION
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_FAC_1
BCS NORMALIZE_FAC_2
JSR COMPLEMENT_FAC
; --------------------------------
NORMALIZE_FAC_2
LDY #0 ; SHIFT UP SIGNIF DIGIT
TYA ; START A=0, COUNT SHIFTS IN A-REG
CLC
L_NORMALIZE_FAC_2_1 LDX FAC+1 ; LOOK AT MOST SIGNIFICANT BYTE
BNE NORMALIZE_FAC_4 ; 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 FAC_EXTENSION
STX FAC+4
STY FAC_EXTENSION ; ZERO EXTENSION BYTE
ADC #8 ; BUMP SHIFT COUNT
CMP #32 ; DONE 4 TIMES YET?
BNE L_NORMALIZE_FAC_2_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 FAC_SIGN
RTS
; --------------------------------
; ADD MANTISSAS OF FAC AND ARG INTO FAC
; --------------------------------
FADD_4 ADC ARG_EXTENSION
STA FAC_EXTENSION
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_FAC_5
; --------------------------------
; FINISH NORMALIZING FAC
; --------------------------------
NORMALIZE_FAC_3
ADC #1 ; COUNT BITS SHIFTED
ASL FAC_EXTENSION
ROL FAC+4
ROL FAC+3
ROL FAC+2
ROL FAC+1
; --------------------------------
NORMALIZE_FAC_4
BPL NORMALIZE_FAC_3 ; 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_FAC_5 ;
BCC RTS_11 ; UNLESS MANTISSA CARRIED
; --------------------------------
NORMALIZE_FAC_6 ;
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 FAC_EXTENSION
RTS_11 RTS
; --------------------------------
; 2'S COMPLEMENT OF FAC
; --------------------------------
COMPLEMENT_FAC
LDA FAC_SIGN
EOR #$FF
STA FAC_SIGN
; --------------------------------
; 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 FAC_EXTENSION
EOR #$FF
STA FAC_EXTENSION
INC FAC_EXTENSION ; START INCREMENTING MANTISSA
BNE RTS_12
; --------------------------------
; INCREMENT FAC MANTISSA
; --------------------------------
INCREMENT_FAC_MANTISSA
INC FAC+4 ; ADD CARRY FROM EXTRA
BNE RTS_12
INC FAC+3
BNE RTS_12
INC FAC+2
BNE RTS_12
INC FAC+1
RTS_12 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_RIGHT_1
LDX #RESULT-1 ; SHIFT RESULT RIGHT
SHIFT_RIGHT_2 ;
LDY 4,X ; SHIFT 8 BITS RIGHT
STY FAC_EXTENSION ;
LDY 3,X ;
STY 4,X ;
LDY 2,X ;
STY 3,X ;
LDY 1,X ;
STY 2,X ;
LDY SHIFT_SIGN_EXT ; $00 IF +, $FF IF -
STY 1,X
; --------------------------------
; MAIN ENTRY TO RIGHT SHIFT SUBROUTINE
; --------------------------------
SHIFT_RIGHT
ADC #8
BMI SHIFT_RIGHT_2 ; STILL MORE THAN 8 BITS TO GO
BEQ SHIFT_RIGHT_2 ; EXACTLY 8 MORE BITS TO GO
SBC #8 ; UNDO ADC ABOVE
TAY ; REMAINING SHIFT COUNT
LDA FAC_EXTENSION ;
BCS SHIFT_RIGHT_5 ; FINISHED SHIFTING
SHIFT_RIGHT_3 ;
L ASL 1,X ; SIGN -> CARRY (SIGN EXTENSION)
BCC L_L_1 ; SIGN +
INC 1,X ; PUT SIGN IN LSB
L_L_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_RIGHT_4
ROR 2,X
ROR 3,X
ROR 4,X
ROR ; EXTENSION
INY ; COUNT THE SHIFT
BNE SHIFT_RIGHT_3 ;
SHIFT_RIGHT_5 ;
CLC ; RETURN WITH CARRY CLEAR
RTS
; --------------------------------
; --------------------------------
CON_ONE ASM_DATA($81,$00,$00,$00,$00)
; --------------------------------
POLY_LOG ASM_DATA(3) ; # OF COEFFICIENTS - 1
ASM_DATA($7F,$5E,$56,$CB,$79) ; * X^7 +
ASM_DATA($80,$13,$9B,$0B,$64) ; * X^5 +
ASM_DATA($80,$76,$38,$93,$16) ; * X^3 +
ASM_DATA($82,$38,$AA,$3B,$20) ; * X
; --------------------------------
CON_SQR_HALF ASM_DATA($80,$35,$04,$F3,$34)
CON_SQR_TWO ASM_DATA($81,$35,$04,$F3,$34)
CON_NEG_HALF ASM_DATA($80,$80,$00,$00,$00)
CON_LOG_TWO ASM_DATA($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 LOG_2 ; >0 IS OK
GIQ JMP IQERR ; <= 0 IS NO GOOD
LOG_2 LDA FAC ; FIRST GET LOG BASE 2
SBC #$7F ; SAVE UNBIASED EXPONENT
PHA ;
LDA #$80 ; NORMALIZE BETWEEN L_LOG_2_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 L_FMULTT_1 ; FAC .NE. ZERO
JMP RTS_13 ; FAC = 0 * ARG = 0
; <<< WHY IS LINE ABOVE JUST "RTS"? >>>
; --------------------------------
;
; --------------------------------
L_FMULTT_1 JSR ADD_EXPONENTS
LDA #0
STA RESULT ; INIT PRODUCT = 0
STA RESULT+1
STA RESULT+2
STA RESULT+3
LDA FAC_EXTENSION
JSR MULTIPLY_1
LDA FAC+4
JSR MULTIPLY_1
LDA FAC+3
JSR MULTIPLY_1
LDA FAC+2
JSR MULTIPLY_1
LDA FAC+1
JSR MULTIPLY_2
JMP COPY_RESULT_INTO_FAC
; --------------------------------
; MULTIPLY ARG BY (A) INTO RESULT
; --------------------------------
MULTIPLY_1
BNE MULTIPLY_2 ; THIS BYTE NON-ZERO
JMP SHIFT_RIGHT_1 ; (A)=0, JUST SHIFT ARG RIGHT 8
; --------------------------------
MULTIPLY_2 ;
LSR ; SHIFT BIT INTO CARRY
ORA #$80 ; SUPPLY SENTINEL BIT
L_MULTIPLY_2_1 TAY ; REMAINING MULTIPLIER TO Y
BCC L_MULTIPLY_2_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
L_MULTIPLY_2_2 ROR RESULT ; SHIFT RESULT RIGHT 1
ROR RESULT+1 ;
ROR RESULT+2 ;
ROR RESULT+3 ;
ROR FAC_EXTENSION ;
TYA ; REMAINING MULTIPLIER
LSR ; LSB INTO CARRY
BNE L_MULTIPLY_2_1 ; IF SENTINEL STILL HERE, MULTIPLY
RTS_13 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 ARG_SIGN ;
EOR FAC_SIGN ; SET COMBINED SIGN FOR MULT/DIV
STA SGNCPR ;
LDA ARG_SIGN ; 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_EXPONENTS_1
BEQ ZERO ; IF ARG=0, RESULT IS ZERO
CLC ;
ADC FAC ;
BCC L_ADD_EXPONENTS_1_1 ; IN RANGE
BMI JOV ; OVERFLOW
CLC ;
ASM_DATA($2C) ; TRICK TO SKIP
L_ADD_EXPONENTS_1_1 BPL ZERO ; OVERFLOW
ADC #$80 ; RE-BIAS
STA FAC ; RESULT
BNE L_ADD_EXPONENTS_1_2
JMP STA_IN_FAC_SIGN ; RESULT IS ZERO
; <<< CRAZY TO JUMP WAY BACK THERE! >>>
; <<< SAME IDENTICAL CODE IS BELOW! >>>
; <<< INSTEAD OF BNE L_ADD_EXPONENTS_1_2, JMP STA.IN.FAC.SIGN >>>
; <<< ONLY NEEDED BEQ L_ADD_EXPONENTS_1_3 >>>
L_ADD_EXPONENTS_1_2 LDA SGNCPR ; SET SIGN OF RESULT
L_ADD_EXPONENTS_1_3 STA FAC_SIGN
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 FAC_SIGN
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 L_MUL10_1 ; FINISHED IF FAC=0
CLC ;
ADC #2 ; ADD 2 TO EXPONENT GIVES (FAC)*4
BCS JOV ; OVERFLOW
LDX #0 ;
STX SGNCPR ;
JSR FADD_2 ; MAKES (FAC)*5
INC FAC ; *2, MAKES (FAC)*10
BEQ JOV ; OVERFLOW
L_MUL10_1 RTS
; --------------------------------
CON_TEN ASM_DATA($84,$20,$00,$00,$00)
; --------------------------------
; DIVIDE FAC BY 10
; --------------------------------
DIV10 JSR COPY_FAC_TO_ARG_ROUNDED
LDA #<CON_TEN ; SET UP TO PUT
LDY #>CON_TEN ; 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 L_FDIVT_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 #$FC ; INDEX FOR RESULT
LDA #1 ; SENTINEL
L_FDIVT_1 LDY ARG+1 ; SEE IF FAC CAN BE SUBTRACTED
CPY FAC+1
BNE L_FDIVT_2
LDY ARG+2
CPY FAC+2
BNE L_FDIVT_2
LDY ARG+3
CPY FAC+3
BNE L_FDIVT_2
LDY ARG+4
CPY FAC+4
L_FDIVT_2 PHP ; SAVE THE ANSWER, AND ALSO ROLL THE
ROL ; BIT INTO THE QUOTIENT, SENTINEL OUT
BCC L_FDIVT_3 ; NO SENTINEL, STILL NOT 8 TRIPS
INX ; 8 TRIPS, STORE BYTE OF QUOTIENT
STA RESULT+3,X
BEQ L_FDIVT_6 ; 32-BITS COMPLETED
BPL L_FDIVT_7 ; FINAL EXIT WHEN X=1
LDA #1 ; RE-START SENTINEL
L_FDIVT_3 PLP ; GET ANSWER, CAN FAC BE SUBTRACTED?
BCS L_FDIVT_5 ; YES, DO IT
L_FDIVT_4 ASL ARG+4 ; NO, SHIFT ARG LEFT
ROL ARG+3 ;
ROL ARG+2 ;
ROL ARG+1 ;
BCS L_FDIVT_2 ; ANOTHER TRIP
BMI L_FDIVT_1 ; HAVE TO COMPARE FIRST
BPL L_FDIVT_2 ; ...ALWAYS
L_FDIVT_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 L_FDIVT_4 ; GO TO SHIFT ARG AND CONTINUE
; --------------------------------
L_FDIVT_6 LDA #$40 ; DO A FEW EXTENSION BITS
BNE L_FDIVT_3 ; ...ALWAYS
; --------------------------------
L_FDIVT_7 ASL ; LEFT JUSTIFY THE EXTENSION BITS WE DID
ASL
ASL
ASL
ASL
ASL
STA FAC_EXTENSION
PLP
JMP COPY_RESULT_INTO_FAC
; --------------------------------
L_FDIVT_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_FAC_2
; --------------------------------
; 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 FAC_SIGN ; FIRST BIT IS SIGN
ORA #$80 ; SET NORMALIZED INVISIBLE BIT
STA FAC+1 ;
DEY ;
LDA (INDEX),Y ;
STA FAC ; EXPONENT
STY FAC_EXTENSION ; Y=0
RTS
; --------------------------------
; ROUND FAC, STORE IN TEMP2
; --------------------------------
STORE_FAC_IN_TEMP2_ROUNDED
LDX #TEMP2 ; PACK FAC INTO TEMP2
ASM_DATA($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_FACDB_YX_ROUNDED ; ...ALWAYS
; --------------------------------
; ROUND FAC, AND STORE WHERE FORPNT POINTS
; --------------------------------
SETFOR LDX FORPNT
LDY FORPNT+1
; --------------------------------
; ROUND FAC, AND STORE AT (Y,X)
; --------------------------------
STORE_FACDB_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 FAC_SIGN ; PACK SIGN IN TOP BIT OF MANTISSA
ORA #$7F ;
AND FAC+1 ;
STA (INDEX),Y ;
DEY ;
LDA FAC ; EXPONENT
STA (INDEX),Y ;
STY FAC_EXTENSION ; ZERO THE EXTENSION
RTS
; --------------------------------
; COPY ARG INTO FAC
; --------------------------------
COPY_ARG_TO_FAC
LDA ARG_SIGN ; COPY SIGN
MFA STA FAC_SIGN ;
LDX #5 ; MOVE 5 BYTES
L_MFA_1 LDA ARG-1,X ;
STA FAC-1,X ;
DEX ;
BNE L_MFA_1 ;
STX FAC_EXTENSION ; 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
L_MAF_1 LDA FAC-1,X ;
STA ARG-1,X ;
DEX ;
BNE L_MAF_1 ;
STX FAC_EXTENSION ; ZERO FAC EXTENSION
RTS_14 RTS ;
; --------------------------------
; ROUND FAC USING EXTENSION BYTE
; --------------------------------
ROUND_FAC
LDA FAC
BEQ RTS_14 ; FAC = 0, RETURN
ASL FAC_EXTENSION ; IS FAC.EXTENSION >= 128?
BCC RTS_14 ; NO, FINISHED
; --------------------------------
; INCREMENT MANTISSA AND RE-NORMALIZE IF CARRY
; --------------------------------
INCREMENT_MANTISSA
JSR INCREMENT_FAC_MANTISSA ; YES, INCREMENT FAC
BNE RTS_14 ; HIGH BYTE HAS BITS, FINISHED
JMP NORMALIZE_FAC_6 ; 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 RTS_15 ; RETURN -1,0,1 IN A-REG
; --------------------------------
SIGN1 LDA FAC_SIGN ;
; --------------------------------
SIGN2 ROL ; MSBIT TO CARRY
LDA #$FF ; -1
BCS RTS_15 ; MSBIT = 1
LDA #1 ; +1
RTS_15 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
; --------------------------------
FLOAT_1 ;
LDA FAC+1 ; MSBIT=0, SET CARRY; =1, CLEAR CARRY
EOR #$FF ;
ROL ;
; --------------------------------
; FLOAT UNSIGNED VALUE IN FAC+1,2
; (X) = EXPONENT
; C=0 TO MAKE VALUE NEGATIVE
; C=1 TO MAKE VALUE POSITIVE
; --------------------------------
FLOAT_2 ;
LDA #0 ; CLEAR LOWER 16-BITS OF MANTISSA
STA FAC+4 ;
STA FAC+3 ;
STX FAC ; STORE EXPONENT
STA FAC_EXTENSION ; CLEAR EXTENSION
STA FAC_SIGN ; MAKE SIGN POSITIVE
JMP NORMALIZE_FAC_1 ; IF C=0, WILL NEGATE FAC
; --------------------------------
; "ABS" FUNCTION
; --------------------------------
ABS LSR FAC_SIGN ; 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 FAC_SIGN ; COMPARE WITH FAC SIGN
BMI SIGN1 ; DIFFERENT SIGNS, "SIGN" GIVES ANSWER
CPX FAC ; SAME SIGN, SO COMPARE EXPONENTS
BNE L_FCOMP2_1 ; DIFFERENT, SO SUFFICIENT TEST
LDA (DEST),Y ; SAME EXPONENT, COMPARE MANTISSA
ORA #$80 ; SET INVISIBLE NORMALIZED BIT
CMP FAC+1 ;
BNE L_FCOMP2_1 ; NOT SAME, SO SUFFICIENT
INY ; SAME, COMPARE MORE MANTISSA
LDA (DEST),Y ;
CMP FAC+2 ;
BNE L_FCOMP2_1 ; NOT SAME, SO SUFFICIENT
INY ; SAME, COMPARE MORE MANTISSA
LDA (DEST),Y ;
CMP FAC+3 ;
BNE L_FCOMP2_1 ; NOT SAME, SO SUFFICIENT
INY ; SAME, COMPARE REST OF MANTISSA
LDA #$7F ; ARTIFICIAL EXTENSION BYTE FOR COMPARAND
CMP FAC_EXTENSION
LDA (DEST),Y
SBC FAC+4
BEQ RTS_16 ; NUMBERS ARE EQUAL, RETURN (A)=0
L_FCOMP2_1 LDA FAC_SIGN ; NUMBERS ARE DIFFERENT
BCC L_FCOMP2_2 ; FAC IS LARGER MAGNITUDE
EOR #$FF ; FAC IS SMALLER MAGNITUDE
; <<< NOTE THAT ABOVE THREE LINES CAN BE SHORTENED: >>>
; <<< L_FCOMP2_1 ROR PUT CARRY INTO SIGN BIT >>>
; <<< EOR FAC.SIGN TOGGLE WITH SIGN OF FAC >>>
L_FCOMP2_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 QINT_3 ; FAC=0, SO FINISHED
SEC ; GET -(NUMBER OF FRACTIONAL BITS)
SBC #$A0 ; IN A-REG FOR SHIFT COUNT
BIT FAC_SIGN ; CHECK SIGN OF FAC
BPL L_QINT_1 ; POSITIVE, CONTINUE
TAX ; NEGATIVE, SO COMPLEMENT MANTISSA
LDA #$FF ; AND SET SIGN EXTENSION FOR SHIFT
STA SHIFT_SIGN_EXT
JSR COMPLEMENT_FAC_MANTISSA
TXA ; RESTORE BIT COUNT TO A-REG
L_QINT_1 LDX #FAC ; POINT SHIFT SUBROUTINE AT FAC
CMP #$F9 ; MORE THAN 7 BITS TO SHIFT?
BPL QINT_2 ; NO, SHORT SHIFT
JSR SHIFT_RIGHT ; YES, USE GENERAL ROUTINE
STY SHIFT_SIGN_EXT ; Y=0, CLEAR SIGN EXTENSION
RTS_16 RTS
; --------------------------------
QINT_2 TAY ; SAVE SHIFT COUNT
LDA FAC_SIGN ; GET SIGN BIT
AND #$80 ;
LSR FAC+1 ; START RIGHT SHIFT
ORA FAC+1 ; AND MERGE WITH SIGN
STA FAC+1
JSR SHIFT_RIGHT_4 ; JUMP INTO MIDDLE OF SHIFTER
STY SHIFT_SIGN_EXT ; Y=0, CLEAR SIGN EXTENSION
RTS
; --------------------------------
; "INT" FUNCTION
;
; USES QINT TO CONVERT (FAC) TO INTEGER FORM,
; AND THEN REFLOATS THE INTEGER.
; <<< A FASTER APPROACH WOULD SIMPLY CLEAR >>>
; <<< THE FRACTIONAL BITS BY ZEROING THEM >>>
; --------------------------------
INT LDA FAC ; CHECK IF EXPONENT < 32
CMP #$A0 ; BECAUSE IF > 31 THERE IS NO FRACTION
BCS RTS_17 ; NO FRACTION, WE ARE FINISHED
JSR QINT ; USE GENERAL INTEGER CONVERSION
STY FAC_EXTENSION ; Y=0, CLEAR EXTENSION
LDA FAC_SIGN ; GET SIGN OF VALUE
STY FAC_SIGN ; Y=0, CLEAR SIGN
EOR #$80 ; TOGGLE ACTUAL SIGN
ROL ; 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_FAC_1 ; NORMALIZE TO FINISH CONVERSION
; --------------------------------
QINT_3 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
RTS_17 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
L_FIN_1 STY TMPEXP,X
DEX
BPL L_FIN_1
; --------------------------------
BCC FIN_2 ; FIRST CHAR IS A DIGIT
CMP #LOCHAR(`-') ; CHECK FOR LEADING SIGN
BNE L_FIN_2 ; NOT MINUS
STX SERLEN ; MINUS, SET SERLEN = $FF FOR FLAG
BEQ FIN_1 ; ...ALWAYS
L_FIN_2 CMP #LOCHAR(`+') ; MIGHT BE PLUS
BNE FIN_3 ; NOT PLUS EITHER, CHECK DECIMAL POINT
; --------------------------------
FIN_1 JSR CHRGET ; GET NEXT CHAR OF STRING
; --------------------------------
FIN_2 BCC FIN_9 ; INSERT THIS DIGIT
; --------------------------------
FIN_3 CMP #LOCHAR(`.') ; CHECK FOR DECIMAL POINT
BEQ FIN_10 ; YES
CMP #LOCHAR(`E') ; CHECK FOR EXPONENT PART
BNE FIN_7 ; NO, END OF NUMBER
JSR CHRGET ; YES, START CONVERTING EXPONENT
BCC FIN_5 ; EXPONENT DIGIT
CMP #TOKEN_MINUS ; NEGATIVE EXPONENT?
BEQ L_FIN_3_1 ; YES
CMP #LOCHAR(`-') ; MIGHT NOT BE TOKENIZED YET
BEQ L_FIN_3_1 ; YES, IT IS NEGATIVE
CMP #TOKEN_PLUS ; OPTIONAL "+"
BEQ FIN_4 ; YES
CMP #LOCHAR(`+') ; MIGHT NOT BE TOKENIZED YET
BEQ FIN_4 ; YES, FOUND "+"
BNE FIN_6 ; ...ALWAYS, NUMBER COMPLETED
L_FIN_3_1 ROR EXPSGN ; C=1, SET FLAG NEGATIVE
; --------------------------------
FIN_4 JSR CHRGET ; GET NEXT DIGIT OF EXPONENT
; --------------------------------
FIN_5 BCC GETEXP ; CHAR IS A DIGIT OF EXPONENT
; --------------------------------
FIN_6 BIT EXPSGN ; END OF NUMBER, CHECK EXP SIGN
BPL FIN_7 ; POSITIVE EXPONENT
LDA #0 ; NEGATIVE EXPONENT
SEC ; MAKE 2'S COMPLEMENT OF EXPONENT
SBC EXPON ;
JMP FIN_8 ;
; --------------------------------
; FOUND A DECIMAL POINT
; --------------------------------
FIN_10 ROR DPFLG ; C=1, SET DPFLG FOR DECIMAL POINT
BIT DPFLG ; CHECK IF PREVIOUS DEC. PT.
BVC FIN_1 ; 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
; --------------------------------
FIN_7 LDA EXPON ; E-VALUE
FIN_8 SEC ; MODIFY WITH COUNT OF DIGITS
SBC TMPEXP ; AFTER THE DECIMAL POINT
STA EXPON ; COMPLETE CURRENT EXPONENT
BEQ L_FIN_8_15 ; NO ADJUST NEEDED IF EXP=0
BPL L_FIN_8_14 ; EXP>0, MULTIPLY BY TEN
L_FIN_8_13 JSR DIV10 ; EXP<0, DIVIDE BY TEN
INC EXPON ; UNTIL EXP=0
BNE L_FIN_8_13 ;
BEQ L_FIN_8_15 ; ...ALWAYS, WE ARE FINISHED
L_FIN_8_14 JSR MUL10 ; EXP>0, MULTIPLY BKY TEN
DEC EXPON ; UNTIL EXP=0
BNE L_FIN_8_14 ;
L_FIN_8_15 LDA SERLEN ; IS WHOLE NUMBER NEGATIVE?
BMI L_FIN_8_16 ; YES
RTS ; NO, RETURN, WHOLE JOB DONE!
L_FIN_8_16 JMP NEGOP ; NEGATIVE NUMBER, SO NEGATE FAC
; --------------------------------
; ACCUMULATE A DIGIT INTO FAC
; --------------------------------
FIN_9 PHA ; SAVE DIGIT
BIT DPFLG ; SEEN A DECIMAL POINT YET?
BPL L_FIN_9_1 ; NO, STILL IN INTEGER PART
INC TMPEXP ; YES, COUNT THE FRACTIONAL DIGIT
L_FIN_9_1 JSR MUL10 ; FAC = FAC * 10
PLA ; CURRENT DIGIT
SEC ; <<<SHORTER HERE TO JUST "AND #$0F">>>
SBC #LOCHAR(`0') ; <<<TO CONVERT ASCII TO BINARY FORM>>>
JSR ADDACC ; ADD THE DIGIT
JMP FIN_1 ; 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 ARG_SIGN ;
EOR FAC_SIGN ;
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 L_GETEXP_1 ; NO, THIS IS 1ST OR 2ND DIGIT
LDA #100 ; EXPONENT TOO BIG
BIT EXPSGN ; UNLESS IT IS NEGATIVE
BMI L_GETEXP_2 ; LARGE NEGATIVE EXPONENT MAKES FAC=0
JMP OVERFLOW ; LARGE POSITIVE EXPONENT IS ERROR
L_GETEXP_1 ASL ; EXPONENT TIMES 10
ASL ;
CLC ;
ADC EXPON ;
ASL ;
CLC ; <<< ASL ALREADY DID THIS! >>>
LDY #0 ; ADD THE NEW DIGIT
ADC (TXTPTR),Y ; BUT THIS IS IN ASCII,
SEC ; SO ADJUST BACK TO BINARY
SBC #LOCHAR(`0')
L_GETEXP_2 STA EXPON ; NEW VALUE
JMP FIN_4 ; BACK FOR MORE
; --------------------------------
; --------------------------------
CON_99999999P9 ASM_DATA($9B,$3E,$BC,$1F,$FD) ; 99,999,999.9
CON_999999999 ASM_DATA($9E,$6E,$6B,$27,$FD) ; 999,999,999
CON_BILLION ASM_DATA($9E,$6E,$6B,$28,$00) ; 1,000,000,000
; --------------------------------
; PRINT "IN <LINE #>"
; --------------------------------
INPRT LDA #<QT_IN ; PRINT " IN "
LDY #>QT_IN
JSR GO_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 FLOAT_2 ; CONVERT LINE # TO FP
; --------------------------------
; CONVERT (FAC) TO STRING, AND PRINT IT
; --------------------------------
PRINT_FAC ;
JSR FOUT ; CONVERT (FAC) TO STRING AT STACK
; --------------------------------
; PRINT STRING STARTING AT Y,A
; --------------------------------
GO_STROUT ;
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)
; --------------------------------
FOUT_1 LDA #LOCHAR(`-') ; IN CASE VALUE NEGATIVE
DEY ; BACK UP PNTR
BIT FAC_SIGN ;
BPL L_FOUT_1_1 ; VALUE IS +
INY ; VALUE IS -
STA STACK-1,Y ; EMIT "-"
L_FOUT_1_1 STA FAC_SIGN ; MAKE FAC.SIGN POSITIVE ($2D)
STY STRNG2 ; SAVE STRING PNTR
INY ;
LDA #LOCHAR(`0') ; IN CASE (FAC)=0
LDX FAC ; NUMBER=0?
BNE L_FOUT_1_2 ; NO, (FAC) NOT ZERO
JMP FOUT_4 ; YES, FINISHED
; --------------------------------
L_FOUT_1_2 LDA #0 ; STARTING VALUE FOR TMPEXP
CPX #$80 ; ANY INTEGER PART?
BEQ L_FOUT_1_3 ; NO, BTWN L_FOUT_1_5 AND L_FOUT_1_999999999
BCS L_FOUT_1_4 ; YES
; --------------------------------
L_FOUT_1_3 LDA #<CON_BILLION ; MULTIPLY BY 1E9
LDY #>CON_BILLION ; TO GIVE ADJUSTMENT A HEAD START
JSR FMULT ;
LDA #$100-9 ; EXPONENT ADJUSTMENT
L_FOUT_1_4 STA TMPEXP ; 0 OR -9
; --------------------------------
; ADJUST UNTIL 1E8 <= (FAC) <1E9
; --------------------------------
L_FOUT_1_5 LDA #<CON_999999999
LDY #>CON_999999999
JSR FCOMP ; COMPARE TO 1E9-1
BEQ L_FOUT_1_10 ; (FAC) = 1E9-1
BPL L_FOUT_1_8 ; TOO LARGE, DIVIDE BY TEN
L_FOUT_1_6 LDA #<CON_99999999P9 ; COMPARE TO 1E8-L_FOUT_1_1
LDY #>CON_99999999P9
JSR FCOMP ; COMPARE TO 1E8-L_FOUT_1_1
BEQ L_FOUT_1_7 ; (FAC) = 1E8-L_FOUT_1_1
BPL L_FOUT_1_9 ; IN RANGE, ADJUSTMENT FINISHED
L_FOUT_1_7 JSR MUL10 ; TOO SMALL, MULTIPLY BY TEN
DEC TMPEXP ; KEEP TRACK OF MULTIPLIES
BNE L_FOUT_1_6 ; ...ALWAYS
L_FOUT_1_8 JSR DIV10 ; TOO LARGE, DIVIDE BY TEN
INC TMPEXP ; KEEP TRACK OF DIVISIONS
BNE L_FOUT_1_5 ; ...ALWAYS
; --------------------------------
L_FOUT_1_9 JSR FADDH ; ROUND ADJUSTED RESULT
L_FOUT_1_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
; --------------------------------
FOUT_2 LDX #1 ; ASSUME 1 DIGIT BEFORE "."
LDA TMPEXP ; CHECK RANGE
CLC ;
ADC #10 ;
BMI L_FOUT_2_1 ; < .01, USE EXPONENTIAL FORM
CMP #11 ;
BCS L_FOUT_2_2 ; >= 1E10, USE EXPONENTIAL FORM
ADC #$FF ; LESS 1 GIVES INDEX FOR "."
TAX ;
LDA #2 ; SET REMAINING EXPONENT = 0
L_FOUT_2_1 SEC ; COMPUTE REMAINING EXPONENT
L_FOUT_2_2 SBC #2 ;
STA EXPON ; VALUE FOR "E+XX" OR "E-XX"
STX TMPEXP ; INDEX FOR DECIMAL POINT
TXA ; SEE IF "." COMES FIRST
BEQ L_FOUT_2_3 ; YES
BPL L_FOUT_2_5 ; NO, LATER
L_FOUT_2_3 LDY STRNG2 ; GET INDEX INTO STRING BEING BUILT
LDA #LOCHAR(`.') ; STORE A DECIMAL POINT
INY ;
STA STACK-1,Y ;
TXA ; SEE IF NEED ".0"
BEQ L_FOUT_2_4 ; NO
LDA #LOCHAR(`0') ; YES, STORE "0"
INY ;
STA STACK-1,Y ;
L_FOUT_2_4 STY STRNG2 ; SAVE OUTPUT INDEX AGAIN
; --------------------------------
; NOW DIVIDE BY POWERS OF TEN TO GET SUCCESSIVE DIGITS
; --------------------------------
L_FOUT_2_5 LDY #0 ; INDEX TO TABLE OF POWERS OF TEN
LDX #$80 ; STARTING VALUE FOR DIGIT WITH DIRECTION
L_FOUT_2_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 L_FOUT_2_7 ; IF C=1 AND X NEGATIVE, KEEP ADDING
BPL L_FOUT_2_6 ; IF C=0 AND X POSITIVE, KEEP ADDING
BMI L_FOUT_2_8 ; IF C=0 AND X NEGATIVE, WE OVERSHOT
L_FOUT_2_7 BMI L_FOUT_2_6 ; IF C=1 AND X POSITIVE, WE OVERSHOT
L_FOUT_2_8 TXA ; OVERSHOT, SO MAKE X INTO A DIGIT
BCC L_FOUT_2_9 ; HOW DEPENDS ON DIRECTION WE WERE GOING
EOR #$FF ; DIGIT = 9-X
ADC #10 ;
L_FOUT_2_9 ADC #LOCHAR(`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 L_FOUT_2_10 ; NOT TIME FOR "." YET
LDA #LOCHAR(`.') ; TIME, SO STORE THE DECIMAL POINT
INY ;
STA STACK-1,Y ;
L_FOUT_2_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 L_FOUT_2_6 ; NOT FINISHED YET
; --------------------------------
; NINE DIGITS HAVE BEEN STORED IN STRING. NOW LOOK
; BACK AND LOP OFF TRAILING ZEROES AND A TRAILING
; DECIMAL POINT.
; --------------------------------
FOUT_3 LDY STRNG2 ; POINTS AT LAST STORED CHAR
L_FOUT_3_1 LDA STACK-1,Y ; SEE IF LOPPABLE
DEY ;
CMP #LOCHAR(`0') ; SUPPRESS TRAILING ZEROES
BEQ L_FOUT_3_1 ; YES, KEEP LOOPING
CMP #LOCHAR(`.') ; SUPPRESS TRAILING DECIMAL POINT
BEQ L_FOUT_3_2 ; ".", SO WRITE OVER IT
INY ; NOT ".", SO INCLUDE IN STRING AGAIN
L_FOUT_3_2 LDA #LOCHAR(`+') ; PREPARE FOR POSITIVE EXPONENT "E+XX"
LDX EXPON ; SEE IF ANY E-VALUE
BEQ FOUT_5 ; NO, JUST MARK END OF STRING
BPL L_FOUT_3_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 #LOCHAR(`-') ; E SIGN
L_FOUT_3_3 STA STACK+1,Y ; STORE SIGN IN STRING
LDA #LOCHAR(`E') ; STORE "E" IN STRING BEFORE SIGN
STA STACK,Y ;
TXA ; EXPONENT MAGNITUDE IN A-REG
LDX #LOCHAR(`0')-1 ; SEED FOR EXPONENT DIGIT
SEC ; CONVERT TO DECIMAL
L_FOUT_3_4 INX ; COUNT THE SUBTRACTION
SBC #10 ; TEN'S DIGIT
BCS L_FOUT_3_4 ; MORE TENS TO SUBTRACT
ADC #LOCHAR(`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 FOUT_6 ; ...ALWAYS
FOUT_4 STA STACK-1,Y ; STORE "0" IN ASCII
FOUT_5 LDA #0 ; STORE $00 ON END OF STRING
STA STACK,Y ;
FOUT_6 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 ASM_DATA($80,$00,$00,$00,$00) ; FP CONSTANT 0L_CON_HALF_5
; --------------------------------
; POWERS OF 10 FROM 1E8 DOWN TO 1,
; AS 32-BIT INTEGERS, WITH ALTERNATING SIGNS
; --------------------------------
DECTBL ASM_DATA($FA,$0A,$1F,$00) ; -100000000
ASM_DATA($00,$98,$96,$80) ; 10000000
ASM_DATA($FF,$F0,$BD,$C0) ; -1000000
ASM_DATA($00,$01,$86,$A0) ; 100000
ASM_DATA($FF,$FF,$D8,$F0) ; -10000
ASM_DATA($00,$00,$03,$E8) ; 1000
ASM_DATA($FF,$FF,$FF,$9C) ; -100
ASM_DATA($00,$00,$00,$0A) ; 10
ASM_DATA($FF,$FF,$FF,$FF) ; -1
DECTBL_END
; --------------------------------
; --------------------------------
; "SQR" FUNCTION
;
; <<< UNFORTUNATELY, RATHER THAN A NEWTON-RAPHSON >>>
; <<< ITERATION, APPLESOFT USES EXPONENTIATION >>>
; <<< SQR(X) = X^L_DECTBL_END_5 >>>
; --------------------------------
SQR JSR COPY_FAC_TO_ARG_ROUNDED
LDA #<CON_HALF ; SET UP POWER OF 0L_SQR_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 L_FPWRT_1 ; NEITHER IS ZERO
JMP STA_IN_FAC_SIGN_AND_EXP ; SET FAC = 0
L_FPWRT_1 LDX #TEMP3 ; SAVE FAC IN TEMP3
LDY #0
JSR STORE_FACDB_YX_ROUNDED
LDA ARG_SIGN ; NORMALLY, ARG MUST BE POSITIVE
BPL L_FPWRT_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 L_FPWRT_2 ; NOT INTEGRAL, WILL CAUSE ERROR LATER
TYA ; MAKE ARG SIGN + AS IT IS MOVED TO FAC
LDY CHARAC ; INTEGRAL, SO ALLOW NEGATIVE ARG
L_FPWRT_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
LSR ; <<<LSR,BCC COULD BE MERELY BPL>>>
BCC RTS_18 ; NOT NEGATIVE, FINISHED
; NEGATIVE ARG, SO NEGATE RESULT
; --------------------------------
; NEGATE VALUE IN FAC
; --------------------------------
NEGOP LDA FAC ; IF FAC=0, NO NEED TO COMPLEMENT
BEQ RTS_18 ; YES, FAC=0
LDA FAC_SIGN ; NO, SO TOGGLE SIGN
EOR #$FF
STA FAC_SIGN
RTS_18 RTS
; --------------------------------
CON_LOG_E ASM_DATA($81,$38,$AA,$3B,$29) ; LOG(E) TO BASE 2
; --------------------------------
POLY_EXP ASM_DATA(7) ; ( # OF TERMS IN POLYNOMIAL) - 1
ASM_DATA($71,$34,$58,$3E,$56) ; (LOG(2)^7)/8!
ASM_DATA($74,$16,$7E,$B3,$1B) ; (LOG(2)^6)/7!
ASM_DATA($77,$2F,$EE,$E3,$85) ; (LOG(2)^5)/6!
ASM_DATA($7A,$1D,$84,$1C,$2A) ; (LOG(2)^4)/5!
ASM_DATA($7C,$63,$59,$58,$0A) ; (LOG(2)^3)/4!
ASM_DATA($7E,$75,$FD,$E7,$C6) ; (LOG(2)^2)/3!
ASM_DATA($80,$31,$72,$18,$10) ; LOG(2)/2!
ASM_DATA($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 FAC_EXTENSION ; NON-STANDARD ROUNDING HERE
ADC #$50 ; ROUND UP IF EXTENSION > $AF
BCC L_EXP_1 ; NO, DON'T ROUND UP
JSR INCREMENT_MANTISSA
L_EXP_1 STA ARG_EXTENSION ; STRANGE VALUE
JSR MAF ; COPY FAC INTO ARG
LDA FAC ; MAXIMUM EXPONENT IS < 128
CMP #$88 ; WITHIN RANGE?
BCC L_EXP_3 ; YES
L_EXP_2 JSR OUTOFRNG ; OVERFLOW IF +, RETURN 0.0 IF -
L_EXP_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 L_EXP_2 ; OVERFLOW
SEC ; BACK OFF TO NORMAL BIAS
SBC #1 ;
PHA ; SAVE EXPONENT
; --------------------------------
LDX #5 ; SWAP ARG AND FAC
L_EXP_4 LDA ARG,X ; <<< WHY SWAP? IT IS DOING >>>
LDY FAC,X ; <<< -(A-B) WHEN (B-A) IS THE >>>
STA FAC,X ; <<< SAME THING! >>>
STY ARG,X
DEX
BPL L_EXP_4
LDA ARG_EXTENSION
STA FAC_EXTENSION
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
JSR ADD_EXPONENTS_1
RTS ; <<< WASTED BYTE HERE, COULD HAVE >>>
; <<< JUST USED "JMP ADD.EXPO..." >>>
; --------------------------------
; 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 L_SERMAIN_1
INC SERPNT+1
L_SERMAIN_1 STA SERPNT
LDY SERPNT+1
L_SERMAIN_2 JSR FMULT ; ACCUMULATE SERIES TERMS
LDA SERPNT ; BUMP PNTR TO NEXT COEFFICIENT
LDY SERPNT+1
CLC
ADC #5
BCC L_SERMAIN_3
INY
L_SERMAIN_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 L_SERMAIN_2 ; THEN ADD ANOTHER TERM
RTS_19 RTS ; FINISHED
; --------------------------------
CON_RND_1 ASM_DATA($98,$35,$44,$7A) ; <<< THESE ARE MISSING ONE BYTE >>>
CON_RND_2 ASM_DATA($68,$28,$B1,$46) ; <<< FOR FP VALUES >>>
; --------------------------------
; "RND" FUNCTION
; --------------------------------
RND JSR SIGN ; REDUCE ARGUMENT TO -1, 0, OR +1
TAX ; SAVE ARGUMENT
BMI L_RND_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 RTS_19 ; =0, RETURN SEED UNCHANGED
LDA #<CON_RND_1 ; VERY POOR RND ALGORITHM
LDY #>CON_RND_1
JSR FMULT
LDA #<CON_RND_2 ; ALSO, CONSTANTS ARE TRUNCATED
LDY #>CON_RND_2 ; <<<THIS DOES NOTHING, DUE TO >>>
; <<<SMALL EXPONENT >>>
JSR FADD
L_RND_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 FAC_SIGN ;
LDA FAC ; A SOMEWHAT RANDOM EXTENSION
STA FAC_EXTENSION
LDA #$80 ; EXPONENT TO MAKE VALUE < 1.0
STA FAC
JSR NORMALIZE_FAC_2
LDX #<RNDSEED ; MOVE FAC TO RND SEED
LDY #>RNDSEED
GO_MOVMF JMP STORE_FACDB_YX_ROUNDED
; --------------------------------
; --------------------------------
; "COS" FUNCTION
; --------------------------------
COS LDA #<CON_PI_HALF ; COS(X)=SIN(X + PI/2)
LDY #>CON_PI_HALF
JSR FADD
; --------------------------------
; "SIN" FUNCTION
; --------------------------------
SIN JSR COPY_FAC_TO_ARG_ROUNDED
LDA #<CON_PI_DOUB ; REMOVE MULTIPLES OF 2*PI
LDY #>CON_PI_DOUB ; BY DIVIDING AND SAVING
LDX ARG_SIGN ; THE FRACTIONAL PART
JSR DIV ; USE SIGN OF ARGUMENT
JSR COPY_FAC_TO_ARG_ROUNDED
JSR INT ; TAKE INTEGER PART
LDA #0 ; <<< WASTED LINES, BECAUSE FSUBT >>>
STA SGNCPR ; <<< CHANGES SGNCPR AGAIN >>>
JSR FSUBT ; SUBTRACT TO GET FRACTIONAL PART
; --------------------------------
; (FAC) = ANGLE AS A FRACTION OF A FULL CIRCLE
;
; NOW FOLD THE RANGE INTO A QUARTER CIRCLE
;
; <<< THERE ARE MUCH SIMPLER WAYS TO DO THIS >>>
; --------------------------------
LDA #<QUARTER ; 1/4 - FRACTION MAKES
LDY #>QUARTER ; -3/4 <= FRACTION < 1/4
JSR FSUB ;
LDA FAC_SIGN ; TEST SIGN OF RESULT
PHA ; SAVE SIGN FOR LATER UNFOLDING
BPL SIN_1 ; ALREADY 0...1/4
JSR FADDH ; ADD 1/2 TO SHIFT TO -1/4...1/2
LDA FAC_SIGN ; TEST SIGN
BMI SIN_2 ; -1/4...0
; 0...1/2
LDA SIGNFLG ; SIGNFLG INITIALIZED = 0 IN "TAN"
EOR #$FF ; FUNCTION
STA SIGNFLG ; "TAN" IS ONLY USER OF SIGNFLG TOO
; --------------------------------
; IF FALL THRU, RANGE IS 0...1/2
; IF BRANCH HERE, RANGE IS 0...1/4
; --------------------------------
SIN_1 JSR NEGOP
; --------------------------------
; IF FALL THRU, RANGE IS -1/2...0
; IF BRANCH HERE, RANGE IS -1/4...0
; --------------------------------
SIN_2 LDA #<QUARTER ; ADD 1/4 TO SHIFT RANGE
LDY #>QUARTER ; TO -1/4...1/4
JSR FADD ;
PLA ; GET SAVED SIGN FROM ABOVE
BPL L_SIN_2_1 ;
JSR NEGOP ; MAKE RANGE 0...1/4
L_SIN_2_1 LDA #<POLY_SIN ; DO STANDARD SIN SERIES
LDY #>POLY_SIN ;
JMP POLYNOMIAL_ODD ;
; --------------------------------
; "TAN" FUNCTION
;
; COMPUTE TAN(X) = SIN(X) / COS(X)
; --------------------------------
TAN JSR STORE_FAC_IN_TEMP1_ROUNDED
LDA #0 ; SIGNFLG WILL BE TOGGLED IF 2ND OR 3RD
STA SIGNFLG ; QUADRANT
JSR SIN ; GET SIN(X)
LDX #<TEMP3 ; SAVE SIN(X) IN TEMP3
LDY #>TEMP3 ;
JSR GO_MOVMF ; <<<FUNNY WAY TO CALL MOVMF! >>>
LDA #<TEMP1 ; RETRIEVE X
LDY #>TEMP1 ;
JSR LOAD_FAC_FROM_YA
LDA #0 ; AND COMPUTE COS(X)
STA FAC_SIGN ;
LDA SIGNFLG ;
JSR TAN_1 ; WEIRD & DANGEROUS WAY TO GET INTO SIN
LDA #<TEMP3 ; NOW FORM SIN/COS
LDY #>TEMP3 ;
JMP FDIV ;
; --------------------------------
TAN_1 PHA ; SHAME, SHAME!
JMP SIN_1
; --------------------------------
CON_PI_HALF ASM_DATA($81,$49,$0F,$DA,$A2)
CON_PI_DOUB ASM_DATA($83,$49,$0F,$DA,$A2)
QUARTER ASM_DATA($7F,$00,$00,$00,$00)
; --------------------------------
POLY_SIN ASM_DATA(5) ; POWER OF POLYNOMIAL
ASM_DATA($84,$E6,$1A,$2D,$1B) ; (2PI)^11/11!
ASM_DATA($86,$28,$07,$FB,$F8) ; (2PI)^9/9!
ASM_DATA($87,$99,$68,$89,$01) ; (2PI)^7/7!
ASM_DATA($87,$23,$35,$DF,$E1) ; (2PI)^5/5!
ASM_DATA($86,$A5,$5D,$E7,$28) ; (2PI)^3/3!
ASM_DATA($83,$49,$0F,$DA,$A2) ; 2PI
; --------------------------------
; <<< NEXT TEN BYTES ARE NEVER REFERENCED >>>
; OBFUSCATED "MICROSOFT!" BY BILL GATES
; (REVERSED, HIGH BIT SET, XOR 7)
; --------------------------------
define(`GATES_OBFUSCATE',
`STR_FORCHAR(__,STR_REVERSE($1),`ASM_DATA(HICHAR(__)^7) NL()')')
GATES_OBFUSCATE(`MICROSOFT!')
; --------------------------------
; "ATN" FUNCTION
; --------------------------------
ATN LDA FAC_SIGN ; FOLD THE ARGUMENT RANGE FIRST
PHA ; SAVE SIGN FOR LATER UNFOLDING
BPL L_ATN_1 ; .GE. 0
JSR NEGOP ; .LT. 0, SO COMPLEMENT
L_ATN_1 LDA FAC ; IF .GE. 1, FORM RECIPROCAL
PHA ; SAVE FOR LATER UNFOLDING
CMP #$81 ; (EXPONENT FOR .GE. 1
BCC L_ATN_2 ; X < 1
LDA #<CON_ONE ; FORM 1/X
LDY #>CON_ONE
JSR FDIV
; --------------------------------
; 0 <= X <= 1
; 0 <= ATN(X) <= PI/8
; --------------------------------
L_ATN_2 LDA #<POLY_ATN ; COMPUTE POLYNOMIAL APPROXIMATION
LDY #>POLY_ATN
JSR POLYNOMIAL_ODD
PLA ; START TO UNFOLD
CMP #$81 ; WAS IT .GE. 1?
BCC L_ATN_3 ; NO
LDA #<CON_PI_HALF ; YES, SUBTRACT FROM PI/2
LDY #>CON_PI_HALF ;
JSR FSUB ;
L_ATN_3 PLA ; WAS IT NEGATIVE?
BPL RTS_20 ; NO
JMP NEGOP ; YES, COMPLEMENT
RTS_20 RTS
; --------------------------------
POLY_ATN ASM_DATA(11) ; POWER OF POLYNOMIAL
ASM_DATA($76,$B3,$83,$BD,$D3)
ASM_DATA($79,$1E,$F4,$A6,$F5)
ASM_DATA($7B,$83,$FC,$B0,$10)
ASM_DATA($7C,$0C,$1F,$67,$CA)
ASM_DATA($7C,$DE,$53,$CB,$C1)
ASM_DATA($7D,$14,$64,$70,$4C)
ASM_DATA($7D,$B7,$EA,$51,$7A)
ASM_DATA($7D,$63,$30,$88,$7E)
ASM_DATA($7E,$92,$44,$99,$3A)
ASM_DATA($7E,$4C,$CC,$91,$C7)
ASM_DATA($7F,$AA,$AA,$AA,$13)
ASM_DATA($81,$00,$00,$00,$00)
; --------------------------------
; 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 L_GENERIC_CHRGET_1
INC TXTPTR+1
L_GENERIC_CHRGET_1 LDA $EA60 ; <<< ACTUAL ADDRESS FILLED IN LATER >>>
CMP #LOCHAR(`:') ; EOS, ALSO TOP OF NUMERIC RANGE
BCS L_GENERIC_CHRGET_2 ; NOT NUMBER, MIGHT BE EOS
CMP #LOCHAR(` ') ; IGNORE BLANKS
BEQ GENERIC_CHRGET
SEC ; TEST FOR NUMERIC RANGE IN WAY THAT
SBC #LOCHAR(`0') ; CLEARS CARRY IF CHAR IS DIGIT
SEC ; AND LEAVES CHAR IN A-REG
SBC #$D0
L_GENERIC_CHRGET_2 RTS
; --------------------------------
; INITIAL VALUE FOR RANDOM NUMBER, ALSO COPIED
; IN ALONG WITH CHRGET, BUT ERRONEOUSLY:
; <<< THE LAST BYTE IS NOT COPIED >>>
; --------------------------------
ASM_DATA($80,$4F,$C7,$52,$58) ; APPROX. = L_GENERIC_CHRGET_811635157
GENERIC_END
; --------------------------------
COLD_START
LDX #$FF ; SET DIRECT MODE FLAG
STX CURLIN+1 ;
LDX #$FB ; SET STACK POINTER, LEAVING ROOM FOR
TXS ; LINE BUFFER DURING PARSING
LDA #<COLD_START ; SET RESTART TO COLD.START
LDY #>COLD_START ; UNTIL COLDSTART IS COMPLETED
STA GOWARM+1 ;
STY GOWARM+2 ;
STA GOSTROUT+1 ; ALSO SECOND USER VECTOR...
STY GOSTROUT+2 ; ..WE SIMPLY MUST FINISH COLD.START!
JSR NORMAL ; SET NORMAL DISPLAY MODE
LDA #$4C ; "JMP" OPCODE FOR 4 VECTORS
STA GOWARM ; WARM START
STA GOSTROUT ; ANYONE EVER USE THIS ONE?
STA JMPADRS ; USED BY FUNCTIONS (JSR JMPADRS)
STA USR ; "USR" FUNCTION VECTOR
LDA #<IQERR ; POINT "USR" TO ILLEGAL QUANTITY
LDY #>IQERR ; ERROR, UNTIL USER SETS IT UP
STA USR+1
STY USR+2
; --------------------------------
; 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
L_COLD_START_1 LDA GENERIC_CHRGET-1,X
STA CHRGET-1,X
STX SPEEDZ ; ON LAST PASS STORES $01)
DEX
BNE L_COLD_START_1
; --------------------------------
STX TRCFLG ; X=0, TURN OFF TRACING
TXA ; A=0
STA SHIFT_SIGN_EXT
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 INPUT_BUFFER-3
STA INPUT_BUFFER-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
L_COLD_START_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 L_COLD_START_3 ; NOT RAM HERE
EOR #$FF ; RESTORE ORIGINAL VALUE
STA (LINNUM),Y ;
CMP (LINNUM),Y ; DID IT TRACK AGAIN?
BEQ L_COLD_START_2 ; YES, STILL IN RAM
L_COLD_START_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 L_COLD_START_4 ;
INC TXTTAB+1 ;
L_COLD_START_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 GOSTROUT+1
STY GOSTROUT+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.
; --------------------------------
; "IN#" STATEMENT
;
; NOTE: NO CHECK FOR VALID SLOT #, AS LONG
; AS VALUE IS < 256 IT IS ACCEPTED.
; MONITOR MASKS VALUE TO 4 BITS (0-15).
; --------------------------------
IN_NUMBER
JSR GETBYT ; GET SLOT NUMBER IN X-REG
TXA ; MONITOR WILL INSTALL IN VECTOR
JMP MON_INPORT ; AT $38,39.
; --------------------------------
; "PR#" STATEMENT
;
; NOTE: NO CHECK FOR VALID SLOT #, AS LONG
; AS VALUE IS < 256 IT IS ACCEPTED.
; MONITOR MASKS VALUE TO 4 BITS (0-15).
; --------------------------------
PR_NUMBER
JSR GETBYT ; GET SLOT NUMBER IN X-REG
TXA ; MONITOR WILL INSTALL IN VECTOR
JMP MON_OUTPORT ; AT $36,37
; --------------------------------
; GET TWO VALUES < 48, WITH COMMA SEPARATOR
;
; CALLED FOR "PLOT X,Y"
; AND "HLIN A,B AT Y"
; AND "VLIN A,B AT X"
;
; --------------------------------
PLOTFNS
JSR GETBYT ; GET FIRST VALUE IN X-REG
CPX #48 ; MUST BE < 48
BCS GOERR ; TOO LARGE
STX FIRST ; SAVE FIRST VALUE
LDA #LOCHAR(`,') ; MUST HAVE A COMMA
JSR SYNCHR ;
JSR GETBYT ; GET SECOND VALUE IN X-REG
CPX #48 ; MUST BE < 48
BCS GOERR ; TOO LARGE
STX MON_H2 ; SAVE SECOND VALUE
STX MON_V2 ;
RTS ; SECOND VALUE STILL IN X-REG
; --------------------------------
GOERR JMP IQERR ; ILLEGAL QUANTITY ERROR
; --------------------------------
; GET "A,B AT C" VALUES FOR "HLIN" AND "VLIN"
;
; PUT SMALLER OF (A,B) IN FIRST,
; AND LARGER OF (A,B) IN H2 AND V2.
; RETURN WITH (X) = C-VALUE.
; --------------------------------
LINCOOR
JSR PLOTFNS ; GET A,B VALUES
CPX FIRST ; IS A < B?
BCS L_LINCOOR_1 ; YES, IN RIGHT ORDER
LDA FIRST ; NO, INTERCHANGE THEM
STA MON_H2 ;
STA MON_V2 ;
STX FIRST ;
L_LINCOOR_1 LDA #TOKENDB ; MUST HAVE "AT" NEXT
JSR SYNCHR ;
JSR GETBYT ; GET C-VALUE IN X-REG
CPX #48 ; MUST BE < 48
BCS GOERR ; TOO LARGE
RTS ; C-VALUE IN X-REG
; --------------------------------
; "PLOT" STATEMENT
; --------------------------------
PLOT JSR PLOTFNS ; GET X,Y VALUES
TXA ; Y-COORD TO A-REG FOR MONITOR
LDY FIRST ; X-COORD TO Y-YEG FOR MONITOR
CPY #40 ; X-COORD MUST BE < 40
BCS GOERR ; X-COORD IS TOO LARGE
JMP MON_PLOT ; PLOT!
; --------------------------------
; "HLIN" STATEMENT
; --------------------------------
HLIN JSR LINCOOR ; GET "A,B AT C"
TXA ; Y-COORD IN A-REG
LDY MON_H2 ; RIGHT END OF LINE
CPY #40 ; MUST BE < 40
BCS GOERR ; TOO LARGE
LDY FIRST ; LEFT END OF LINE IN Y-REG
JMP MON_HLINE ; LET MONITOR DRAW LINE
; --------------------------------
; "VLIN" STATEMENT
; --------------------------------
VLIN JSR LINCOOR ; GET "A,B AT C"
TXA ; X-COORD IN Y-REG
TAY ;
CPY #40 ; X-COORD MUST BE < 40
BCS GOERR ; TOO LARGE
LDA FIRST ; TOP END OF LINE IN A-REG
JMP MON_VLINE ; LET MONITOR DRAW LINE
; --------------------------------
; "COLOR=" STATEMENT
; --------------------------------
COLOR JSR GETBYT ; GET COLOR VALUE IN X-REG
TXA ;
JMP MON_SETCOL ; LET MONITOR STORE COLOR
; --------------------------------
; "VTAB" STATEMENT
; --------------------------------
VTAB JSR GETBYT ; GET LINE # IN X-REG
DEX ; CONVERT TO ZERO BASE
TXA ;
CMP #24 ; MUST BE 0-23
BCS GOERR ; TOO LARGE, OR WAS "VTAB 0"
JMP MON_TABV ; LET MONITOR COMPUTE BASE
; --------------------------------
; "SPEED=" STATEMENT
; --------------------------------
SPEED JSR GETBYT ; GET SPEED SETTING IN X-REG
TXA ; SPEEDZ = $100-SPEED
EOR #$FF ; SO "SPEED=255" IS FASTEST
TAX ;
INX ;
STX SPEEDZ ;
RTS ;
; --------------------------------
; "TRACE" STATEMENT
; SET SIGN BIT IN TRCFLG
; --------------------------------
TRACE SEC ;
ASM_DATA($90) ; FAKE BCC TO SKIP NEXT OPCODE
; --------------------------------
; "NOTRACE" STATEMENT
; CLEAR SIGN BIT IN TRCFLG
; --------------------------------
NOTRACE ;
CLC ;
ROR TRCFLG ; SHIFT CARRY INTO TRCFLG
RTS ;
; --------------------------------
; "NORMAL" STATEMENT
; --------------------------------
NORMAL LDA #$FF ; SET INVFLG = $FF
BNE N_I_ ; AND FLASH.BIT = $00
; --------------------------------
; "INVERSE" STATEMENT
; --------------------------------
INVERSE ;
LDA #$3F ; SET INVFLG = $3F
N_I_ LDX #0 ; AND FLASH.BIT = $00
N_I_F_ STA MON_INVFLG
STX FLASH_BIT
RTS
; --------------------------------
; "FLASH" STATEMENT
; --------------------------------
FLASH LDA #$7F ; SET INVFLG = $7F
LDX #$40 ; AND FLASH.BIT = $40
BNE N_I_F_ ; ...ALWAYS
; --------------------------------
; "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
; <<<COULD ALSO HAVE DONE TXS >>>
; <<<HERE; SEE ONERR CORRECTION>>>
; <<<IN APPLESOFT MANUAL. >>>
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 ;
; <<< ONERR CORRECTION IN MANUAL IS EASILY >>>
; <<< BY "CALL -3288", WHICH IS $F328 HERE >>>
LDX ERRSTK ; RETRIEVE STACK PNTR AS IT WAS
TXS ; BEFORE STATEMENT SCANNED
JMP NEWSTT ; DO STATEMENT AGAIN
; --------------------------------
JSYN JMP SYNERR ;
; --------------------------------
; "DEL" STATEMENT
; --------------------------------
DEL BCS JSYN ; ERROR IF # NOT SPECIFIED
LDX PRGEND ;
STX VARTAB ;
LDX PRGEND+1 ;
STX VARTAB+1 ;
JSR LINGET ; GET BEGINNING OF RANGE
JSR FNDLIN ; FIND THIS LINE OR NEXT
LDA LOWTR ; UPPER PORTION OF PROGRAM WILL
STA DEST ; BE MOVED DOWN TO HERE
LDA LOWTR+1 ;
STA DEST+1 ;
LDA #LOCHAR(`,') ; MUST HAVE A COMMA NEXT
JSR SYNCHR ;
JSR LINGET ; GET END RANGE
; (DOES NOTHING IF END RANGE
; IS NOT SPECIFIED)
INC LINNUM ; POINT ONE PAST IT
BNE L_DEL_1 ;
INC LINNUM+1 ;
L_DEL_1 JSR FNDLIN ; FIND START LINE AFTER SPECIFIED LINE
LDA LOWTR ; WHICH IS BEGINNING OF PORTION
CMP DEST ; TO BE MOVED DOWN
LDA LOWTR+1 ; IT MUST BE ABOVE THE TARGET
SBC DEST+1 ;
BCS L_DEL_2 ; IT IS OKAY
RTS ; NOTHING TO DELETE
L_DEL_2 LDY #0 ; MOVE UPPER PORTION DOWN NOW
L_DEL_3 LDA (LOWTR),Y ; SOURCE . . .
STA (DEST),Y ; ...TO DESTINATION
INC LOWTR ; BUMP SOURCE PNTR
BNE L_DEL_4 ;
INC LOWTR+1 ;
L_DEL_4 INC DEST ; BUMP DESTINATION PNTR
BNE L_DEL_5 ;
INC DEST+1 ;
L_DEL_5 LDA VARTAB ; REACHED END OF PROGRAM YET?
CMP LOWTR ;
LDA VARTAB+1 ;
SBC LOWTR+1 ;
BCS L_DEL_3 ; NO, KEEP MOVING
LDX DEST+1 ; STORE NEW END OF PROGRAM
LDY DEST ; MUST SUBTRACT 1 FIRST
BNE L_DEL_6 ;
DEX ;
L_DEL_6 DEY ;
STX VARTAB+1 ;
STY VARTAB ;
JMP FIX_LINKS ; RESET LINKS AFTER A DELETE
; --------------------------------
; "GR" STATEMENT
; --------------------------------
GR LDA SW_LORES
LDA SW_MIXSET
JMP MON_SETGR
; --------------------------------
; "TEXT" STATEMENT
; --------------------------------
TEXT LDA SW_LOWSCR ; JMP $FB36 WOULD HAVE
JMP MON_SETTXT ; DONE BOTH OF THESE
; <<< BETTER CODE WOULD BE: >>>
; <<< LDA SW.MIXSET >>>
; <<< JMP $FB33 >>>
; --------------------------------
; "STORE" STATEMENT
; --------------------------------
STORE JSR GETARYPT ; GET ADDRESS OF ARRAY TO BE SAVED
LDY #3 ; FORWARD OFFSET - 1 IS SIZE OF
LDA (LOWTR),Y ; THIS ARRAY
TAX
DEY
LDA (LOWTR),Y
SBC #1
BCS L_STORE_1
DEX
L_STORE_1 STA LINNUM
STX LINNUM+1
JSR MON_WRITE
JSR TAPEPNT
JMP MON_WRITE
; --------------------------------
; "RECALL" STATEMENT
; --------------------------------
RECALL JSR GETARYPT ; FIND ARRAY IN MEMORY
JSR MON_READ ; READ HEADER
LDY #2 ; MAKE SURE THE NEW DATA FITS
LDA (LOWTR),Y ;
CMP LINNUM ;
INY ;
LDA (LOWTR),Y ;
SBC LINNUM+1 ;
BCS L_RECALL_1 ; IT FITS
JMP MEMERR ; DOESN'T FIT
L_RECALL_1 JSR TAPEPNT ; READ THE DATA
JMP MON_READ ;
; --------------------------------
; "HGR" AND "HGR2" STATEMENTS
; --------------------------------
HGR2 BIT SW_HISCR ; SELECT PAGE 2 ($4000-5FFF)
BIT SW_MIXCLR ; DEFAULT TO FULL SCREEN
LDA #>$4000 ; SET STARTING PAGE FOR HIRES
BNE SETHPG ; ...ALWAYS
HGR LDA #>$2000 ; SET STARTING PAGE FOR HIRES
BIT SW_LOWSCR ; SELECT PAGE 1 ($2000-3FFF)
BIT SW_MIXSET ; DEFAULT TO MIXED SCREEN
SETHPG STA HGR_PAGE ; BASE PAGE OF HIRES BUFFER
LDA SW_HIRES ; TURN ON HIRES
LDA SW_TXTCLR ; TURN ON GRAPHICS
; --------------------------------
; CLEAR SCREEN
; --------------------------------
HCLR LDA #0 ; SET FOR BLACK BACKGROUND
STA HGR_BITS
; --------------------------------
; FILL SCREEN WITH (HGR.BITS)
; --------------------------------
BKGND LDA HGR_PAGE ; PUT BUFFER ADDRESS IN HGR.SHAPE
STA HGR_SHAPE+1
LDY #0
STY HGR_SHAPE
L_BKGND_1 LDA HGR_BITS ; COLOR BYTE
STA (HGR_SHAPE),Y ; CLEAR HIRES TO HGR.BITS
JSR COLOR_SHIFT ; CORRECT FOR COLOR SHIFT
INY ; (SLOWS CLEAR BY FACTOR OF 2)
BNE L_BKGND_1
INC HGR_SHAPE+1
LDA HGR_SHAPE+1
AND #$1F ; DONE? ($40 OR$60)
BNE L_BKGND_1 ; NO
RTS ; YES, RETURN
; --------------------------------
; SET THE HIRES CURSOR POSITION
;
; (Y,X) = HORIZONTAL COORDINATE (0-279)
; (A) = VERTICAL COORDINATE (0-191)
; --------------------------------
HPOSN STA HGR_Y ; SAVE Y- AND X-POSITIONS
STX HGR_X ;
STY HGR_X+1 ;
PHA ; Y-POS ALSO ON STACK
AND #$C0 ; CALCULATE BASE ADDRESS FOR Y-POS
STA MON_GBASL ; FOR Y=ABCDEFGH
LSR ; GBASL=ABAB0000
LSR ;
ORA MON_GBASL ;
STA MON_GBASL ;
PLA ; (A) (GBASH) (GBASL)
STA MON_GBASH ; ?-ABCDEFGH ABCDEFGH ABAB0000
ASL ; A-BCDEFGH0 ABCDEFGH ABAB0000
ASL ; B-CDEFGH00 ABCDEFGH ABAB0000
ASL ; C-DEFGH000 ABCDEFGH ABAB0000
ROL MON_GBASH ; A-DEFGH000 BCDEFGHC ABAB0000
ASL ; D-EFGH0000 BCDEFGHC ABAB0000
ROL MON_GBASH ; B-EFGH0000 CDEFGHCD ABAB0000
ASL ; E-FGH00000 CDEFGHCD ABAB0000
ROR MON_GBASL ; 0-FGH00000 CDEFGHCD EABAB000
LDA MON_GBASH ; 0-CDEFGHCD CDEFGHCD EABAB000
AND #$1F ; 0-000FGHCD CDEFGHCD EABAB000
ORA HGR_PAGE ; 0-PPPFGHCD CDEFGHCD EABAB000
STA MON_GBASH ; 0-PPPFGHCD PPPFGHCD EABAB000
TXA ; DIVIDE X-POS BY 7 FOR INDEX FROM BASE
CPY #0 ; IS X-POS < 256?
BEQ L_HPOSN_2 ; YES
LDY #35 ; NO: 256/7 = 36 REM 4
; CARRY=1, SO ADC #4 IS TOO LARGE;
; HOWEVER, ADC #4 CLEARS CARRY
; WHICH MAKES SBC #7 ONLY -6
; BALANCING IT OUT.
ADC #4 ; FOLLOWING INY MAKES Y=36
L_HPOSN_1 INY
L_HPOSN_2 SBC #7
BCS L_HPOSN_1
STY HGR_HORIZ ; HORIZONTAL INDEX
TAX ; USE REMAINDER-7 TO LOOK UP THE
LDA MSKTBL-$100+7,X ; BIT MASK
STA MON_HMASK
TYA ; QUOTIENT GIVES BYTE INDEX
LSR ; ODD OR EVEN COLUMN?
LDA HGR_COLOR ; IF ON ODD BYTE (CARRY SET)
STA HGR_BITS ; THEN ROTATE BITS
BCS COLOR_SHIFT ; ODD COLUMN
RTS ; EVEN COLUMN
; --------------------------------
; PLOT A DOT
;
; (Y,X) = HORIZONTAL POSITION
; (A) = VERTICAL POSITION
; --------------------------------
HPLOT0 JSR HPOSN
LDA HGR_BITS ; CALCULATE BIT POSN IN GBAS,
EOR (MON_GBASL),Y ; HGR.HORIZ, AND HMASK FROM
AND MON_HMASK ; Y-COOR IN A-REG,
EOR (MON_GBASL),Y ; X-COOR IN X,Y REGS.
STA (MON_GBASL),Y ; FOR ANY 1-BITS, SUBSTITUTE
RTS ; CORRESPONDING BIT OF HGR.BITS
; --------------------------------
; MOVE LEFT OR RIGHT ONE PIXEL
;
; IF STATUS IS +, MOVE RIGHT; IF -, MOVE LEFT
; IF ALREADY AT LEFT OR RIGHT EDGE, WRAP AROUND
;
; REMEMBER BITS IN HI-RES BYTE ARE BACKWARDS ORDER:
; BYTE N BYTE N+1
; S7654321 SEDCBA98
; --------------------------------
MOVE_LEFT_OR_RIGHT
BPL MOVE_RIGHT ; + MOVE RIGHT, - MOVE LEFT
LDA MON_HMASK ; MOVE LEFT ONE PIXEL
LSR ; SHIFT MASK RIGHT, MOVES DOT LEFT
BCS LR_2 ; ...DOT MOVED TO NEXT BYTE
EOR #$C0 ; MOVE SIGN BIT BACK WHERE IT WAS
LR_1 STA MON_HMASK ; NEW MASK VALUE
RTS ;
LR_2 DEY ; MOVED TO NEXT BYTE, SO DECR INDEX
BPL LR_3 ; STILL NOT PAST EDGE
LDY #39 ; OFF LEFT EDGE, SO WRAP AROUND SCREEN
LR_3 LDA #$C0 ; NEW HMASK, RIGHTMOST BIT ON SCREEN
LR_4 STA MON_HMASK ; NEW MASK AND INDEX
STY HGR_HORIZ ;
LDA HGR_BITS ; ALSO NEED TO ROTATE COLOR
; --------------------------------
COLOR_SHIFT
ASL ; ROTATE LOW-ORDER 7 BITS
CMP #$C0 ; OF HGR.BITS ONE BIT POSN.
BPL L_COLOR_SHIFT_1
LDA HGR_BITS
EOR #$7F
STA HGR_BITS
L_COLOR_SHIFT_1 RTS
; --------------------------------
; MOVE RIGHT ONE PIXEL
; IF ALREADY AT RIGHT EDGE, WRAP AROUND
; --------------------------------
MOVE_RIGHT
LDA MON_HMASK
ASL ; SHIFTING BYTE LEFT MOVES PIXEL RIGHT
EOR #$80 ;
; ORIGINAL: C0 A0 90 88 84 82 81
; SHIFTED: 80 40 20 10 08 02 01
; EOR #$80: 00 C0 A0 90 88 84 82
BMI LR_1 ; FINISHED
LDA #$81 ; NEW MASK VALUE
INY ; MOVE TO NEXT BYTE RIGHT
CPY #40 ; UNLESS THAT IS TOO FAR
BCC LR_4 ; NOT TOO FAR
LDY #0 ; TOO FAR, SO WRAP AROUND
BCS LR_4 ; ...ALWAYS
; --------------------------------
; --------------------------------
; "XDRAW" ONE BIT
; --------------------------------
LRUDX1 CLC ; C=0 MEANS NO 90 DEGREE ROTATION
LRUDX2 LDA HGR_DX+1 ; C=1 MEANS ROTATE 90 DEGREES
AND #4 ; IF BIT2=0 THEN DON'T PLOT
BEQ LRUD4 ; YES, DO NOT PLOT
LDA #$7F ; NO, LOOK AT WHAT IS ALREADY THERE
AND MON_HMASK
AND (MON_GBASL),Y ; SCREEN BIT = 1?
BNE LRUD3 ; YES, GO CLEAR IT
INC HGR_COLLISIONS ; NO, COUNT THE COLLISION
LDA #$7F ; AND TURN THE BIT ON
AND MON_HMASK ;
BPL LRUD3 ; ...ALWAYS
; --------------------------------
; "DRAW" ONE BIT
; --------------------------------
LRUD1 CLC ; C=0 MEANS NO 90 DEGREE ROTATION
LRUD2 LDA HGR_DX+1 ; C=1 MEANS ROTATE
AND #4 ; IF BIT2=0 THEN DO NOT PLOT
BEQ LRUD4 ; DO NOT PLOT
LDA (MON_GBASL),Y
EOR HGR_BITS ; 1'S WHERE ANY BITS NOT IN COLOR
AND MON_HMASK ; LOOK AT JUST THIS BIT POSITION
BNE LRUD3 ; THE BIT WAS ZERO, SO PLOT IT
INC HGR_COLLISIONS ; BIT IS ALREADY 1; COUNT COLLSN
; --------------------------------
; TOGGLE BIT ON SCREEN WITH (A)
; --------------------------------
LRUD3 EOR (MON_GBASL),Y
STA (MON_GBASL),Y
; --------------------------------
; DETERMINE WHERE NEXT POINT WILL BE, AND MOVE THERE
; C=0 IF NO 90 DEGREE ROTATION
; C=1 ROTATES 90 DEGREES
; --------------------------------
LRUD4 LDA HGR_DX+1 ; CALCULATE THE DIRECTION TO MOVE
ADC HGR_QUADRANT
AND #3 ; WRAP AROUND THE CIRCLE
CON_03 = *-1 ; (( A CONSTANT ))
;
; 00 -- UP
; 01 -- DOWN
; 10 -- RIGHT
; 11 -- LEFT
;
CMP #2 ; C=0 IF 0 OR 1, C=1 IF 2 OR 3
ROR ; PUT C INTO SIGN, ODD/EVEN INTO C
BCS MOVE_LEFT_OR_RIGHT
; --------------------------------
MOVE_UP_OR_DOWN
BMI MOVE_DOWN ; SIGN FOR UP/DOWN SELECT_
; --------------------------------
; MOVE UP ONE PIXEL
; IF ALREADY AT TOP, GO TO BOTTOM
;
; REMEMBER: Y-COORD GBASH GBASL
; ABCDEFGH PPPFGHCD EABAB000
; --------------------------------
CLC ; MOVE UP
LDA MON_GBASH ; CALC. BASE ADDRESS OF PREV. LINE
BIT CON_1C ; LOOK AT BITS 000FGH00 IN GBASH
BNE L_MOVE_UP_OR_DOWN_5 ; SIMPLE, JUST FGH=FGH-1
; GBASH=PPP000CD, GBASL=EABAB000
ASL MON_GBASL ; WHAT IS "E"?
BCS L_MOVE_UP_OR_DOWN_3 ; E=1, THEN EFGH=EFGH-1
BIT CON_03 ; LOOK AT 000000CD IN GBASH
BEQ L_MOVE_UP_OR_DOWN_1 ; Y-POS IS AB000000 FORM
ADC #$1F ; CD <> 0, SO CDEFGH=CDEFGH-1
SEC ;
BCS L_MOVE_UP_OR_DOWN_4 ; ...ALWAYS
L_MOVE_UP_OR_DOWN_1 ADC #$23 ; ENOUGH TO MAKE GBASH=PPP11111 LATER
PHA ; SAVE FOR LATER
LDA MON_GBASL ; GBASL IS NOW ABAB0000 (AB=00,01,10)
ADC #$B0 ; 0000+1011=1011 AND CARRY CLEAR
; OR 0101+1011=0000 AND CARRY SET
; OR 1010+1011=0101 AND CARRY SET
BCS L_MOVE_UP_OR_DOWN_2 ; NO WRAP-AROUND NEEDED
ADC #$F0 ; CHANGE 1011 TO 1010 (WRAP-AROUND)
L_MOVE_UP_OR_DOWN_2 STA MON_GBASL ; FORM IS NOW STILL ABAB0000
PLA ; PARTIALLY MODIFIED GBASH
BCS L_MOVE_UP_OR_DOWN_4 ; ...ALWAYS
L_MOVE_UP_OR_DOWN_3 ADC #$1F ;
L_MOVE_UP_OR_DOWN_4 ROR MON_GBASL ; SHIFT IN E, TO GET EABAB000 FORM
L_MOVE_UP_OR_DOWN_5 ADC #$FC ; FINISH GBASH MODS
UD_1 STA MON_GBASH ;
RTS
; --------------------------------
CLC ; <<<NEVER USED>>>
; --------------------------------
; MOVE DOWN ONE PIXEL
; IF ALREADY AT BOTTOM, GO TO TOP
;
; REMEMBER: Y-COORD GBASH GBASL
; ABCDEFGH PPPFGHCD EABAB000
; --------------------------------
MOVE_DOWN
LDA MON_GBASH ; TRY IT FIRST, BY FGH=FGH+1
ADC #4 ; GBASH = PPPFGHCD
CON_04 = *-1 ; (( CONSTANT ))
BIT CON_1C ; IS FGH FIELD NOW ZERO?
BNE UD_1 ; NO, SO WE ARE FINISHED
; YES, RIPPLE THE CARRY AS HIGH
; AS NECESSARY
ASL MON_GBASL ; LOOK AT "E" BIT
BCC L_CON_04_2 ; NOW ZERO; MAKE IT 1 AND LEAVE
ADC #$E0 ; CARRY = 1, SO ADDS $E1
CLC ; IS "CD" NOT ZERO?
BIT CON_04 ; TESTS BIT 2 FOR CARRY OUT OF "CD"
BEQ L_CON_04_3 ; NO CARRY, FINISHED
; INCREMENT "AB" THEN
; 0000 --> 0101
; 0101 --> 1010
; 1010 --> WRAP AROUND TO LINE 0
LDA MON_GBASL ; 0000 0101 1010
ADC #$50 ; 0101 1010 1111
EOR #$F0 ; 1010 0101 0000
BEQ L_CON_04_1 ;
EOR #$F0 ; 0101 1010
L_CON_04_1 STA MON_GBASL ; NEW ABAB0000
LDA HGR_PAGE ; WRAP AROUND TO LINE ZERO OF GROUP
BCC L_CON_04_3 ; ...ALWAYS
L_CON_04_2 ADC #$E0
L_CON_04_3 ROR MON_GBASL
BCC UD_1 ; ...ALWAYS
; --------------------------------
; HLINRL IS NEVER CALLED BY APPLESOFT
;
; ENTER WITH: (A,X) = DX FROM CURRENT POINT
; (Y) = DY FROM CURRENT POINT
; --------------------------------
HLINRL PHA ; SAVE (A)
LDA #0 ; CLEAR CURRENT POINT SO HGLIN WILL
STA HGR_X ; ACT RELATIVELY
STA HGR_X+1 ;
STA HGR_Y ;
PLA ; RESTORE (A)
; --------------------------------
; DRAW LINE FROM LAST PLOTTED POINT TO (A,X),(Y)
;
; ENTER WITH: (A,X) = X OF TARGET POINT
; (Y) = Y OF TARGET POINT
; --------------------------------
HGLIN PHA ; COMPUTE DX = X- X0
SEC
SBC HGR_X
PHA
TXA
SBC HGR_X+1
STA HGR_QUADRANT ; SAVE DX SIGN (+ = RIGHT, - = LEFT)
BCS L_HGLIN_1 ; NOW FIND ABS (DX)
PLA ; FORMS 2'S COMPLEMENT
EOR #$FF
ADC #1
PHA
LDA #0
SBC HGR_QUADRANT
L_HGLIN_1 STA HGR_DX+1
STA HGR_E+1 ; INIT HGR.E TO ABS(X-X0)
PLA
STA HGR_DX
STA HGR_E
PLA
STA HGR_X ; TARGET X POINT
STX HGR_X+1 ;
TYA ; TARGET Y POINT
CLC ; COMPUTE DY = Y-HGR.Y
SBC HGR_Y ; AND SAVE -ABS(Y-HGR.Y)-1 IN HGR.DY
BCC L_HGLIN_2 ; (SO + MEANS UP, - MEANS DOWN)
EOR #$FF ; 2'S COMPLEMENT OF DY
ADC #$FE ;
L_HGLIN_2 STA HGR_DY ;
STY HGR_Y ; TARGET Y POINT
ROR HGR_QUADRANT ; SHIFT Y-DIRECTION INTO QUADRANT
SEC ; COUNT = DX -(-DY) = # OF DOTS NEEDED
SBC HGR_DX ;
TAX ; COUNTL IS IN X-REG
LDA #$FF
SBC HGR_DX+1
STA HGR_COUNT
LDY HGR_HORIZ ; HORIZONTAL INDEX
BCS MOVEX2 ; ...ALWAYS
; --------------------------------
; MOVE LEFT OR RIGHT ONE PIXEL
; (A) BIT 6 HAS DIRECTION
; --------------------------------
MOVEX ASL ; PUT BIT 6 INTO SIGN POSITION
JSR MOVE_LEFT_OR_RIGHT
SEC
; --------------------------------
; DRAW LINE NOW
; --------------------------------
MOVEX2 LDA HGR_E ; CARRY IS SET
ADC HGR_DY ; E = E-DELTY
STA HGR_E ; NOTE: DY IS (-DELTA Y)-1
LDA HGR_E+1 ; CARRY CLR IF HGR.E GOES NEGATIVE
SBC #0
L_MOVEX2_1 STA HGR_E+1
LDA (MON_GBASL),Y
EOR HGR_BITS ; PLOT A DOT
AND MON_HMASK
EOR (MON_GBASL),Y
STA (MON_GBASL),Y
INX ; FINISHED ALL THE DOTS?
BNE L_MOVEX2_2 ; NO
INC HGR_COUNT ; TEST REST OF COUNT
BEQ RTS_22 ; YES, FINISHED.
L_MOVEX2_2 LDA HGR_QUADRANT ; TEST DIRECTION
BCS MOVEX ; NEXT MOVE IS IN THE X DIRECTION
JSR MOVE_UP_OR_DOWN ; IF CLR, NEG, MOVE
CLC ; E = E+DX
LDA HGR_E
ADC HGR_DX
STA HGR_E
LDA HGR_E+1
ADC HGR_DX+1
BVC L_MOVEX2_1 ; ...ALWAYS
; --------------------------------
MSKTBL ASM_DATA(%10000001)
ASM_DATA(%10000010)
ASM_DATA(%10000100)
ASM_DATA(%10001000)
ASM_DATA(%10010000)
ASM_DATA(%10100000)
ASM_DATA(%11000000)
; --------------------------------
CON_1C ASM_DATA(%00011100) ; MASK FOR "FGH" BITS
; --------------------------------
; --------------------------------
; TABLE OF COS(90*X/16 DEGREES)*$100 - 1
; WITH ONE BYTE PRECISION, X=0 TO 16:
; --------------------------------
COSINE_TABLE ASM_DATA($FF,$FE,$FA,$F4,$EC,$E1,$D4,$C5)
ASM_DATA($B4,$A1,$8D,$78,$61,$49,$31,$18)
ASM_DATA($FF)
; --------------------------------
; HFIND -- CALCULATES CURRENT POSITION OF HI-RES CURSOR
; (NOT CALLED BY ANY APPLESOFT ROUTINE)
;
; CALCULATE Y-COORD FROM GBASL,H
; AND X-COORD FROM HORIZ AND HMASK
; --------------------------------
HFIND LDA MON_GBASL ; GBASL = EABAB000
ASL ; E INTO CARRY
LDA MON_GBASH ; GBASH = PPPFGHCD
AND #3 ; 000000CD
ROL ; 00000CDE
ORA MON_GBASL ; EABABCDE
ASL ; ABABCDE0
ASL ; BABCDE00
ASL ; ABCDE000
STA HGR_Y ; ALL BUT FGH
LDA MON_GBASH ; PPPFGHCD
LSR ; 0PPPFGHC
LSR ; 00PPPFGH
AND #7 ; 00000FGH
ORA HGR_Y ; ABCDEFGH
STA HGR_Y ; THAT TAKES CARE OF Y-COORDINATE!
LDA HGR_HORIZ ; X = 7*HORIZ + BIT POS. IN HMASK
ASL ; MULTIPLY BY 7
ADC HGR_HORIZ ; 3* SO FAR
ASL ; 6*
TAX ; SINCE 7* MIGHT NOT FIT IN 1 BYTE,
; WAIT TILL LATER FOR LAST ADD
DEX ;
LDA MON_HMASK ; NOW FIND BIT POSITION IN HMASK
AND #$7F ; ONLY LOOK AT LOW SEVEN
L_HFIND_1 INX ; COUNT A SHIFT
LSR ;
BNE L_HFIND_1 ; STILL IN THERE
STA HGR_X+1 ; ZERO TO HI-BYTE
TXA ; 6*HORIZ+LOG2(HMASK)
CLC ; ADD HORIZ ONE MORE TIME
ADC HGR_HORIZ ; 7*HORIZ+LOG2(HMASK)
BCC L_HFIND_2 ; UPPER BYTE = 0
INC HGR_X+1 ; UPPER BYTE = 1
L_HFIND_2 STA HGR_X ; STORE LOWER BYTE
RTS_22 RTS
; --------------------------------
; DRAW A SHAPE
;
; (Y,X) = SHAPE STARTING ADDRESS
; (A) = ROTATION (0-3F)
; --------------------------------
; APPLESOFT DOES NOT CALL DRAW0
; --------------------------------
DRAW0 STX HGR_SHAPE ; SAVE SHAPE ADDRESS
STY HGR_SHAPE+1
; --------------------------------
; APPLESOFT ENTERS HERE
; --------------------------------
DRAW1 TAX ; SAVE ROTATION (0-$3F)
LSR ; DIVIDE ROTATION BY 16 TO GET
LSR ; QUADRANT (0=UP, 1=RT, 2=DWN, 3=LFT)
LSR
LSR
STA HGR_QUADRANT
TXA ; USE LOW 4 BITS OF ROTATION TO INDEX
AND #$0F ; THE TRIG TABLE
TAX
LDY COSINE_TABLE,X ; SAVE COSINE IN HGR.DX
STY HGR_DX ;
EOR #$F ; AND SINE IN DY
TAX
LDY COSINE_TABLE+1,X
INY
STY HGR_DY
LDY HGR_HORIZ ; INDEX FROM GBASL,H TO BYTE WE'RE IN
LDX #0
STX HGR_COLLISIONS ; CLEAR COLLISION COUNTER
LDA (HGR_SHAPE,X) ; GET FIRST BYTE OF SHAPE DEFN
L_DRAW1_1 STA HGR_DX+1 ; KEEP SHAPE BYTE IN HGR.DX+1
LDX #$80 ; INITIAL VALUES FOR FRACTIONAL VECTORS
STX HGR_E ; L_DRAW1_5 IN COSINE COMPONENT
STX HGR_E+1 ; L_DRAW1_5 IN SINE COMPONENT
LDX HGR_SCALE ; SCALE FACTOR
L_DRAW1_2 LDA HGR_E ; ADD COSINE VALUE TO X-VALUE
SEC ; IF >= 1, THEN DRAW
ADC HGR_DX ;
STA HGR_E ; ONLY SAVE FRACTIONAL PART
BCC L_DRAW1_3 ; NO INTEGRAL PART
JSR LRUD1 ; TIME TO PLOT COSINE COMPONENT
CLC ;
L_DRAW1_3 LDA HGR_E+1 ; ADD SINE VALUE TO Y-VALUE
ADC HGR_DY ; IF >= 1, THEN DRAW
STA HGR_E+1 ; ONLY SAVE FRACTIONAL PART
BCC L_DRAW1_4 ; NO INTEGRAL PART
JSR LRUD2 ; TIME TO PLOT SINE COMPONENT
L_DRAW1_4 DEX ; LOOP ON SCALE FACTOR.
BNE L_DRAW1_2 ; STILL ON SAME SHAPE ITEM
LDA HGR_DX+1 ; GET NEXT SHAPE ITEM
LSR ; NEXT 3 BIT VECTOR
LSR ;
LSR ;
BNE L_DRAW1_1 ; MORE IN THIS SHAPE BYTE
INC HGR_SHAPE ; GO TO NEXT SHAPE BYTE
BNE L_DRAW1_5
INC HGR_SHAPE+1
L_DRAW1_5 LDA (HGR_SHAPE,X) ; NEXT BYTE OF SHAPE DEFINITION
BNE L_DRAW1_1 ; PROCESS IF NOT ZERO
RTS ; FINISHED
; --------------------------------
; XDRAW A SHAPE (SAME AS DRAW, EXCEPT TOGGLES SCREEN)
;
; (Y,X) = SHAPE STARTING ADDRESS
; (A) = ROTATION (0-3F)
; --------------------------------
; APPLESOFT DOES NOT CALL XDRAW0
; --------------------------------
XDRAW0 STX HGR_SHAPE ; SAVE SHAPE ADDRESS
STY HGR_SHAPE+1
; --------------------------------
; APPLESOFT ENTERS HERE
; --------------------------------
XDRAW1 TAX ; SAVE ROTATION (0-$3F)
LSR ; DIVIDE ROTATION BY 16 TO GET
LSR ; QUADRANT (0=UP, 1=RT, 2=DWN, 3=LFT)
LSR
LSR
STA HGR_QUADRANT
TXA ; USE LOW 4 BITS OF ROTATION TO INDEX
AND #$0F ; THE TRIG TABLE
TAX
LDY COSINE_TABLE,X ; SAVE COSINE IN HGR.DX
STY HGR_DX ;
EOR #$F ; AND SINE IN DY
TAX
LDY COSINE_TABLE+1,X
INY
STY HGR_DY
LDY HGR_HORIZ ; INDEX FROM GBASL,H TO BYTE WE'RE IN
LDX #0
STX HGR_COLLISIONS ; CLEAR COLLISION COUNTER
LDA (HGR_SHAPE,X) ; GET FIRST BYTE OF SHAPE DEFN
L_XDRAW1_1 STA HGR_DX+1 ; KEEP SHAPE BYTE IN HGR.DX+1
LDX #$80 ; INITIAL VALUES FOR FRACTIONAL VECTORS
STX HGR_E ; L_XDRAW1_5 IN COSINE COMPONENT
STX HGR_E+1 ; L_XDRAW1_5 IN SINE COMPONENT
LDX HGR_SCALE ; SCALE FACTOR
L_XDRAW1_2 LDA HGR_E ; ADD COSINE VALUE TO X-VALUE
SEC ; IF >= 1, THEN DRAW
ADC HGR_DX ;
STA HGR_E ; ONLY SAVE FRACTIONAL PART
BCC L_XDRAW1_3 ; NO INTEGRAL PART
JSR LRUDX1 ; TIME TO PLOT COSINE COMPONENT
CLC ;
L_XDRAW1_3 LDA HGR_E+1 ; ADD SINE VALUE TO Y-VALUE
ADC HGR_DY ; IF >= 1, THEN DRAW
STA HGR_E+1 ; ONLY SAVE FRACTIONAL PART
BCC L_XDRAW1_4 ; NO INTEGRAL PART
JSR LRUDX2 ; TIME TO PLOT SINE COMPONENT
L_XDRAW1_4 DEX ; LOOP ON SCALE FACTOR.
BNE L_XDRAW1_2 ; STILL ON SAME SHAPE ITEM
LDA HGR_DX+1 ; GET NEXT SHAPE ITEM
LSR ; NEXT 3 BIT VECTOR
LSR ;
LSR ;
BNE L_XDRAW1_1 ; MORE IN THIS SHAPE BYTE
INC HGR_SHAPE ; GO TO NEXT SHAPE BYTE
BNE L_XDRAW1_5
INC HGR_SHAPE+1
L_XDRAW1_5 LDA (HGR_SHAPE,X) ; NEXT BYTE OF SHAPE DEFINITION
BNE L_XDRAW1_1 ; PROCESS IF NOT ZERO
RTS ; FINISHED
; --------------------------------
; GET HI-RES PLOTTING COORDINATES (0-279,0-191) FROM
; TXTPTR. LEAVE REGISTERS SET UP FOR HPOSN:
; (Y,X)=X-COORD
; (A) =Y-COORD
; --------------------------------
HFNS JSR FRMNUM ; EVALUATE EXPRESSION, MUST BE NUMERIC
JSR GETADR ; CONVERT TO 2-BYTE INTEGER IN LINNUM
LDY LINNUM+1 ; GET HORIZ COOR IN X,Y
LDX LINNUM ;
CPY #>280 ; MAKE SURE IT IS < 280
BCC L_HFNS_1 ; IN RANGE
BNE GGERR ;
CPX #<280 ;
BCS GGERR ;
L_HFNS_1 TXA ; SAVE HORIZ COOR ON STACK
PHA ;
TYA ;
PHA ;
LDA #LOCHAR(`,') ; REQUIRE A COMMA
JSR SYNCHR ;
JSR GETBYT ; EVAL EXP TO SINGLE BYTE IN X-REG
CPX #192 ; CHECK FOR RANGE
BCS GGERR ; TOO BIG
STX FAC ; SAVE Y-COORD
PLA ; RETRIEVE HORIZONTAL COORDINATE
TAY ;
PLA ;
TAX ;
LDA FAC ; AND VERTICAL COORDINATE
RTS ;
; --------------------------------
GGERR JMP GOERR ; ILLEGAL QUANTITY ERROR
; --------------------------------
; "HCOLOR=" STATEMENT
; --------------------------------
HCOLOR JSR GETBYT ; EVAL EXP TO SINGLE BYTE IN X
CPX #8 ; VALUE MUST BE 0-7
BCS GGERR ; TOO BIG
LDA COLORTBL,X ; GET COLOR PATTERN
STA HGR_COLOR
RTS_23 RTS
; --------------------------------
COLORTBL ASM_DATA(%00000000)
ASM_DATA(%00101010)
ASM_DATA(%01010101)
ASM_DATA(%01111111)
ASM_DATA(%00000000 | %10000000)
ASM_DATA(%00101010 | %10000000)
ASM_DATA(%01010101 | %10000000)
ASM_DATA(%01111111 | %10000000)
; --------------------------------
; "HPLOT" STATEMENT
;
; HPLOT X,Y
; HPLOT TO X,Y
; HPLOT X1,Y1 TO X2,Y2
; --------------------------------
HPLOT CMP #TOKEN_TO ; "PLOT TO" FORM?
BEQ L_HPLOT_2 ; YES, START FROM CURRENT LOCATION
JSR HFNS ; NO, GET STARTING POINT OF LINE
JSR HPLOT0 ; PLOT THE POINT, AND SET UP FOR
; DRAWING A LINE FROM THAT POINT
L_HPLOT_1 JSR CHRGOT ; CHARACTER AT END OF EXPRESSION
CMP #TOKEN_TO ; IS A LINE SPECIFIED?
BNE RTS_23 ; NO, EXIT
L_HPLOT_2 JSR SYNCHR ; YES. ADV. TXTPTR (WHY NOT CHRGET)
JSR HFNS ; GET COORDINATES OF LINE END
STY DSCTMP ; SET UP FOR LINE
TAY ;
TXA ;
LDX DSCTMP ;
JSR HGLIN ; PLOT LINE
JMP L_HPLOT_1 ; LOOP TILL NO MORE "TO" PHRASES
; --------------------------------
; "ROT=" STATEMENT
; --------------------------------
ROT JSR GETBYT ; EVAL EXP TO A BYTE IN X-REG
STX HGR_ROTATION
RTS
; --------------------------------
; "SCALE=" STATEMENT
; --------------------------------
SCALE JSR GETBYT ; EVAL EXP TO A BYTE IN X-REG
STX HGR_SCALE
RTS
; --------------------------------
; SET UP FOR DRAW AND XDRAW
; --------------------------------
DRWPNT JSR GETBYT ; GET SHAPE NUMBER IN X-REG
LDA HGR_SHAPE_PNTR ; SEARCH FOR THAT SHAPE
STA HGR_SHAPE ; SET UP PNTR TO BEGINNING OF TABLE
LDA HGR_SHAPE_PNTR+1
STA HGR_SHAPE+1
TXA
LDX #0
CMP (HGR_SHAPE,X) ; COMPARE TO # OF SHAPES IN TABLE
BEQ L_DRWPNT_1 ; LAST SHAPE IN TABLE
BCS GGERR ; SHAPE # TOO LARGE
L_DRWPNT_1 ASL ; DOUBLE SHAPE# TO MAKE AN INDEX
BCC L_DRWPNT_2 ; ADD 256 IF SHAPE # > 127
INC HGR_SHAPE+1
CLC
L_DRWPNT_2 TAY ; USE INDEX TO LOOK UP OFFSET FOR SHAPE
LDA (HGR_SHAPE),Y ; IN OFFSET TABLE
ADC HGR_SHAPE
TAX
INY
LDA (HGR_SHAPE),Y
ADC HGR_SHAPE_PNTR+1
STA HGR_SHAPE+1 ; SAVE ADDRESS OF SHAPE
STX HGR_SHAPE
JSR CHRGOT ; IS THERE ANY "AT" PHRASE?
CMP #TOKENDB ;
BNE L_DRWPNT_3 ; NO, DRAW RIGHT WHERE WE ARE
JSR SYNCHR ; SCAN OVER "AT"
JSR HFNS ; GET X- AND Y-COORDS TO START DRAWING AT
JSR HPOSN ; SET UP CURSOR THERE
L_DRWPNT_3 LDA HGR_ROTATION ; ROTATION VALUE
RTS
; --------------------------------
; "DRAW" STATEMENT
; --------------------------------
DRAW JSR DRWPNT
JMP DRAW1
; --------------------------------
; "XDRAW" STATEMENT
; --------------------------------
XDRAW JSR DRWPNT
JMP XDRAW1
; --------------------------------
; "SHLOAD" STATEMENT
;
; READS A SHAPE TABLE FROM CASSETTE TAPE
; TO A POSITION JUST BELOW HIMEM.
; HIMEM IS THEN MOVED TO JUST BELOW THE TABLE
; --------------------------------
SHLOAD LDA #>LINNUM ; SET UP TO READ TWO BYTES
STA MON_A1H ; INTO LINNUM,LINNUM+1
STA MON_A2H ;
LDY #LINNUM ;
STY MON_A1L ;
INY ; LINNUM+1
STY MON_A2L ;
JSR MON_READ ; READ TAPE
CLC ; SETUP TO READ (LINNUM) BYTES
LDA MEMSIZ ; ENDING AT HIMEM-1
TAX ;
DEX ; FORMING HIMEM-1
STX MON_A2L ;
SBC LINNUM ; FORMING HIMEM-(LINNUM)
PHA ;
LDA MEMSIZ+1 ;
TAY ;
INX ; SEE IF HIMEM LOW-BYTE WAS ZERO
BNE L_SHLOAD_1 ; NO
DEY ; YES, HAVE TO DECREMENT HIGH BYTE
L_SHLOAD_1 STY MON_A2H ;
SBC LINNUM+1 ;
CMP STREND+1 ; RUNNING INTO VARIABLES?
BCC L_SHLOAD_2 ; YES, OUT OF MEMORY
BNE L_SHLOAD_3 ; NO, STILL ROOM
L_SHLOAD_2 JMP MEMERR ; MEM FULL ERR
L_SHLOAD_3 STA MEMSIZ+1 ;
STA FRETOP+1 ; CLEAR STRING SPACE
STA MON_A1H ; (BUT NAMES ARE STILL IN VARTBL!)
STA HGR_SHAPE_PNTR+1
PLA
STA HGR_SHAPE_PNTR
STA MEMSIZ
STA FRETOP
STA MON_A1L
JSR MON_RD2BIT ; READ TO TAPE TRANSITIONS
LDA #3 ; SHORT DELAY FOR INTERMEDIATE HEADER
JMP MON_READ2 ; READ SHAPES
; --------------------------------
; CALLED FROM STORE AND RECALL
; --------------------------------
TAPEPNT
CLC
LDA LOWTR
ADC LINNUM
STA MON_A2L
LDA LOWTR+1
ADC LINNUM+1
STA MON_A2H
LDY #4
LDA (LOWTR),Y
JSR GETARY2
LDA HIGHDS
STA MON_A1L
LDA HIGHDS+1
STA MON_A1H
RTS
; --------------------------------
; CALLED FROM STORE AND RECALL
; --------------------------------
GETARYPT
LDA #$40
STA SUBFLG
JSR PTRGET
LDA #0
STA SUBFLG
JMP VARTIO
; --------------------------------
; "HTAB" STATEMENT
;
; NOTE THAT IF WNDLEFT IS NOT 0, HTAB CAN PRINT
; OUTSIDE THE SCREEN (EG., IN THE PROGRAM)
; --------------------------------
HTAB JSR GETBYT
DEX
TXA
L_HTAB_1 CMP #40
BCC L_HTAB_2
SBC #40
PHA
JSR CRDO
PLA
JMP L_HTAB_1
L_HTAB_2 STA MON_CH
RTS
; --------------------------------
HIASCII(`KRW') ; UNKNOWN
Reference in New Issue View Git Blame Copy Permalink