Palaiologos/langsmoke
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
42fae5dd39
langsmoke/3rd/ehbasic.asm
Kamila Szewczyk f337457b94
broken
2023-11-12 18:51:03 +01:00

8691 lines
244 KiB
NASM
Raw Blame History

; Enhanced BASIC to assemble under 6502 simulator, $ver 2.22
; $E7E1 $E7CF $E7C6 $E7D3 $E7D1 $E7D5 $E7CF $E81E $E825
; 2.00 new revision numbers start here
; 2.01 fixed LCASE$() and UCASE$()
; 2.02 new get value routine done
; 2.03 changed RND() to galoise method
; 2.04 fixed SPC()
; 2.05 new get value routine fixed
; 2.06 changed USR() code
; 2.07 fixed STR$()
; 2.08 changed INPUT and READ to remove need for $00 start to input buffer
; 2.09 fixed RND()
; 2.10 integrated missed changes from an earlier version
; 2.20 added ELSE to IF .. THEN and fixed IF .. GOTO <statement> to cause error
; 2.21 fixed IF .. THEN RETURN to not cause error
; 2.22 fixed RND() breaking the get byte routine
; zero page use ..
LAB_WARM = $00 ; BASIC warm start entry point
Wrmjpl = LAB_WARM+1; BASIC warm start vector jump low byte
Wrmjph = LAB_WARM+2; BASIC warm start vector jump high byte
Usrjmp = $0A ; USR function JMP address
Usrjpl = Usrjmp+1 ; USR function JMP vector low byte
Usrjph = Usrjmp+2 ; USR function JMP vector high byte
Nullct = $0D ; nulls output after each line
TPos = $0E ; BASIC terminal position byte
TWidth = $0F ; BASIC terminal width byte
Iclim = $10 ; input column limit
Itempl = $11 ; temporary integer low byte
Itemph = Itempl+1 ; temporary integer high byte
nums_1 = Itempl ; number to bin/hex string convert MSB
nums_2 = nums_1+1 ; number to bin/hex string convert
nums_3 = nums_1+2 ; number to bin/hex string convert LSB
Srchc = $5B ; search character
Temp3 = Srchc ; temp byte used in number routines
Scnquo = $5C ; scan-between-quotes flag
Asrch = Scnquo ; alt search character
XOAw_l = Srchc ; eXclusive OR, OR and AND word low byte
XOAw_h = Scnquo ; eXclusive OR, OR and AND word high byte
Ibptr = $5D ; input buffer pointer
Dimcnt = Ibptr ; # of dimensions
Tindx = Ibptr ; token index
Defdim = $5E ; default DIM flag
Dtypef = $5F ; data type flag, $FF=string, $00=numeric
Oquote = $60 ; open quote flag (b7) (Flag: DATA scan; LIST quote; memory)
Gclctd = $60 ; garbage collected flag
Sufnxf = $61 ; subscript/FNX flag, 1xxx xxx = FN(0xxx xxx)
Imode = $62 ; input mode flag, $00=INPUT, $80=READ
Cflag = $63 ; comparison evaluation flag
TabSiz = $64 ; TAB step size (was input flag)
next_s = $65 ; next descriptor stack address
; these two bytes form a word pointer to the item
; currently on top of the descriptor stack
last_sl = $66 ; last descriptor stack address low byte
last_sh = $67 ; last descriptor stack address high byte (always $00)
des_sk = $68 ; descriptor stack start address (temp strings)
; = $70 ; End of descriptor stack
ut1_pl = $71 ; utility pointer 1 low byte
ut1_ph = ut1_pl+1 ; utility pointer 1 high byte
ut2_pl = $73 ; utility pointer 2 low byte
ut2_ph = ut2_pl+1 ; utility pointer 2 high byte
Temp_2 = ut1_pl ; temp byte for block move
FACt_1 = $75 ; FAC temp mantissa1
FACt_2 = FACt_1+1 ; FAC temp mantissa2
FACt_3 = FACt_2+1 ; FAC temp mantissa3
dims_l = FACt_2 ; array dimension size low byte
dims_h = FACt_3 ; array dimension size high byte
TempB = $78 ; temp page 0 byte
Smeml = $79 ; start of mem low byte (Start-of-Basic)
Smemh = Smeml+1 ; start of mem high byte (Start-of-Basic)
Svarl = $7B ; start of vars low byte (Start-of-Variables)
Svarh = Svarl+1 ; start of vars high byte (Start-of-Variables)
Sarryl = $7D ; var mem end low byte (Start-of-Arrays)
Sarryh = Sarryl+1 ; var mem end high byte (Start-of-Arrays)
Earryl = $7F ; array mem end low byte (End-of-Arrays)
Earryh = Earryl+1 ; array mem end high byte (End-of-Arrays)
Sstorl = $81 ; string storage low byte (String storage (moving down))
Sstorh = Sstorl+1 ; string storage high byte (String storage (moving down))
Sutill = $83 ; string utility ptr low byte
Sutilh = Sutill+1 ; string utility ptr high byte
Ememl = $85 ; end of mem low byte (Limit-of-memory)
Ememh = Ememl+1 ; end of mem high byte (Limit-of-memory)
Clinel = $87 ; current line low byte (Basic line number)
Clineh = Clinel+1 ; current line high byte (Basic line number)
Blinel = $89 ; break line low byte (Previous Basic line number)
Blineh = Blinel+1 ; break line high byte (Previous Basic line number)
Cpntrl = $8B ; continue pointer low byte
Cpntrh = Cpntrl+1 ; continue pointer high byte
Dlinel = $8D ; current DATA line low byte
Dlineh = Dlinel+1 ; current DATA line high byte
Dptrl = $8F ; DATA pointer low byte
Dptrh = Dptrl+1 ; DATA pointer high byte
Rdptrl = $91 ; read pointer low byte
Rdptrh = Rdptrl+1 ; read pointer high byte
Varnm1 = $93 ; current var name 1st byte
Varnm2 = Varnm1+1 ; current var name 2nd byte
Cvaral = $95 ; current var address low byte
Cvarah = Cvaral+1 ; current var address high byte
Frnxtl = $97 ; var pointer for FOR/NEXT low byte
Frnxth = Frnxtl+1 ; var pointer for FOR/NEXT high byte
Tidx1 = Frnxtl ; temp line index
Lvarpl = Frnxtl ; let var pointer low byte
Lvarph = Frnxth ; let var pointer high byte
prstk = $99 ; precedence stacked flag
comp_f = $9B ; compare function flag, bits 0,1 and 2 used
; bit 2 set if >
; bit 1 set if =
; bit 0 set if <
func_l = $9C ; function pointer low byte
func_h = func_l+1 ; function pointer high byte
garb_l = func_l ; garbage collection working pointer low byte
garb_h = func_h ; garbage collection working pointer high byte
des_2l = $9E ; string descriptor_2 pointer low byte
des_2h = des_2l+1 ; string descriptor_2 pointer high byte
g_step = $A0 ; garbage collect step size
Fnxjmp = $A1 ; jump vector for functions
Fnxjpl = Fnxjmp+1 ; functions jump vector low byte
Fnxjph = Fnxjmp+2 ; functions jump vector high byte
g_indx = Fnxjpl ; garbage collect temp index
FAC2_r = $A3 ; FAC2 rounding byte
Adatal = $A4 ; array data pointer low byte
Adatah = Adatal+1 ; array data pointer high byte
Nbendl = Adatal ; new block end pointer low byte
Nbendh = Adatah ; new block end pointer high byte
Obendl = $A6 ; old block end pointer low byte
Obendh = Obendl+1 ; old block end pointer high byte
numexp = $A8 ; string to float number exponent count
expcnt = $A9 ; string to float exponent count
numbit = numexp ; bit count for array element calculations
numdpf = $AA ; string to float decimal point flag
expneg = $AB ; string to float eval exponent -ve flag
Astrtl = numdpf ; array start pointer low byte
Astrth = expneg ; array start pointer high byte
Histrl = numdpf ; highest string low byte
Histrh = expneg ; highest string high byte
Baslnl = numdpf ; BASIC search line pointer low byte
Baslnh = expneg ; BASIC search line pointer high byte
Fvar_l = numdpf ; find/found variable pointer low byte
Fvar_h = expneg ; find/found variable pointer high byte
Ostrtl = numdpf ; old block start pointer low byte
Ostrth = expneg ; old block start pointer high byte
Vrschl = numdpf ; variable search pointer low byte
Vrschh = expneg ; variable search pointer high byte
FAC1_e = $AC ; FAC1 exponent
FAC1_1 = FAC1_e+1 ; FAC1 mantissa1
FAC1_2 = FAC1_e+2 ; FAC1 mantissa2
FAC1_3 = FAC1_e+3 ; FAC1 mantissa3
FAC1_s = FAC1_e+4 ; FAC1 sign (b7)
str_ln = FAC1_e ; string length
str_pl = FAC1_1 ; string pointer low byte
str_ph = FAC1_2 ; string pointer high byte
des_pl = FAC1_2 ; string descriptor pointer low byte
des_ph = FAC1_3 ; string descriptor pointer high byte
mids_l = FAC1_3 ; MID$ string temp length byte
negnum = $B1 ; string to float eval -ve flag
numcon = $B1 ; series evaluation constant count
FAC1_o = $B2 ; FAC1 overflow byte
FAC2_e = $B3 ; FAC2 exponent
FAC2_1 = FAC2_e+1 ; FAC2 mantissa1
FAC2_2 = FAC2_e+2 ; FAC2 mantissa2
FAC2_3 = FAC2_e+3 ; FAC2 mantissa3
FAC2_s = FAC2_e+4 ; FAC2 sign (b7)
FAC_sc = $B8 ; FAC sign comparison, Acc#1 vs #2
FAC1_r = $B9 ; FAC1 rounding byte
ssptr_l = FAC_sc ; string start pointer low byte
ssptr_h = FAC1_r ; string start pointer high byte
sdescr = FAC_sc ; string descriptor pointer
csidx = $BA ; line crunch save index
Asptl = csidx ; array size/pointer low byte
Aspth = $BB ; array size/pointer high byte
Btmpl = Asptl ; BASIC pointer temp low byte
Btmph = Aspth ; BASIC pointer temp low byte
Cptrl = Asptl ; BASIC pointer temp low byte
Cptrh = Aspth ; BASIC pointer temp low byte
Sendl = Asptl ; BASIC pointer temp low byte
Sendh = Aspth ; BASIC pointer temp low byte
LAB_IGBY = $BC ; get next BASIC byte subroutine
LAB_GBYT = $C2 ; get current BASIC byte subroutine
Bpntrl = $C3 ; BASIC execute (get byte) pointer low byte
Bpntrh = Bpntrl+1 ; BASIC execute (get byte) pointer high byte
; = $D7 ; end of get BASIC char subroutine
Rbyte4 = $D8 ; extra PRNG byte
Rbyte1 = Rbyte4+1 ; most significant PRNG byte
Rbyte2 = Rbyte4+2 ; middle PRNG byte
Rbyte3 = Rbyte4+3 ; least significant PRNG byte
NmiBase = $DC ; NMI handler enabled/setup/triggered flags
; bit function
; === ========
; 7 interrupt enabled
; 6 interrupt setup
; 5 interrupt happened
; = $DD ; NMI handler addr low byte
; = $DE ; NMI handler addr high byte
IrqBase = $DF ; IRQ handler enabled/setup/triggered flags
; = $E0 ; IRQ handler addr low byte
; = $E1 ; IRQ handler addr high byte
; = $DE ; unused
; = $DF ; unused
; = $E0 ; unused
; = $E1 ; unused
; = $E2 ; unused
; = $E3 ; unused
; = $E4 ; unused
; = $E5 ; unused
; = $E6 ; unused
; = $E7 ; unused
; = $E8 ; unused
; = $E9 ; unused
; = $EA ; unused
; = $EB ; unused
; = $EC ; unused
; = $ED ; unused
; = $EE ; unused
Decss = $EF ; number to decimal string start
Decssp1 = Decss+1 ; number to decimal string start
; = $FF ; decimal string end
; token values needed for BASIC
; primary command tokens (can start a statement)
TK_END = $80 ; END token
TK_FOR = TK_END+1 ; FOR token
TK_NEXT = TK_FOR+1 ; NEXT token
TK_DATA = TK_NEXT+1 ; DATA token
TK_INPUT = TK_DATA+1 ; INPUT token
TK_DIM = TK_INPUT+1 ; DIM token
TK_READ = TK_DIM+1 ; READ token
TK_LET = TK_READ+1 ; LET token
TK_DEC = TK_LET+1 ; DEC token
TK_GOTO = TK_DEC+1 ; GOTO token
TK_RUN = TK_GOTO+1 ; RUN token
TK_IF = TK_RUN+1 ; IF token
TK_RESTORE = TK_IF+1 ; RESTORE token
TK_GOSUB = TK_RESTORE+1 ; GOSUB token
TK_RETIRQ = TK_GOSUB+1 ; RETIRQ token
TK_RETNMI = TK_RETIRQ+1 ; RETNMI token
TK_RETURN = TK_RETNMI+1 ; RETURN token
TK_REM = TK_RETURN+1 ; REM token
TK_STOP = TK_REM+1 ; STOP token
TK_ON = TK_STOP+1 ; ON token
TK_NULL = TK_ON+1 ; NULL token
TK_INC = TK_NULL+1 ; INC token
TK_WAIT = TK_INC+1 ; WAIT token
TK_LOAD = TK_WAIT+1 ; LOAD token
TK_SAVE = TK_LOAD+1 ; SAVE token
TK_DEF = TK_SAVE+1 ; DEF token
TK_POKE = TK_DEF+1 ; POKE token
TK_DOKE = TK_POKE+1 ; DOKE token
TK_CALL = TK_DOKE+1 ; CALL token
TK_DO = TK_CALL+1 ; DO token
TK_LOOP = TK_DO+1 ; LOOP token
TK_PRINT = TK_LOOP+1 ; PRINT token
TK_CONT = TK_PRINT+1 ; CONT token
TK_LIST = TK_CONT+1 ; LIST token
TK_CLEAR = TK_LIST+1 ; CLEAR token
TK_NEW = TK_CLEAR+1 ; NEW token
TK_WIDTH = TK_NEW+1 ; WIDTH token
TK_GET = TK_WIDTH+1 ; GET token
TK_SWAP = TK_GET+1 ; SWAP token
TK_BITSET = TK_SWAP+1 ; BITSET token
TK_BITCLR = TK_BITSET+1 ; BITCLR token
TK_IRQ = TK_BITCLR+1 ; IRQ token
TK_NMI = TK_IRQ+1 ; NMI token
; secondary command tokens, can't start a statement
TK_TAB = TK_NMI+1 ; TAB token
TK_ELSE = TK_TAB+1 ; ELSE token
TK_TO = TK_ELSE+1 ; TO token
TK_FN = TK_TO+1 ; FN token
TK_SPC = TK_FN+1 ; SPC token
TK_THEN = TK_SPC+1 ; THEN token
TK_NOT = TK_THEN+1 ; NOT token
TK_STEP = TK_NOT+1 ; STEP token
TK_UNTIL = TK_STEP+1 ; UNTIL token
TK_WHILE = TK_UNTIL+1 ; WHILE token
TK_OFF = TK_WHILE+1 ; OFF token
; opperator tokens
TK_PLUS = TK_OFF+1 ; + token
TK_MINUS = TK_PLUS+1 ; - token
TK_MUL = TK_MINUS+1 ; * token
TK_DIV = TK_MUL+1 ; / token
TK_POWER = TK_DIV+1 ; ^ token
TK_AND = TK_POWER+1 ; AND token
TK_EOR = TK_AND+1 ; EOR token
TK_OR = TK_EOR+1 ; OR token
TK_RSHIFT = TK_OR+1 ; RSHIFT token
TK_LSHIFT = TK_RSHIFT+1 ; LSHIFT token
TK_GT = TK_LSHIFT+1 ; > token
TK_EQUAL = TK_GT+1 ; = token
TK_LT = TK_EQUAL+1 ; < token
; functions tokens
TK_SGN = TK_LT+1 ; SGN token
TK_INT = TK_SGN+1 ; INT token
TK_ABS = TK_INT+1 ; ABS token
TK_USR = TK_ABS+1 ; USR token
TK_FRE = TK_USR+1 ; FRE token
TK_POS = TK_FRE+1 ; POS token
TK_SQR = TK_POS+1 ; SQR token
TK_RND = TK_SQR+1 ; RND token
TK_LOG = TK_RND+1 ; LOG token
TK_EXP = TK_LOG+1 ; EXP token
TK_COS = TK_EXP+1 ; COS token
TK_SIN = TK_COS+1 ; SIN token
TK_TAN = TK_SIN+1 ; TAN token
TK_ATN = TK_TAN+1 ; ATN token
TK_PEEK = TK_ATN+1 ; PEEK token
TK_DEEK = TK_PEEK+1 ; DEEK token
TK_SADD = TK_DEEK+1 ; SADD token
TK_LEN = TK_SADD+1 ; LEN token
TK_STRS = TK_LEN+1 ; STR$ token
TK_VAL = TK_STRS+1 ; VAL token
TK_ASC = TK_VAL+1 ; ASC token
TK_UCASES = TK_ASC+1 ; UCASE$ token
TK_LCASES = TK_UCASES+1 ; LCASE$ token
TK_CHRS = TK_LCASES+1 ; CHR$ token
TK_HEXS = TK_CHRS+1 ; HEX$ token
TK_BINS = TK_HEXS+1 ; BIN$ token
TK_BITTST = TK_BINS+1 ; BITTST token
TK_MAX = TK_BITTST+1 ; MAX token
TK_MIN = TK_MAX+1 ; MIN token
TK_PI = TK_MIN+1 ; PI token
TK_TWOPI = TK_PI+1 ; TWOPI token
TK_VPTR = TK_TWOPI+1 ; VARPTR token
TK_LEFTS = TK_VPTR+1 ; LEFT$ token
TK_RIGHTS = TK_LEFTS+1 ; RIGHT$ token
TK_MIDS = TK_RIGHTS+1 ; MID$ token
; offsets from a base of X or Y
PLUS_0 = $00 ; X or Y plus 0
PLUS_1 = $01 ; X or Y plus 1
PLUS_2 = $02 ; X or Y plus 2
PLUS_3 = $03 ; X or Y plus 3
LAB_STAK = $0100 ; stack bottom, no offset
LAB_SKFE = LAB_STAK+$FE
; flushed stack address
LAB_SKFF = LAB_STAK+$FF
; flushed stack address
ccflag = $0200 ; BASIC CTRL-C flag, 00 = enabled, 01 = dis
ccbyte = ccflag+1 ; BASIC CTRL-C byte
ccnull = ccbyte+1 ; BASIC CTRL-C byte timeout
VEC_CC = ccnull+1 ; ctrl c check vector
VEC_IN = VEC_CC+2 ; input vector
VEC_OUT = VEC_IN+2 ; output vector
VEC_LD = VEC_OUT+2 ; load vector
VEC_SV = VEC_LD+2 ; save vector
; Ibuffs can now be anywhere in RAM, ensure that the max length is < $80
Ibuffs = IRQ_vec+$14
; start of input buffer after IRQ/NMI code
Ibuffe = Ibuffs+$47; end of input buffer
Ram_base = $0300 ; start of user RAM (set as needed, should be page aligned)
Ram_top = $C000 ; end of user RAM+1 (set as needed, should be page aligned)
; This start can be changed to suit your system
*= $C000
; BASIC cold start entry point
; new page 2 initialisation, copy block to ccflag on
LAB_COLD
LDY #PG2_TABE-PG2_TABS-1
; byte count-1
LAB_2D13
LDA PG2_TABS,Y ; get byte
STA ccflag,Y ; store in page 2
DEY ; decrement count
BPL LAB_2D13 ; loop if not done
LDX #$FF ; set byte
STX Clineh ; set current line high byte (set immediate mode)
TXS ; reset stack pointer
LDA #$4C ; code for JMP
STA Fnxjmp ; save for jump vector for functions
; copy block from LAB_2CEE to $00BC - $00D3
LDX #StrTab-LAB_2CEE ; set byte count
LAB_2D4E
LDA LAB_2CEE-1,X ; get byte from table
STA LAB_IGBY-1,X ; save byte in page zero
DEX ; decrement count
BNE LAB_2D4E ; loop if not all done
; copy block from StrTab to $0000 - $0012
LAB_GMEM
LDX #EndTab-StrTab-1 ; set byte count-1
TabLoop
LDA StrTab,X ; get byte from table
STA PLUS_0,X ; save byte in page zero
DEX ; decrement count
BPL TabLoop ; loop if not all done
; set-up start values
LDA #$00 ; clear A
STA NmiBase ; clear NMI handler enabled flag
STA IrqBase ; clear IRQ handler enabled flag
STA FAC1_o ; clear FAC1 overflow byte
STA last_sh ; clear descriptor stack top item pointer high byte
LDA #$0E ; set default tab size
STA TabSiz ; save it
LDA #$03 ; set garbage collect step size for descriptor stack
STA g_step ; save it
LDX #des_sk ; descriptor stack start
STX next_s ; set descriptor stack pointer
JSR LAB_CRLF ; print CR/LF
LDA #<LAB_MSZM ; point to memory size message (low addr)
LDY #>LAB_MSZM ; point to memory size message (high addr)
JSR LAB_18C3 ; print null terminated string from memory
JSR LAB_INLN ; print "? " and get BASIC input
STX Bpntrl ; set BASIC execute pointer low byte
STY Bpntrh ; set BASIC execute pointer high byte
JSR LAB_GBYT ; get last byte back
BNE LAB_2DAA ; branch if not null (user typed something)
LDY #$00 ; else clear Y
; character was null so get memory size the hard way
; we get here with Y=0 and Itempl/h = Ram_base
LAB_2D93
INC Itempl ; increment temporary integer low byte
BNE LAB_2D99 ; branch if no overflow
INC Itemph ; increment temporary integer high byte
LDA Itemph ; get high byte
CMP #>Ram_top ; compare with top of RAM+1
BEQ LAB_2DB6 ; branch if match (end of user RAM)
LAB_2D99
LDA #$55 ; set test byte
STA (Itempl),Y ; save via temporary integer
CMP (Itempl),Y ; compare via temporary integer
BNE LAB_2DB6 ; branch if fail
ASL ; shift test byte left (now $AA)
STA (Itempl),Y ; save via temporary integer
CMP (Itempl),Y ; compare via temporary integer
BEQ LAB_2D93 ; if ok go do next byte
BNE LAB_2DB6 ; branch if fail
LAB_2DAA
JSR LAB_2887 ; get FAC1 from string
LDA FAC1_e ; get FAC1 exponent
CMP #$98 ; compare with exponent = 2^24
BCS LAB_GMEM ; if too large go try again
JSR LAB_F2FU ; save integer part of FAC1 in temporary integer
; (no range check)
LAB_2DB6
LDA Itempl ; get temporary integer low byte
LDY Itemph ; get temporary integer high byte
CPY #<Ram_base+1 ; compare with start of RAM+$100 high byte
BCC LAB_GMEM ; if too small go try again
; uncomment these lines if you want to check on the high limit of memory. Note if
; Ram_top is set too low then this will fail. default is ignore it and assume the
; users know what they're doing!
; CPY #>Ram_top ; compare with top of RAM high byte
; BCC MEM_OK ; branch if < RAM top
; BNE LAB_GMEM ; if too large go try again
; else was = so compare low bytes
; CMP #<Ram_top ; compare with top of RAM low byte
; BEQ MEM_OK ; branch if = RAM top
; BCS LAB_GMEM ; if too large go try again
;MEM_OK
STA Ememl ; set end of mem low byte
STY Ememh ; set end of mem high byte
STA Sstorl ; set bottom of string space low byte
STY Sstorh ; set bottom of string space high byte
LDY #<Ram_base ; set start addr low byte
LDX #>Ram_base ; set start addr high byte
STY Smeml ; save start of mem low byte
STX Smemh ; save start of mem high byte
; this line is only needed if Ram_base is not $xx00
; LDY #$00 ; clear Y
TYA ; clear A
STA (Smeml),Y ; clear first byte
INC Smeml ; increment start of mem low byte
; these two lines are only needed if Ram_base is $xxFF
; BNE LAB_2E05 ; branch if no rollover
; INC Smemh ; increment start of mem high byte
LAB_2E05
JSR LAB_CRLF ; print CR/LF
JSR LAB_1463 ; do "NEW" and "CLEAR"
LDA Ememl ; get end of mem low byte
SEC ; set carry for subtract
SBC Smeml ; subtract start of mem low byte
TAX ; copy to X
LDA Ememh ; get end of mem high byte
SBC Smemh ; subtract start of mem high byte
JSR LAB_295E ; print XA as unsigned integer (bytes free)
LDA #<LAB_SMSG ; point to sign-on message (low addr)
LDY #>LAB_SMSG ; point to sign-on message (high addr)
JSR LAB_18C3 ; print null terminated string from memory
LDA #<LAB_1274 ; warm start vector low byte
LDY #>LAB_1274 ; warm start vector high byte
STA Wrmjpl ; save warm start vector low byte
STY Wrmjph ; save warm start vector high byte
JMP (Wrmjpl) ; go do warm start
; open up space in memory
; move (Ostrtl)-(Obendl) to new block ending at (Nbendl)
; Nbendl,Nbendh - new block end address (A/Y)
; Obendl,Obendh - old block end address
; Ostrtl,Ostrth - old block start address
; returns with ..
; Nbendl,Nbendh - new block start address (high byte - $100)
; Obendl,Obendh - old block start address (high byte - $100)
; Ostrtl,Ostrth - old block start address (unchanged)
LAB_11CF
JSR LAB_121F ; check available memory, "Out of memory" error if no room
; addr to check is in AY (low/high)
STA Earryl ; save new array mem end low byte
STY Earryh ; save new array mem end high byte
; open up space in memory
; move (Ostrtl)-(Obendl) to new block ending at (Nbendl)
; don't set array end
LAB_11D6
SEC ; set carry for subtract
LDA Obendl ; get block end low byte
SBC Ostrtl ; subtract block start low byte
TAY ; copy MOD(block length/$100) byte to Y
LDA Obendh ; get block end high byte
SBC Ostrth ; subtract block start high byte
TAX ; copy block length high byte to X
INX ; +1 to allow for count=0 exit
TYA ; copy block length low byte to A
BEQ LAB_120A ; branch if length low byte=0
; block is (X-1)*256+Y bytes, do the Y bytes first
SEC ; set carry for add + 1, two's complement
EOR #$FF ; invert low byte for subtract
ADC Obendl ; add block end low byte
STA Obendl ; save corrected old block end low byte
BCS LAB_11F3 ; branch if no underflow
DEC Obendh ; else decrement block end high byte
SEC ; set carry for add + 1, two's complement
LAB_11F3
TYA ; get MOD(block length/$100) byte
EOR #$FF ; invert low byte for subtract
ADC Nbendl ; add destination end low byte
STA Nbendl ; save modified new block end low byte
BCS LAB_1203 ; branch if no underflow
DEC Nbendh ; else decrement block end high byte
BCC LAB_1203 ; branch always
LAB_11FF
LDA (Obendl),Y ; get byte from source
STA (Nbendl),Y ; copy byte to destination
LAB_1203
DEY ; decrement index
BNE LAB_11FF ; loop until Y=0
; now do Y=0 indexed byte
LDA (Obendl),Y ; get byte from source
STA (Nbendl),Y ; save byte to destination
LAB_120A
DEC Obendh ; decrement source pointer high byte
DEC Nbendh ; decrement destination pointer high byte
DEX ; decrement block count
BNE LAB_1203 ; loop until count = $0
RTS
; check room on stack for A bytes
; stack too deep? do OM error
LAB_1212
STA TempB ; save result in temp byte
TSX ; copy stack
CPX TempB ; compare new "limit" with stack
BCC LAB_OMER ; if stack < limit do "Out of memory" error then warm start
RTS
; check available memory, "Out of memory" error if no room
; addr to check is in AY (low/high)
LAB_121F
CPY Sstorh ; compare bottom of string mem high byte
BCC LAB_124B ; if less then exit (is ok)
BNE LAB_1229 ; skip next test if greater (tested <)
; high byte was =, now do low byte
CMP Sstorl ; compare with bottom of string mem low byte
BCC LAB_124B ; if less then exit (is ok)
; addr is > string storage ptr (oops!)
LAB_1229
PHA ; push addr low byte
LDX #$08 ; set index to save Adatal to expneg inclusive
TYA ; copy addr high byte (to push on stack)
; save misc numeric work area
LAB_122D
PHA ; push byte
LDA Adatal-1,X ; get byte from Adatal to expneg ( ,$00 not pushed)
DEX ; decrement index
BPL LAB_122D ; loop until all done
JSR LAB_GARB ; garbage collection routine
; restore misc numeric work area
LDX #$00 ; clear the index to restore bytes
LAB_1238
PLA ; pop byte
STA Adatal,X ; save byte to Adatal to expneg
INX ; increment index
CPX #$08 ; compare with end + 1
BMI LAB_1238 ; loop if more to do
PLA ; pop addr high byte
TAY ; copy back to Y
PLA ; pop addr low byte
CPY Sstorh ; compare bottom of string mem high byte
BCC LAB_124B ; if less then exit (is ok)
BNE LAB_OMER ; if greater do "Out of memory" error then warm start
; high byte was =, now do low byte
CMP Sstorl ; compare with bottom of string mem low byte
BCS LAB_OMER ; if >= do "Out of memory" error then warm start
; ok exit, carry clear
LAB_124B
RTS
; do "Out of memory" error then warm start
LAB_OMER
LDX #$0C ; error code $0C ("Out of memory" error)
; do error #X, then warm start
LAB_XERR
JSR LAB_CRLF ; print CR/LF
LDA LAB_BAER,X ; get error message pointer low byte
LDY LAB_BAER+1,X ; get error message pointer high byte
JSR LAB_18C3 ; print null terminated string from memory
JSR LAB_1491 ; flush stack and clear continue flag
LDA #<LAB_EMSG ; point to " Error" low addr
LDY #>LAB_EMSG ; point to " Error" high addr
LAB_1269
JSR LAB_18C3 ; print null terminated string from memory
LDY Clineh ; get current line high byte
INY ; increment it
BEQ LAB_1274 ; go do warm start (was immediate mode)
; else print line number
JSR LAB_2953 ; print " in line [LINE #]"
; BASIC warm start entry point
; wait for Basic command
LAB_1274
; clear ON IRQ/NMI bytes
LDA #$00 ; clear A
STA IrqBase ; clear enabled byte
STA NmiBase ; clear enabled byte
LDA #<LAB_RMSG ; point to "Ready" message low byte
LDY #>LAB_RMSG ; point to "Ready" message high byte
JSR LAB_18C3 ; go do print string
; wait for Basic command (no "Ready")
LAB_127D
JSR LAB_1357 ; call for BASIC input
LAB_1280
STX Bpntrl ; set BASIC execute pointer low byte
STY Bpntrh ; set BASIC execute pointer high byte
JSR LAB_GBYT ; scan memory
BEQ LAB_127D ; loop while null
; got to interpret input line now ..
LDX #$FF ; current line to null value
STX Clineh ; set current line high byte
BCC LAB_1295 ; branch if numeric character (handle new BASIC line)
; no line number .. immediate mode
JSR LAB_13A6 ; crunch keywords into Basic tokens
JMP LAB_15F6 ; go scan and interpret code
; handle new BASIC line
LAB_1295
JSR LAB_GFPN ; get fixed-point number into temp integer
JSR LAB_13A6 ; crunch keywords into Basic tokens
STY Ibptr ; save index pointer to end of crunched line
JSR LAB_SSLN ; search BASIC for temp integer line number
BCC LAB_12E6 ; branch if not found
; aroooogah! line # already exists! delete it
LDY #$01 ; set index to next line pointer high byte
LDA (Baslnl),Y ; get next line pointer high byte
STA ut1_ph ; save it
LDA Svarl ; get start of vars low byte
STA ut1_pl ; save it
LDA Baslnh ; get found line pointer high byte
STA ut2_ph ; save it
LDA Baslnl ; get found line pointer low byte
DEY ; decrement index
SBC (Baslnl),Y ; subtract next line pointer low byte
CLC ; clear carry for add
ADC Svarl ; add start of vars low byte
STA Svarl ; save new start of vars low byte
STA ut2_pl ; save destination pointer low byte
LDA Svarh ; get start of vars high byte
ADC #$FF ; -1 + carry
STA Svarh ; save start of vars high byte
SBC Baslnh ; subtract found line pointer high byte
TAX ; copy to block count
SEC ; set carry for subtract
LDA Baslnl ; get found line pointer low byte
SBC Svarl ; subtract start of vars low byte
TAY ; copy to bytes in first block count
BCS LAB_12D0 ; branch if overflow
INX ; increment block count (correct for =0 loop exit)
DEC ut2_ph ; decrement destination high byte
LAB_12D0
CLC ; clear carry for add
ADC ut1_pl ; add source pointer low byte
BCC LAB_12D8 ; branch if no overflow
DEC ut1_ph ; else decrement source pointer high byte
CLC ; clear carry
; close up memory to delete old line
LAB_12D8
LDA (ut1_pl),Y ; get byte from source
STA (ut2_pl),Y ; copy to destination
INY ; increment index
BNE LAB_12D8 ; while <> 0 do this block
INC ut1_ph ; increment source pointer high byte
INC ut2_ph ; increment destination pointer high byte
DEX ; decrement block count
BNE LAB_12D8 ; loop until all done
; got new line in buffer and no existing same #
LAB_12E6
LDA Ibuffs ; get byte from start of input buffer
BEQ LAB_1319 ; if null line just go flush stack/vars and exit
; got new line and it isn't empty line
LDA Ememl ; get end of mem low byte
LDY Ememh ; get end of mem high byte
STA Sstorl ; set bottom of string space low byte
STY Sstorh ; set bottom of string space high byte
LDA Svarl ; get start of vars low byte (end of BASIC)
STA Obendl ; save old block end low byte
LDY Svarh ; get start of vars high byte (end of BASIC)
STY Obendh ; save old block end high byte
ADC Ibptr ; add input buffer pointer (also buffer length)
BCC LAB_1301 ; branch if no overflow from add
INY ; else increment high byte
LAB_1301
STA Nbendl ; save new block end low byte (move to, low byte)
STY Nbendh ; save new block end high byte
JSR LAB_11CF ; open up space in memory
; old start pointer Ostrtl,Ostrth set by the find line call
LDA Earryl ; get array mem end low byte
LDY Earryh ; get array mem end high byte
STA Svarl ; save start of vars low byte
STY Svarh ; save start of vars high byte
LDY Ibptr ; get input buffer pointer (also buffer length)
DEY ; adjust for loop type
LAB_1311
LDA Ibuffs-4,Y ; get byte from crunched line
STA (Baslnl),Y ; save it to program memory
DEY ; decrement count
CPY #$03 ; compare with first byte-1
BNE LAB_1311 ; continue while count <> 3
LDA Itemph ; get line # high byte
STA (Baslnl),Y ; save it to program memory
DEY ; decrement count
LDA Itempl ; get line # low byte
STA (Baslnl),Y ; save it to program memory
DEY ; decrement count
LDA #$FF ; set byte to allow chain rebuild. if you didn't set this
; byte then a zero already here would stop the chain rebuild
; as it would think it was the [EOT] marker.
STA (Baslnl),Y ; save it to program memory
LAB_1319
JSR LAB_1477 ; reset execution to start, clear vars and flush stack
LDX Smeml ; get start of mem low byte
LDA Smemh ; get start of mem high byte
LDY #$01 ; index to high byte of next line pointer
LAB_1325
STX ut1_pl ; set line start pointer low byte
STA ut1_ph ; set line start pointer high byte
LDA (ut1_pl),Y ; get it
BEQ LAB_133E ; exit if end of program
; rebuild chaining of Basic lines
LDY #$04 ; point to first code byte of line
; there is always 1 byte + [EOL] as null entries are deleted
LAB_1330
INY ; next code byte
LDA (ut1_pl),Y ; get byte
BNE LAB_1330 ; loop if not [EOL]
SEC ; set carry for add + 1
TYA ; copy end index
ADC ut1_pl ; add to line start pointer low byte
TAX ; copy to X
LDY #$00 ; clear index, point to this line's next line pointer
STA (ut1_pl),Y ; set next line pointer low byte
TYA ; clear A
ADC ut1_ph ; add line start pointer high byte + carry
INY ; increment index to high byte
STA (ut1_pl),Y ; save next line pointer low byte
BCC LAB_1325 ; go do next line, branch always, carry clear
LAB_133E
JMP LAB_127D ; else we just wait for Basic command, no "Ready"
; print "? " and get BASIC input
LAB_INLN
JSR LAB_18E3 ; print "?" character
JSR LAB_18E0 ; print " "
BNE LAB_1357 ; call for BASIC input and return
; receive line from keyboard
; $08 as delete key (BACKSPACE on standard keyboard)
LAB_134B
JSR LAB_PRNA ; go print the character
DEX ; decrement the buffer counter (delete)
.byte $2C ; make LDX into BIT abs
; call for BASIC input (main entry point)
LAB_1357
LDX #$00 ; clear BASIC line buffer pointer
LAB_1359
JSR V_INPT ; call scan input device
BCC LAB_1359 ; loop if no byte
BEQ LAB_1359 ; loop until valid input (ignore NULLs)
CMP #$07 ; compare with [BELL]
BEQ LAB_1378 ; branch if [BELL]
CMP #$0D ; compare with [CR]
BEQ LAB_1384 ; do CR/LF exit if [CR]
CPX #$00 ; compare pointer with $00
BNE LAB_1374 ; branch if not empty
; next two lines ignore any non print character and [SPACE] if input buffer empty
CMP #$21 ; compare with [SP]+1
BCC LAB_1359 ; if < ignore character
LAB_1374
CMP #$08 ; compare with [BACKSPACE] (delete last character)
BEQ LAB_134B ; go delete last character
LAB_1378
CPX #Ibuffe-Ibuffs ; compare character count with max
BCS LAB_138E ; skip store and do [BELL] if buffer full
STA Ibuffs,X ; else store in buffer
INX ; increment pointer
LAB_137F
JSR LAB_PRNA ; go print the character
BNE LAB_1359 ; always loop for next character
LAB_1384
JMP LAB_1866 ; do CR/LF exit to BASIC
; announce buffer full
LAB_138E
LDA #$07 ; [BELL] character into A
BNE LAB_137F ; go print the [BELL] but ignore input character
; branch always
; crunch keywords into Basic tokens
; position independent buffer version ..
; faster, dictionary search version ....
LAB_13A6
LDY #$FF ; set save index (makes for easy math later)
SEC ; set carry for subtract
LDA Bpntrl ; get basic execute pointer low byte
SBC #<Ibuffs ; subtract input buffer start pointer
TAX ; copy result to X (index past line # if any)
STX Oquote ; clear open quote/DATA flag
LAB_13AC
LDA Ibuffs,X ; get byte from input buffer
BEQ LAB_13EC ; if null save byte then exit
CMP #'_' ; compare with "_"
BCS LAB_13EC ; if >= go save byte then continue crunching
CMP #'<' ; compare with "<"
BCS LAB_13CC ; if >= go crunch now
CMP #'0' ; compare with "0"
BCS LAB_13EC ; if >= go save byte then continue crunching
STA Scnquo ; save buffer byte as search character
CMP #$22 ; is it quote character?
BEQ LAB_1410 ; branch if so (copy quoted string)
CMP #'*' ; compare with "*"
BCC LAB_13EC ; if < go save byte then continue crunching
; else crunch now
LAB_13CC
BIT Oquote ; get open quote/DATA token flag
BVS LAB_13EC ; branch if b6 of Oquote set (was DATA)
; go save byte then continue crunching
STX TempB ; save buffer read index
STY csidx ; copy buffer save index
LDY #<TAB_1STC ; get keyword first character table low address
STY ut2_pl ; save pointer low byte
LDY #>TAB_1STC ; get keyword first character table high address
STY ut2_ph ; save pointer high byte
LDY #$00 ; clear table pointer
LAB_13D0
CMP (ut2_pl),Y ; compare with keyword first character table byte
BEQ LAB_13D1 ; go do word_table_chr if match
BCC LAB_13EA ; if < keyword first character table byte go restore
; Y and save to crunched
INY ; else increment pointer
BNE LAB_13D0 ; and loop (branch always)
; have matched first character of some keyword
LAB_13D1
TYA ; copy matching index
ASL ; *2 (bytes per pointer)
TAX ; copy to new index
LDA TAB_CHRT,X ; get keyword table pointer low byte
STA ut2_pl ; save pointer low byte
LDA TAB_CHRT+1,X ; get keyword table pointer high byte
STA ut2_ph ; save pointer high byte
LDY #$FF ; clear table pointer (make -1 for start)
LDX TempB ; restore buffer read index
LAB_13D6
INY ; next table byte
LDA (ut2_pl),Y ; get byte from table
LAB_13D8
BMI LAB_13EA ; all bytes matched so go save token
INX ; next buffer byte
CMP Ibuffs,X ; compare with byte from input buffer
BEQ LAB_13D6 ; go compare next if match
BNE LAB_1417 ; branch if >< (not found keyword)
LAB_13EA
LDY csidx ; restore save index
; save crunched to output
LAB_13EC
INX ; increment buffer index (to next input byte)
INY ; increment save index (to next output byte)
STA Ibuffs,Y ; save byte to output
CMP #$00 ; set the flags, set carry
BEQ LAB_142A ; do exit if was null [EOL]
; A holds token or byte here
SBC #':' ; subtract ":" (carry set by CMP #00)
BEQ LAB_13FF ; branch if it was ":" (is now $00)
; A now holds token-$3A
CMP #TK_DATA-$3A ; compare with DATA token - $3A
BNE LAB_1401 ; branch if not DATA
; token was : or DATA
LAB_13FF
STA Oquote ; save token-$3A (clear for ":", TK_DATA-$3A for DATA)
LAB_1401
EOR #TK_REM-$3A ; effectively subtract REM token offset
BNE LAB_13AC ; If wasn't REM then go crunch rest of line
STA Asrch ; else was REM so set search for [EOL]
; loop for REM, "..." etc.
LAB_1408
LDA Ibuffs,X ; get byte from input buffer
BEQ LAB_13EC ; branch if null [EOL]
CMP Asrch ; compare with stored character
BEQ LAB_13EC ; branch if match (end quote)
; entry for copy string in quotes, don't crunch
LAB_1410
INY ; increment buffer save index
STA Ibuffs,Y ; save byte to output
INX ; increment buffer read index
BNE LAB_1408 ; loop while <> 0 (should never be 0!)
; not found keyword this go
LAB_1417
LDX TempB ; compare has failed, restore buffer index (start byte!)
; now find the end of this word in the table
LAB_141B
LDA (ut2_pl),Y ; get table byte
PHP ; save status
INY ; increment table index
PLP ; restore byte status
BPL LAB_141B ; if not end of keyword go do next
LDA (ut2_pl),Y ; get byte from keyword table
BNE LAB_13D8 ; go test next word if not zero byte (end of table)
; reached end of table with no match
LDA Ibuffs,X ; restore byte from input buffer
BPL LAB_13EA ; branch always (all bytes in buffer are $00-$7F)
; go save byte in output and continue crunching
; reached [EOL]
LAB_142A
INY ; increment pointer
INY ; increment pointer (makes it next line pointer high byte)
STA Ibuffs,Y ; save [EOL] (marks [EOT] in immediate mode)
INY ; adjust for line copy
INY ; adjust for line copy
INY ; adjust for line copy
DEC Bpntrl ; allow for increment (change if buffer starts at $xxFF)
RTS
; search Basic for temp integer line number from start of mem
LAB_SSLN
LDA Smeml ; get start of mem low byte
LDX Smemh ; get start of mem high byte
; search Basic for temp integer line number from AX
; returns carry set if found
; returns Baslnl/Baslnh pointer to found or next higher (not found) line
; old 541 new 507
LAB_SHLN
LDY #$01 ; set index
STA Baslnl ; save low byte as current
STX Baslnh ; save high byte as current
LDA (Baslnl),Y ; get pointer high byte from addr
BEQ LAB_145F ; pointer was zero so we're done, do 'not found' exit
LDY #$03 ; set index to line # high byte
LDA (Baslnl),Y ; get line # high byte
DEY ; decrement index (point to low byte)
CMP Itemph ; compare with temporary integer high byte
BNE LAB_1455 ; if <> skip low byte check
LDA (Baslnl),Y ; get line # low byte
CMP Itempl ; compare with temporary integer low byte
LAB_1455
BCS LAB_145E ; else if temp < this line, exit (passed line#)
LAB_1456
DEY ; decrement index to next line ptr high byte
LDA (Baslnl),Y ; get next line pointer high byte
TAX ; copy to X
DEY ; decrement index to next line ptr low byte
LDA (Baslnl),Y ; get next line pointer low byte
BCC LAB_SHLN ; go search for line # in temp (Itempl/Itemph) from AX
; (carry always clear)
LAB_145E
BEQ LAB_1460 ; exit if temp = found line #, carry is set
LAB_145F
CLC ; clear found flag
LAB_1460
RTS
; perform NEW
LAB_NEW
BNE LAB_1460 ; exit if not end of statement (to do syntax error)
LAB_1463
LDA #$00 ; clear A
TAY ; clear Y
STA (Smeml),Y ; clear first line, next line pointer, low byte
INY ; increment index
STA (Smeml),Y ; clear first line, next line pointer, high byte
CLC ; clear carry
LDA Smeml ; get start of mem low byte
ADC #$02 ; calculate end of BASIC low byte
STA Svarl ; save start of vars low byte
LDA Smemh ; get start of mem high byte
ADC #$00 ; add any carry
STA Svarh ; save start of vars high byte
; reset execution to start, clear vars and flush stack
LAB_1477
CLC ; clear carry
LDA Smeml ; get start of mem low byte
ADC #$FF ; -1
STA Bpntrl ; save BASIC execute pointer low byte
LDA Smemh ; get start of mem high byte
ADC #$FF ; -1+carry
STA Bpntrh ; save BASIC execute pointer high byte
; "CLEAR" command gets here
LAB_147A
LDA Ememl ; get end of mem low byte
LDY Ememh ; get end of mem high byte
STA Sstorl ; set bottom of string space low byte
STY Sstorh ; set bottom of string space high byte
LDA Svarl ; get start of vars low byte
LDY Svarh ; get start of vars high byte
STA Sarryl ; save var mem end low byte
STY Sarryh ; save var mem end high byte
STA Earryl ; save array mem end low byte
STY Earryh ; save array mem end high byte
JSR LAB_161A ; perform RESTORE command
; flush stack and clear continue flag
LAB_1491
LDX #des_sk ; set descriptor stack pointer
STX next_s ; save descriptor stack pointer
PLA ; pull return address low byte
TAX ; copy return address low byte
PLA ; pull return address high byte
STX LAB_SKFE ; save to cleared stack
STA LAB_SKFF ; save to cleared stack
LDX #$FD ; new stack pointer
TXS ; reset stack
LDA #$00 ; clear byte
STA Cpntrh ; clear continue pointer high byte
STA Sufnxf ; clear subscript/FNX flag
LAB_14A6
RTS
; perform CLEAR
LAB_CLEAR
BEQ LAB_147A ; if no following token go do "CLEAR"
; else there was a following token (go do syntax error)
RTS
; perform LIST [n][-m]
; bigger, faster version (a _lot_ faster)
LAB_LIST
BCC LAB_14BD ; branch if next character numeric (LIST n..)
BEQ LAB_14BD ; branch if next character [NULL] (LIST)
CMP #TK_MINUS ; compare with token for -
BNE LAB_14A6 ; exit if not - (LIST -m)
; LIST [[n][-m]]
; this bit sets the n , if present, as the start and end
LAB_14BD
JSR LAB_GFPN ; get fixed-point number into temp integer
JSR LAB_SSLN ; search BASIC for temp integer line number
; (pointer in Baslnl/Baslnh)
JSR LAB_GBYT ; scan memory
BEQ LAB_14D4 ; branch if no more characters
; this bit checks the - is present
CMP #TK_MINUS ; compare with token for -
BNE LAB_1460 ; return if not "-" (will be Syntax error)
; LIST [n]-m
; the - was there so set m as the end value
JSR LAB_IGBY ; increment and scan memory
JSR LAB_GFPN ; get fixed-point number into temp integer
BNE LAB_1460 ; exit if not ok
LAB_14D4
LDA Itempl ; get temporary integer low byte
ORA Itemph ; OR temporary integer high byte
BNE LAB_14E2 ; branch if start set
LDA #$FF ; set for -1
STA Itempl ; set temporary integer low byte
STA Itemph ; set temporary integer high byte
LAB_14E2
LDY #$01 ; set index for line
STY Oquote ; clear open quote flag
JSR LAB_CRLF ; print CR/LF
LDA (Baslnl),Y ; get next line pointer high byte
; pointer initially set by search at LAB_14BD
BEQ LAB_152B ; if null all done so exit
JSR LAB_1629 ; do CRTL-C check vector
INY ; increment index for line
LDA (Baslnl),Y ; get line # low byte
TAX ; copy to X
INY ; increment index
LDA (Baslnl),Y ; get line # high byte
CMP Itemph ; compare with temporary integer high byte
BNE LAB_14FF ; branch if no high byte match
CPX Itempl ; compare with temporary integer low byte
BEQ LAB_1501 ; branch if = last line to do (< will pass next branch)
LAB_14FF ; else ..
BCS LAB_152B ; if greater all done so exit
LAB_1501
STY Tidx1 ; save index for line
JSR LAB_295E ; print XA as unsigned integer
LDA #$20 ; space is the next character
LAB_1508
LDY Tidx1 ; get index for line
AND #$7F ; mask top out bit of character
LAB_150C
JSR LAB_PRNA ; go print the character
CMP #$22 ; was it " character
BNE LAB_1519 ; branch if not
; we are either entering or leaving a pair of quotes
LDA Oquote ; get open quote flag
EOR #$FF ; toggle it
STA Oquote ; save it back
LAB_1519
INY ; increment index
LDA (Baslnl),Y ; get next byte
BNE LAB_152E ; branch if not [EOL] (go print character)
TAY ; else clear index
LDA (Baslnl),Y ; get next line pointer low byte
TAX ; copy to X
INY ; increment index
LDA (Baslnl),Y ; get next line pointer high byte
STX Baslnl ; set pointer to line low byte
STA Baslnh ; set pointer to line high byte
BNE LAB_14E2 ; go do next line if not [EOT]
; else ..
LAB_152B
RTS
LAB_152E
BPL LAB_150C ; just go print it if not token byte
; else was token byte so uncrunch it (maybe)
BIT Oquote ; test the open quote flag
BMI LAB_150C ; just go print character if open quote set
LDX #>LAB_KEYT ; get table address high byte
ASL ; *2
ASL ; *4
BCC LAB_152F ; branch if no carry
INX ; else increment high byte
CLC ; clear carry for add
LAB_152F
ADC #<LAB_KEYT ; add low byte
BCC LAB_1530 ; branch if no carry
INX ; else increment high byte
LAB_1530
STA ut2_pl ; save table pointer low byte
STX ut2_ph ; save table pointer high byte
STY Tidx1 ; save index for line
LDY #$00 ; clear index
LDA (ut2_pl),Y ; get length
TAX ; copy length
INY ; increment index
LDA (ut2_pl),Y ; get 1st character
DEX ; decrement length
BEQ LAB_1508 ; if no more characters exit and print
JSR LAB_PRNA ; go print the character
INY ; increment index
LDA (ut2_pl),Y ; get keyword address low byte
PHA ; save it for now
INY ; increment index
LDA (ut2_pl),Y ; get keyword address high byte
LDY #$00
STA ut2_ph ; save keyword pointer high byte
PLA ; pull low byte
STA ut2_pl ; save keyword pointer low byte
LAB_1540
LDA (ut2_pl),Y ; get character
DEX ; decrement character count
BEQ LAB_1508 ; if last character exit and print
JSR LAB_PRNA ; go print the character
INY ; increment index
BNE LAB_1540 ; loop for next character
; perform FOR
LAB_FOR
LDA #$80 ; set FNX
STA Sufnxf ; set subscript/FNX flag
JSR LAB_LET ; go do LET
PLA ; pull return address
PLA ; pull return address
LDA #$10 ; we need 16d bytes !
JSR LAB_1212 ; check room on stack for A bytes
JSR LAB_SNBS ; scan for next BASIC statement ([:] or [EOL])
CLC ; clear carry for add
TYA ; copy index to A
ADC Bpntrl ; add BASIC execute pointer low byte
PHA ; push onto stack
LDA Bpntrh ; get BASIC execute pointer high byte
ADC #$00 ; add carry
PHA ; push onto stack
LDA Clineh ; get current line high byte
PHA ; push onto stack
LDA Clinel ; get current line low byte
PHA ; push onto stack
LDA #TK_TO ; get "TO" token
JSR LAB_SCCA ; scan for CHR$(A) , else do syntax error then warm start
JSR LAB_CTNM ; check if source is numeric, else do type mismatch
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
LDA FAC1_s ; get FAC1 sign (b7)
ORA #$7F ; set all non sign bits
AND FAC1_1 ; and FAC1 mantissa1
STA FAC1_1 ; save FAC1 mantissa1
LDA #<LAB_159F ; set return address low byte
LDY #>LAB_159F ; set return address high byte
STA ut1_pl ; save return address low byte
STY ut1_ph ; save return address high byte
JMP LAB_1B66 ; round FAC1 and put on stack (returns to next instruction)
LAB_159F
LDA #<LAB_259C ; set 1 pointer low addr (default step size)
LDY #>LAB_259C ; set 1 pointer high addr
JSR LAB_UFAC ; unpack memory (AY) into FAC1
JSR LAB_GBYT ; scan memory
CMP #TK_STEP ; compare with STEP token
BNE LAB_15B3 ; jump if not "STEP"
;.was step so ..
JSR LAB_IGBY ; increment and scan memory
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
LAB_15B3
JSR LAB_27CA ; return A=FF,C=1/-ve A=01,C=0/+ve
STA FAC1_s ; set FAC1 sign (b7)
; this is +1 for +ve step and -1 for -ve step, in NEXT we
; compare the FOR value and the TO value and return +1 if
; FOR > TO, 0 if FOR = TO and -1 if FOR < TO. the value
; here (+/-1) is then compared to that result and if they
; are the same (+ve and FOR > TO or -ve and FOR < TO) then
; the loop is done
JSR LAB_1B5B ; push sign, round FAC1 and put on stack
LDA Frnxth ; get var pointer for FOR/NEXT high byte
PHA ; push on stack
LDA Frnxtl ; get var pointer for FOR/NEXT low byte
PHA ; push on stack
LDA #TK_FOR ; get FOR token
PHA ; push on stack
; interpreter inner loop
LAB_15C2
JSR LAB_1629 ; do CRTL-C check vector
LDA Bpntrl ; get BASIC execute pointer low byte
LDY Bpntrh ; get BASIC execute pointer high byte
LDX Clineh ; continue line is $FFxx for immediate mode
; ($00xx for RUN from immediate mode)
INX ; increment it (now $00 if immediate mode)
BEQ LAB_15D1 ; branch if null (immediate mode)
STA Cpntrl ; save continue pointer low byte
STY Cpntrh ; save continue pointer high byte
LAB_15D1
LDY #$00 ; clear index
LDA (Bpntrl),Y ; get next byte
BEQ LAB_15DC ; branch if null [EOL]
CMP #':' ; compare with ":"
BEQ LAB_15F6 ; branch if = (statement separator)
LAB_15D9
JMP LAB_SNER ; else syntax error then warm start
; have reached [EOL]
LAB_15DC
LDY #$02 ; set index
LDA (Bpntrl),Y ; get next line pointer high byte
CLC ; clear carry for no "BREAK" message
BEQ LAB_1651 ; if null go to immediate mode (was immediate or [EOT]
; marker)
INY ; increment index
LDA (Bpntrl),Y ; get line # low byte
STA Clinel ; save current line low byte
INY ; increment index
LDA (Bpntrl),Y ; get line # high byte
STA Clineh ; save current line high byte
TYA ; A now = 4
ADC Bpntrl ; add BASIC execute pointer low byte
STA Bpntrl ; save BASIC execute pointer low byte
BCC LAB_15F6 ; branch if no overflow
INC Bpntrh ; else increment BASIC execute pointer high byte
LAB_15F6
JSR LAB_IGBY ; increment and scan memory
LAB_15F9
JSR LAB_15FF ; go interpret BASIC code from (Bpntrl)
LAB_15FC
JMP LAB_15C2 ; loop
; interpret BASIC code from (Bpntrl)
LAB_15FF
BEQ LAB_1628 ; exit if zero [EOL]
LAB_1602
ASL ; *2 bytes per vector and normalise token
BCS LAB_1609 ; branch if was token
JMP LAB_LET ; else go do implied LET
LAB_1609
CMP #[TK_TAB-$80]*2 ; compare normalised token * 2 with TAB
BCS LAB_15D9 ; branch if A>=TAB (do syntax error then warm start)
; only tokens before TAB can start a line
TAY ; copy to index
LDA LAB_CTBL+1,Y ; get vector high byte
PHA ; onto stack
LDA LAB_CTBL,Y ; get vector low byte
PHA ; onto stack
JMP LAB_IGBY ; jump to increment and scan memory
; then "return" to vector
; CTRL-C check jump. this is called as a subroutine but exits back via a jump if a
; key press is detected.
LAB_1629
JMP (VEC_CC) ; ctrl c check vector
; if there was a key press it gets back here ..
LAB_1636
CMP #$03 ; compare with CTRL-C
; perform STOP
LAB_STOP
BCS LAB_163B ; branch if token follows STOP
; else just END
; END
LAB_END
CLC ; clear the carry, indicate a normal program end
LAB_163B
BNE LAB_167A ; if wasn't CTRL-C or there is a following byte return
LDA Bpntrh ; get the BASIC execute pointer high byte
EOR #>Ibuffs ; compare with buffer address high byte (Cb unchanged)
BEQ LAB_164F ; branch if the BASIC pointer is in the input buffer
; (can't continue in immediate mode)
; else ..
EOR #>Ibuffs ; correct the bits
LDY Bpntrl ; get BASIC execute pointer low byte
STY Cpntrl ; save continue pointer low byte
STA Cpntrh ; save continue pointer high byte
LAB_1647
LDA Clinel ; get current line low byte
LDY Clineh ; get current line high byte
STA Blinel ; save break line low byte
STY Blineh ; save break line high byte
LAB_164F
PLA ; pull return address low
PLA ; pull return address high
LAB_1651
BCC LAB_165E ; if was program end just do warm start
; else ..
LDA #<LAB_BMSG ; point to "Break" low byte
LDY #>LAB_BMSG ; point to "Break" high byte
JMP LAB_1269 ; print "Break" and do warm start
LAB_165E
JMP LAB_1274 ; go do warm start
; perform RESTORE
LAB_RESTORE
BNE LAB_RESTOREn ; branch if next character not null (RESTORE n)
LAB_161A
SEC ; set carry for subtract
LDA Smeml ; get start of mem low byte
SBC #$01 ; -1
LDY Smemh ; get start of mem high byte
BCS LAB_1624 ; branch if no underflow
LAB_uflow
DEY ; else decrement high byte
LAB_1624
STA Dptrl ; save DATA pointer low byte
STY Dptrh ; save DATA pointer high byte
LAB_1628
RTS
; is RESTORE n
LAB_RESTOREn
JSR LAB_GFPN ; get fixed-point number into temp integer
JSR LAB_SNBL ; scan for next BASIC line
LDA Clineh ; get current line high byte
CMP Itemph ; compare with temporary integer high byte
BCS LAB_reset_search ; branch if >= (start search from beginning)
TYA ; else copy line index to A
SEC ; set carry (+1)
ADC Bpntrl ; add BASIC execute pointer low byte
LDX Bpntrh ; get BASIC execute pointer high byte
BCC LAB_go_search ; branch if no overflow to high byte
INX ; increment high byte
BCS LAB_go_search ; branch always (can never be carry clear)
; search for line # in temp (Itempl/Itemph) from start of mem pointer (Smeml)
LAB_reset_search
LDA Smeml ; get start of mem low byte
LDX Smemh ; get start of mem high byte
; search for line # in temp (Itempl/Itemph) from (AX)
LAB_go_search
JSR LAB_SHLN ; search Basic for temp integer line number from AX
BCS LAB_line_found ; if carry set go set pointer
JMP LAB_16F7 ; else go do "Undefined statement" error
LAB_line_found
; carry already set for subtract
LDA Baslnl ; get pointer low byte
SBC #$01 ; -1
LDY Baslnh ; get pointer high byte
BCS LAB_1624 ; branch if no underflow (save DATA pointer and return)
BCC LAB_uflow ; else decrement high byte then save DATA pointer and
; return (branch always)
; perform NULL
LAB_NULL
JSR LAB_GTBY ; get byte parameter
STX Nullct ; save new NULL count
LAB_167A
RTS
; perform CONT
LAB_CONT
BNE LAB_167A ; if following byte exit to do syntax error
LDY Cpntrh ; get continue pointer high byte
BNE LAB_166C ; go do continue if we can
LDX #$1E ; error code $1E ("Can't continue" error)
JMP LAB_XERR ; do error #X, then warm start
; we can continue so ..
LAB_166C
LDA #TK_ON ; set token for ON
JSR LAB_IRQ ; set IRQ flags
LDA #TK_ON ; set token for ON
JSR LAB_NMI ; set NMI flags
STY Bpntrh ; save BASIC execute pointer high byte
LDA Cpntrl ; get continue pointer low byte
STA Bpntrl ; save BASIC execute pointer low byte
LDA Blinel ; get break line low byte
LDY Blineh ; get break line high byte
STA Clinel ; set current line low byte
STY Clineh ; set current line high byte
RTS
; perform RUN
LAB_RUN
BNE LAB_1696 ; branch if RUN n
JMP LAB_1477 ; reset execution to start, clear variables, flush stack and
; return
; does RUN n
LAB_1696
JSR LAB_147A ; go do "CLEAR"
BEQ LAB_16B0 ; get n and do GOTO n (branch always as CLEAR sets Z=1)
; perform DO
LAB_DO
LDA #$05 ; need 5 bytes for DO
JSR LAB_1212 ; check room on stack for A bytes
LDA Bpntrh ; get BASIC execute pointer high byte
PHA ; push on stack
LDA Bpntrl ; get BASIC execute pointer low byte
PHA ; push on stack
LDA Clineh ; get current line high byte
PHA ; push on stack
LDA Clinel ; get current line low byte
PHA ; push on stack
LDA #TK_DO ; token for DO
PHA ; push on stack
JSR LAB_GBYT ; scan memory
JMP LAB_15C2 ; go do interpreter inner loop
; perform GOSUB
LAB_GOSUB
LDA #$05 ; need 5 bytes for GOSUB
JSR LAB_1212 ; check room on stack for A bytes
LDA Bpntrh ; get BASIC execute pointer high byte
PHA ; push on stack
LDA Bpntrl ; get BASIC execute pointer low byte
PHA ; push on stack
LDA Clineh ; get current line high byte
PHA ; push on stack
LDA Clinel ; get current line low byte
PHA ; push on stack
LDA #TK_GOSUB ; token for GOSUB
PHA ; push on stack
LAB_16B0
JSR LAB_GBYT ; scan memory
JSR LAB_GOTO ; perform GOTO n
JMP LAB_15C2 ; go do interpreter inner loop
; (can't RTS, we used the stack!)
; perform GOTO
LAB_GOTO
JSR LAB_GFPN ; get fixed-point number into temp integer
JSR LAB_SNBL ; scan for next BASIC line
LDA Clineh ; get current line high byte
CMP Itemph ; compare with temporary integer high byte
BCS LAB_16D0 ; branch if >= (start search from beginning)
TYA ; else copy line index to A
SEC ; set carry (+1)
ADC Bpntrl ; add BASIC execute pointer low byte
LDX Bpntrh ; get BASIC execute pointer high byte
BCC LAB_16D4 ; branch if no overflow to high byte
INX ; increment high byte
BCS LAB_16D4 ; branch always (can never be carry)
; search for line # in temp (Itempl/Itemph) from start of mem pointer (Smeml)
LAB_16D0
LDA Smeml ; get start of mem low byte
LDX Smemh ; get start of mem high byte
; search for line # in temp (Itempl/Itemph) from (AX)
LAB_16D4
JSR LAB_SHLN ; search Basic for temp integer line number from AX
BCC LAB_16F7 ; if carry clear go do "Undefined statement" error
; (unspecified statement)
; carry already set for subtract
LDA Baslnl ; get pointer low byte
SBC #$01 ; -1
STA Bpntrl ; save BASIC execute pointer low byte
LDA Baslnh ; get pointer high byte
SBC #$00 ; subtract carry
STA Bpntrh ; save BASIC execute pointer high byte
LAB_16E5
RTS
LAB_DONOK
LDX #$22 ; error code $22 ("LOOP without DO" error)
JMP LAB_XERR ; do error #X, then warm start
; perform LOOP
LAB_LOOP
TAY ; save following token
TSX ; copy stack pointer
LDA LAB_STAK+3,X ; get token byte from stack
CMP #TK_DO ; compare with DO token
BNE LAB_DONOK ; branch if no matching DO
INX ; dump calling routine return address
INX ; dump calling routine return address
TXS ; correct stack
TYA ; get saved following token back
BEQ LoopAlways ; if no following token loop forever
; (stack pointer in X)
CMP #':' ; could be ':'
BEQ LoopAlways ; if :... loop forever
SBC #TK_UNTIL ; subtract token for UNTIL, we know carry is set here
TAX ; copy to X (if it was UNTIL then Y will be correct)
BEQ DoRest ; branch if was UNTIL
DEX ; decrement result
BNE LAB_16FC ; if not WHILE go do syntax error and warm start
; only if the token was WHILE will this fail
DEX ; set invert result byte
DoRest
STX Frnxth ; save invert result byte
JSR LAB_IGBY ; increment and scan memory
JSR LAB_EVEX ; evaluate expression
LDA FAC1_e ; get FAC1 exponent
BEQ DoCmp ; if =0 go do straight compare
LDA #$FF ; else set all bits
DoCmp
TSX ; copy stack pointer
EOR Frnxth ; EOR with invert byte
BNE LoopDone ; if <> 0 clear stack and back to interpreter loop
; loop condition wasn't met so do it again
LoopAlways
LDA LAB_STAK+2,X ; get current line low byte
STA Clinel ; save current line low byte
LDA LAB_STAK+3,X ; get current line high byte
STA Clineh ; save current line high byte
LDA LAB_STAK+4,X ; get BASIC execute pointer low byte
STA Bpntrl ; save BASIC execute pointer low byte
LDA LAB_STAK+5,X ; get BASIC execute pointer high byte
STA Bpntrh ; save BASIC execute pointer high byte
JSR LAB_GBYT ; scan memory
JMP LAB_15C2 ; go do interpreter inner loop
; clear stack and back to interpreter loop
LoopDone
INX ; dump DO token
INX ; dump current line low byte
INX ; dump current line high byte
INX ; dump BASIC execute pointer low byte
INX ; dump BASIC execute pointer high byte
TXS ; correct stack
JMP LAB_DATA ; go perform DATA (find : or [EOL])
; do the return without gosub error
LAB_16F4
LDX #$04 ; error code $04 ("RETURN without GOSUB" error)
.byte $2C ; makes next line BIT LAB_0EA2
LAB_16F7 ; do undefined statement error
LDX #$0E ; error code $0E ("Undefined statement" error)
JMP LAB_XERR ; do error #X, then warm start
; perform RETURN
LAB_RETURN
BNE LAB_16E5 ; exit if following token (to allow syntax error)
LAB_16E8
PLA ; dump calling routine return address
PLA ; dump calling routine return address
PLA ; pull token
CMP #TK_GOSUB ; compare with GOSUB token
BNE LAB_16F4 ; branch if no matching GOSUB
LAB_16FF
PLA ; pull current line low byte
STA Clinel ; save current line low byte
PLA ; pull current line high byte
STA Clineh ; save current line high byte
PLA ; pull BASIC execute pointer low byte
STA Bpntrl ; save BASIC execute pointer low byte
PLA ; pull BASIC execute pointer high byte
STA Bpntrh ; save BASIC execute pointer high byte
; now do the DATA statement as we could be returning into
; the middle of an ON <var> GOSUB n,m,p,q line
; (the return address used by the DATA statement is the one
; pushed before the GOSUB was executed!)
; perform DATA
LAB_DATA
JSR LAB_SNBS ; scan for next BASIC statement ([:] or [EOL])
; set BASIC execute pointer
LAB_170F
TYA ; copy index to A
CLC ; clear carry for add
ADC Bpntrl ; add BASIC execute pointer low byte
STA Bpntrl ; save BASIC execute pointer low byte
BCC LAB_1719 ; skip next if no carry
INC Bpntrh ; else increment BASIC execute pointer high byte
LAB_1719
RTS
LAB_16FC
JMP LAB_SNER ; do syntax error then warm start
; scan for next BASIC statement ([:] or [EOL])
; returns Y as index to [:] or [EOL]
LAB_SNBS
LDX #':' ; set look for character = ":"
.byte $2C ; makes next line BIT $00A2
; scan for next BASIC line
; returns Y as index to [EOL]
LAB_SNBL
LDX #$00 ; set alt search character = [EOL]
LDY #$00 ; set search character = [EOL]
STY Asrch ; store search character
LAB_1725
TXA ; get alt search character
EOR Asrch ; toggle search character, effectively swap with $00
STA Asrch ; save swapped search character
LAB_172D
LDA (Bpntrl),Y ; get next byte
BEQ LAB_1719 ; exit if null [EOL]
CMP Asrch ; compare with search character
BEQ LAB_1719 ; exit if found
INY ; increment index
CMP #$22 ; compare current character with open quote
BNE LAB_172D ; if not open quote go get next character
BEQ LAB_1725 ; if found go swap search character for alt search character
; perform IF
LAB_IF
JSR LAB_EVEX ; evaluate the expression
JSR LAB_GBYT ; scan memory
CMP #TK_THEN ; compare with THEN token
BEQ LAB_174B ; if it was THEN go do IF
; wasn't IF .. THEN so must be IF .. GOTO
CMP #TK_GOTO ; compare with GOTO token
BNE LAB_16FC ; if it wasn't GOTO go do syntax error
LDX Bpntrl ; save the basic pointer low byte
LDY Bpntrh ; save the basic pointer high byte
JSR LAB_IGBY ; increment and scan memory
BCS LAB_16FC ; if not numeric go do syntax error
STX Bpntrl ; restore the basic pointer low byte
STY Bpntrh ; restore the basic pointer high byte
LAB_174B
LDA FAC1_e ; get FAC1 exponent
BEQ LAB_174E ; if the result was zero go look for an ELSE
JSR LAB_IGBY ; else increment and scan memory
BCS LAB_174D ; if not numeric go do var or keyword
LAB_174C
JMP LAB_GOTO ; else was numeric so do GOTO n
; is var or keyword
LAB_174D
CMP #TK_RETURN ; compare the byte with the token for RETURN
BNE LAB_174G ; if it wasn't RETURN go interpret BASIC code from (Bpntrl)
; and return to this code to process any following code
JMP LAB_1602 ; else it was RETURN so interpret BASIC code from (Bpntrl)
; but don't return here
LAB_174G
JSR LAB_15FF ; interpret BASIC code from (Bpntrl)
; the IF was executed and there may be a following ELSE so the code needs to return
; here to check and ignore the ELSE if present
LDY #$00 ; clear the index
LDA (Bpntrl),Y ; get the next BASIC byte
CMP #TK_ELSE ; compare it with the token for ELSE
BEQ LAB_DATA ; if ELSE ignore the following statement
; there was no ELSE so continue execution of IF <expr> THEN <stat> [: <stat>]. any
; following ELSE will, correctly, cause a syntax error
RTS ; else return to the interpreter inner loop
; perform ELSE after IF
LAB_174E
LDY #$00 ; clear the BASIC byte index
LDX #$01 ; clear the nesting depth
LAB_1750
INY ; increment the BASIC byte index
LDA (Bpntrl),Y ; get the next BASIC byte
BEQ LAB_1753 ; if EOL go add the pointer and return
CMP #TK_IF ; compare the byte with the token for IF
BNE LAB_1752 ; if not IF token skip the depth increment
INX ; else increment the nesting depth ..
BNE LAB_1750 ; .. and continue looking
LAB_1752
CMP #TK_ELSE ; compare the byte with the token for ELSE
BNE LAB_1750 ; if not ELSE token continue looking
DEX ; was ELSE so decrement the nesting depth
BNE LAB_1750 ; loop if still nested
INY ; increment the BASIC byte index past the ELSE
; found the matching ELSE, now do <{n|statement}>
LAB_1753
TYA ; else copy line index to A
CLC ; clear carry for add
ADC Bpntrl ; add the BASIC execute pointer low byte
STA Bpntrl ; save the BASIC execute pointer low byte
BCC LAB_1754 ; branch if no overflow to high byte
INC Bpntrh ; else increment the BASIC execute pointer high byte
LAB_1754
JSR LAB_GBYT ; scan memory
BCC LAB_174C ; if numeric do GOTO n
; the code will return to the interpreter loop at the
; tail end of the GOTO <n>
JMP LAB_15FF ; interpret BASIC code from (Bpntrl)
; the code will return to the interpreter loop at the
; tail end of the <statement>
; perform REM, skip (rest of) line
LAB_REM
JSR LAB_SNBL ; scan for next BASIC line
JMP LAB_170F ; go set BASIC execute pointer and return, branch always
LAB_16FD
JMP LAB_SNER ; do syntax error then warm start
; perform ON
LAB_ON
CMP #TK_IRQ ; was it IRQ token ?
BNE LAB_NOIN ; if not go check NMI
JMP LAB_SIRQ ; else go set-up IRQ
LAB_NOIN
CMP #TK_NMI ; was it NMI token ?
BNE LAB_NONM ; if not go do normal ON command
JMP LAB_SNMI ; else go set-up NMI
LAB_NONM
JSR LAB_GTBY ; get byte parameter
PHA ; push GOTO/GOSUB token
CMP #TK_GOSUB ; compare with GOSUB token
BEQ LAB_176B ; branch if GOSUB
CMP #TK_GOTO ; compare with GOTO token
LAB_1767
BNE LAB_16FD ; if not GOTO do syntax error then warm start
; next character was GOTO or GOSUB
LAB_176B
DEC FAC1_3 ; decrement index (byte value)
BNE LAB_1773 ; branch if not zero
PLA ; pull GOTO/GOSUB token
JMP LAB_1602 ; go execute it
LAB_1773
JSR LAB_IGBY ; increment and scan memory
JSR LAB_GFPN ; get fixed-point number into temp integer (skip this n)
; (we could LDX #',' and JSR LAB_SNBL+2, then we
; just BNE LAB_176B for the loop. should be quicker ..
; no we can't, what if we meet a colon or [EOL]?)
CMP #$2C ; compare next character with ","
BEQ LAB_176B ; loop if ","
LAB_177E
PLA ; else pull keyword token (run out of options)
; also dump +/-1 pointer low byte and exit
LAB_177F
RTS
; takes n * 106 + 11 cycles where n is the number of digits
; get fixed-point number into temp integer
LAB_GFPN
LDX #$00 ; clear reg
STX Itempl ; clear temporary integer low byte
LAB_1785
STX Itemph ; save temporary integer high byte
BCS LAB_177F ; return if carry set, end of scan, character was
; not 0-9
CPX #$19 ; compare high byte with $19
TAY ; ensure Zb = 0 if the branch is taken
BCS LAB_1767 ; branch if >=, makes max line # 63999 because next
; bit does *$0A, = 64000, compare at target will fail
; and do syntax error
SBC #'0'-1 ; subtract "0", $2F + carry, from byte
TAY ; copy binary digit
LDA Itempl ; get temporary integer low byte
ASL ; *2 low byte
ROL Itemph ; *2 high byte
ASL ; *2 low byte
ROL Itemph ; *2 high byte, *4
ADC Itempl ; + low byte, *5
STA Itempl ; save it
TXA ; get high byte copy to A
ADC Itemph ; + high byte, *5
ASL Itempl ; *2 low byte, *10d
ROL ; *2 high byte, *10d
TAX ; copy high byte back to X
TYA ; get binary digit back
ADC Itempl ; add number low byte
STA Itempl ; save number low byte
BCC LAB_17B3 ; if no overflow to high byte get next character
INX ; else increment high byte
LAB_17B3
JSR LAB_IGBY ; increment and scan memory
JMP LAB_1785 ; loop for next character
; perform DEC
LAB_DEC
LDA #<LAB_2AFD ; set -1 pointer low byte
.byte $2C ; BIT abs to skip the LDA below
; perform INC
LAB_INC
LDA #<LAB_259C ; set 1 pointer low byte
LAB_17B5
PHA ; save +/-1 pointer low byte
LAB_17B7
JSR LAB_GVAR ; get var address
LDX Dtypef ; get data type flag, $FF=string, $00=numeric
BMI IncrErr ; exit if string
STA Lvarpl ; save var address low byte
STY Lvarph ; save var address high byte
JSR LAB_UFAC ; unpack memory (AY) into FAC1
PLA ; get +/-1 pointer low byte
PHA ; save +/-1 pointer low byte
LDY #>LAB_259C ; set +/-1 pointer high byte (both the same)
JSR LAB_246C ; add (AY) to FAC1
JSR LAB_PFAC ; pack FAC1 into variable (Lvarpl)
JSR LAB_GBYT ; scan memory
CMP #',' ; compare with ","
BNE LAB_177E ; exit if not "," (either end or error)
; was "," so another INCR variable to do
JSR LAB_IGBY ; increment and scan memory
JMP LAB_17B7 ; go do next var
IncrErr
JMP LAB_1ABC ; do "Type mismatch" error then warm start
; perform LET
LAB_LET
JSR LAB_GVAR ; get var address
STA Lvarpl ; save var address low byte
STY Lvarph ; save var address high byte
LDA #TK_EQUAL ; get = token
JSR LAB_SCCA ; scan for CHR$(A), else do syntax error then warm start
LDA Dtypef ; get data type flag, $FF=string, $00=numeric
PHA ; push data type flag
JSR LAB_EVEX ; evaluate expression
PLA ; pop data type flag
ROL ; set carry if type = string
JSR LAB_CKTM ; type match check, set C for string
BNE LAB_17D5 ; branch if string
JMP LAB_PFAC ; pack FAC1 into variable (Lvarpl) and return
; string LET
LAB_17D5
LDY #$02 ; set index to pointer high byte
LDA (des_pl),Y ; get string pointer high byte
CMP Sstorh ; compare bottom of string space high byte
BCC LAB_17F4 ; if less assign value and exit (was in program memory)
BNE LAB_17E6 ; branch if >
; else was equal so compare low bytes
DEY ; decrement index
LDA (des_pl),Y ; get pointer low byte
CMP Sstorl ; compare bottom of string space low byte
BCC LAB_17F4 ; if less assign value and exit (was in program memory)
; pointer was >= to bottom of string space pointer
LAB_17E6
LDY des_ph ; get descriptor pointer high byte
CPY Svarh ; compare start of vars high byte
BCC LAB_17F4 ; branch if less (descriptor is on stack)
BNE LAB_17FB ; branch if greater (descriptor is not on stack)
; else high bytes were equal so ..
LDA des_pl ; get descriptor pointer low byte
CMP Svarl ; compare start of vars low byte
BCS LAB_17FB ; branch if >= (descriptor is not on stack)
LAB_17F4
LDA des_pl ; get descriptor pointer low byte
LDY des_ph ; get descriptor pointer high byte
JMP LAB_1811 ; clean stack, copy descriptor to variable and return
; make space and copy string
LAB_17FB
LDY #$00 ; index to length
LDA (des_pl),Y ; get string length
JSR LAB_209C ; copy string
LDA des_2l ; get descriptor pointer low byte
LDY des_2h ; get descriptor pointer high byte
STA ssptr_l ; save descriptor pointer low byte
STY ssptr_h ; save descriptor pointer high byte
JSR LAB_228A ; copy string from descriptor (sdescr) to (Sutill)
LDA #<FAC1_e ; set descriptor pointer low byte
LDY #>FAC1_e ; get descriptor pointer high byte
; clean stack and assign value to string variable
LAB_1811
STA des_2l ; save descriptor_2 pointer low byte
STY des_2h ; save descriptor_2 pointer high byte
JSR LAB_22EB ; clean descriptor stack, YA = pointer
LDY #$00 ; index to length
LDA (des_2l),Y ; get string length
STA (Lvarpl),Y ; copy to let string variable
INY ; index to string pointer low byte
LDA (des_2l),Y ; get string pointer low byte
STA (Lvarpl),Y ; copy to let string variable
INY ; index to string pointer high byte
LDA (des_2l),Y ; get string pointer high byte
STA (Lvarpl),Y ; copy to let string variable
RTS
; perform GET
LAB_GET
JSR LAB_GVAR ; get var address
STA Lvarpl ; save var address low byte
STY Lvarph ; save var address high byte
JSR INGET ; get input byte
LDX Dtypef ; get data type flag, $FF=string, $00=numeric
BMI LAB_GETS ; go get string character
; was numeric get
TAY ; copy character to Y
JSR LAB_1FD0 ; convert Y to byte in FAC1
JMP LAB_PFAC ; pack FAC1 into variable (Lvarpl) and return
LAB_GETS
PHA ; save character
LDA #$01 ; string is single byte
BCS LAB_IsByte ; branch if byte received
PLA ; string is null
LAB_IsByte
JSR LAB_MSSP ; make string space A bytes long A=$AC=length,
; X=$AD=Sutill=ptr low byte, Y=$AE=Sutilh=ptr high byte
BEQ LAB_NoSt ; skip store if null string
PLA ; get character back
LDY #$00 ; clear index
STA (str_pl),Y ; save byte in string (byte IS string!)
LAB_NoSt
JSR LAB_RTST ; check for space on descriptor stack then put address
; and length on descriptor stack and update stack pointers
JMP LAB_17D5 ; do string LET and return
; perform PRINT
LAB_1829
JSR LAB_18C6 ; print string from Sutill/Sutilh
LAB_182C
JSR LAB_GBYT ; scan memory
; PRINT
LAB_PRINT
BEQ LAB_CRLF ; if nothing following just print CR/LF
LAB_1831
CMP #TK_TAB ; compare with TAB( token
BEQ LAB_18A2 ; go do TAB/SPC
CMP #TK_SPC ; compare with SPC( token
BEQ LAB_18A2 ; go do TAB/SPC
CMP #',' ; compare with ","
BEQ LAB_188B ; go do move to next TAB mark
CMP #';' ; compare with ";"
BEQ LAB_18BD ; if ";" continue with PRINT processing
JSR LAB_EVEX ; evaluate expression
BIT Dtypef ; test data type flag, $FF=string, $00=numeric
BMI LAB_1829 ; branch if string
JSR LAB_296E ; convert FAC1 to string
JSR LAB_20AE ; print " terminated string to Sutill/Sutilh
LDY #$00 ; clear index
; don't check fit if terminal width byte is zero
LDA TWidth ; get terminal width byte
BEQ LAB_185E ; skip check if zero
SEC ; set carry for subtract
SBC TPos ; subtract terminal position
SBC (des_pl),Y ; subtract string length
BCS LAB_185E ; branch if less than terminal width
JSR LAB_CRLF ; else print CR/LF
LAB_185E
JSR LAB_18C6 ; print string from Sutill/Sutilh
BEQ LAB_182C ; always go continue processing line
; CR/LF return to BASIC from BASIC input handler
LAB_1866
LDA #$00 ; clear byte
STA Ibuffs,X ; null terminate input
LDX #<Ibuffs ; set X to buffer start-1 low byte
LDY #>Ibuffs ; set Y to buffer start-1 high byte
; print CR/LF
LAB_CRLF
LDA #$0D ; load [CR]
JSR LAB_PRNA ; go print the character
LDA #$0A ; load [LF]
BNE LAB_PRNA ; go print the character and return, branch always
LAB_188B
LDA TPos ; get terminal position
CMP Iclim ; compare with input column limit
BCC LAB_1897 ; branch if less
JSR LAB_CRLF ; else print CR/LF (next line)
BNE LAB_18BD ; continue with PRINT processing (branch always)
LAB_1897
SEC ; set carry for subtract
LAB_1898
SBC TabSiz ; subtract TAB size
BCS LAB_1898 ; loop if result was +ve
EOR #$FF ; complement it
ADC #$01 ; +1 (twos complement)
BNE LAB_18B6 ; always print A spaces (result is never $00)
; do TAB/SPC
LAB_18A2
PHA ; save token
JSR LAB_SGBY ; scan and get byte parameter
CMP #$29 ; is next character )
BNE LAB_1910 ; if not do syntax error then warm start
PLA ; get token back
CMP #TK_TAB ; was it TAB ?
BNE LAB_18B7 ; if not go do SPC
; calculate TAB offset
TXA ; copy integer value to A
SBC TPos ; subtract terminal position
BCC LAB_18BD ; branch if result was < 0 (can't TAB backwards)
; print A spaces
LAB_18B6
TAX ; copy result to X
LAB_18B7
TXA ; set flags on size for SPC
BEQ LAB_18BD ; branch if result was = $0, already here
; print X spaces
LAB_18BA
JSR LAB_18E0 ; print " "
DEX ; decrement count
BNE LAB_18BA ; loop if not all done
; continue with PRINT processing
LAB_18BD
JSR LAB_IGBY ; increment and scan memory
BNE LAB_1831 ; if more to print go do it
RTS
; print null terminated string from memory
LAB_18C3
JSR LAB_20AE ; print " terminated string to Sutill/Sutilh
; print string from Sutill/Sutilh
LAB_18C6
JSR LAB_22B6 ; pop string off descriptor stack, or from top of string
; space returns with A = length, X=$71=pointer low byte,
; Y=$72=pointer high byte
LDY #$00 ; reset index
TAX ; copy length to X
BEQ LAB_188C ; exit (RTS) if null string
LAB_18CD
LDA (ut1_pl),Y ; get next byte
JSR LAB_PRNA ; go print the character
INY ; increment index
DEX ; decrement count
BNE LAB_18CD ; loop if not done yet
RTS
; Print single format character
; print " "
LAB_18E0
LDA #$20 ; load " "
.byte $2C ; change next line to BIT LAB_3FA9
; print "?" character
LAB_18E3
LDA #$3F ; load "?" character
; print character in A
; now includes the null handler
; also includes infinite line length code
; note! some routines expect this one to exit with Zb=0
LAB_PRNA
CMP #' ' ; compare with " "
BCC LAB_18F9 ; branch if less (non printing)
; else printable character
PHA ; save the character
; don't check fit if terminal width byte is zero
LDA TWidth ; get terminal width
BNE LAB_18F0 ; branch if not zero (not infinite length)
; is "infinite line" so check TAB position
LDA TPos ; get position
SBC TabSiz ; subtract TAB size, carry set by CMP #$20 above
BNE LAB_18F7 ; skip reset if different
STA TPos ; else reset position
BEQ LAB_18F7 ; go print character
LAB_18F0
CMP TPos ; compare with terminal character position
BNE LAB_18F7 ; branch if not at end of line
JSR LAB_CRLF ; else print CR/LF
LAB_18F7
INC TPos ; increment terminal position
PLA ; get character back
LAB_18F9
JSR V_OUTP ; output byte via output vector
CMP #$0D ; compare with [CR]
BNE LAB_188A ; branch if not [CR]
; else print nullct nulls after the [CR]
STX TempB ; save buffer index
LDX Nullct ; get null count
BEQ LAB_1886 ; branch if no nulls
LDA #$00 ; load [NULL]
LAB_1880
JSR LAB_PRNA ; go print the character
DEX ; decrement count
BNE LAB_1880 ; loop if not all done
LDA #$0D ; restore the character (and set the flags)
LAB_1886
STX TPos ; clear terminal position (X always = zero when we get here)
LDX TempB ; restore buffer index
LAB_188A
AND #$FF ; set the flags
LAB_188C
RTS
; handle bad input data
LAB_1904
LDA Imode ; get input mode flag, $00=INPUT, $00=READ
BPL LAB_1913 ; branch if INPUT (go do redo)
LDA Dlinel ; get current DATA line low byte
LDY Dlineh ; get current DATA line high byte
STA Clinel ; save current line low byte
STY Clineh ; save current line high byte
LAB_1910
JMP LAB_SNER ; do syntax error then warm start
; mode was INPUT
LAB_1913
LDA #<LAB_REDO ; point to redo message (low addr)
LDY #>LAB_REDO ; point to redo message (high addr)
JSR LAB_18C3 ; print null terminated string from memory
LDA Cpntrl ; get continue pointer low byte
LDY Cpntrh ; get continue pointer high byte
STA Bpntrl ; save BASIC execute pointer low byte
STY Bpntrh ; save BASIC execute pointer high byte
RTS
; perform INPUT
LAB_INPUT
CMP #$22 ; compare next byte with open quote
BNE LAB_1934 ; branch if no prompt string
JSR LAB_1BC1 ; print "..." string
LDA #$3B ; load A with ";"
JSR LAB_SCCA ; scan for CHR$(A), else do syntax error then warm start
JSR LAB_18C6 ; print string from Sutill/Sutilh
; done with prompt, now get data
LAB_1934
JSR LAB_CKRN ; check not Direct, back here if ok
JSR LAB_INLN ; print "? " and get BASIC input
LDA #$00 ; set mode = INPUT
CMP Ibuffs ; test first byte in buffer
BNE LAB_1953 ; branch if not null input
CLC ; was null input so clear carry to exit program
JMP LAB_1647 ; go do BREAK exit
; perform READ
LAB_READ
LDX Dptrl ; get DATA pointer low byte
LDY Dptrh ; get DATA pointer high byte
LDA #$80 ; set mode = READ
LAB_1953
STA Imode ; set input mode flag, $00=INPUT, $80=READ
STX Rdptrl ; save READ pointer low byte
STY Rdptrh ; save READ pointer high byte
; READ or INPUT next variable from list
LAB_195B
JSR LAB_GVAR ; get (var) address
STA Lvarpl ; save address low byte
STY Lvarph ; save address high byte
LDA Bpntrl ; get BASIC execute pointer low byte
LDY Bpntrh ; get BASIC execute pointer high byte
STA Itempl ; save as temporary integer low byte
STY Itemph ; save as temporary integer high byte
LDX Rdptrl ; get READ pointer low byte
LDY Rdptrh ; get READ pointer high byte
STX Bpntrl ; set BASIC execute pointer low byte
STY Bpntrh ; set BASIC execute pointer high byte
JSR LAB_GBYT ; scan memory
BNE LAB_1988 ; branch if not null
; pointer was to null entry
BIT Imode ; test input mode flag, $00=INPUT, $80=READ
BMI LAB_19DD ; branch if READ
; mode was INPUT
JSR LAB_18E3 ; print "?" character (double ? for extended input)
JSR LAB_INLN ; print "? " and get BASIC input
STX Bpntrl ; set BASIC execute pointer low byte
STY Bpntrh ; set BASIC execute pointer high byte
LAB_1985
JSR LAB_GBYT ; scan memory
LAB_1988
BIT Dtypef ; test data type flag, $FF=string, $00=numeric
BPL LAB_19B0 ; branch if numeric
; else get string
STA Srchc ; save search character
CMP #$22 ; was it " ?
BEQ LAB_1999 ; branch if so
LDA #':' ; else search character is ":"
STA Srchc ; set new search character
LDA #',' ; other search character is ","
CLC ; clear carry for add
LAB_1999
STA Asrch ; set second search character
LDA Bpntrl ; get BASIC execute pointer low byte
LDY Bpntrh ; get BASIC execute pointer high byte
ADC #$00 ; c is =1 if we came via the BEQ LAB_1999, else =0
BCC LAB_19A4 ; branch if no execute pointer low byte rollover
INY ; else increment high byte
LAB_19A4
JSR LAB_20B4 ; print Srchc or Asrch terminated string to Sutill/Sutilh
JSR LAB_23F3 ; restore BASIC execute pointer from temp (Btmpl/Btmph)
JSR LAB_17D5 ; go do string LET
JMP LAB_19B6 ; go check string terminator
; get numeric INPUT
LAB_19B0
JSR LAB_2887 ; get FAC1 from string
JSR LAB_PFAC ; pack FAC1 into (Lvarpl)
LAB_19B6
JSR LAB_GBYT ; scan memory
BEQ LAB_19C5 ; branch if null (last entry)
CMP #',' ; else compare with ","
BEQ LAB_19C2 ; branch if ","
JMP LAB_1904 ; else go handle bad input data
; got good input data
LAB_19C2
JSR LAB_IGBY ; increment and scan memory
LAB_19C5
LDA Bpntrl ; get BASIC execute pointer low byte (temp READ/INPUT ptr)
LDY Bpntrh ; get BASIC execute pointer high byte (temp READ/INPUT ptr)
STA Rdptrl ; save for now
STY Rdptrh ; save for now
LDA Itempl ; get temporary integer low byte (temp BASIC execute ptr)
LDY Itemph ; get temporary integer high byte (temp BASIC execute ptr)
STA Bpntrl ; set BASIC execute pointer low byte
STY Bpntrh ; set BASIC execute pointer high byte
JSR LAB_GBYT ; scan memory
BEQ LAB_1A03 ; if null go do extra ignored message
JSR LAB_1C01 ; else scan for "," , else do syntax error then warm start
JMP LAB_195B ; go INPUT next variable from list
; find next DATA statement or do "Out of DATA" error
LAB_19DD
JSR LAB_SNBS ; scan for next BASIC statement ([:] or [EOL])
INY ; increment index
TAX ; copy character ([:] or [EOL])
BNE LAB_19F6 ; branch if [:]
LDX #$06 ; set for "Out of DATA" error
INY ; increment index, now points to next line pointer high byte
LDA (Bpntrl),Y ; get next line pointer high byte
BEQ LAB_1A54 ; branch if end (eventually does error X)
INY ; increment index
LDA (Bpntrl),Y ; get next line # low byte
STA Dlinel ; save current DATA line low byte
INY ; increment index
LDA (Bpntrl),Y ; get next line # high byte
INY ; increment index
STA Dlineh ; save current DATA line high byte
LAB_19F6
LDA (Bpntrl),Y ; get byte
INY ; increment index
TAX ; copy to X
JSR LAB_170F ; set BASIC execute pointer
CPX #TK_DATA ; compare with "DATA" token
BEQ LAB_1985 ; was "DATA" so go do next READ
BNE LAB_19DD ; go find next statement if not "DATA"
; end of INPUT/READ routine
LAB_1A03
LDA Rdptrl ; get temp READ pointer low byte
LDY Rdptrh ; get temp READ pointer high byte
LDX Imode ; get input mode flag, $00=INPUT, $80=READ
BPL LAB_1A0E ; branch if INPUT
JMP LAB_1624 ; save AY as DATA pointer and return
; we were getting INPUT
LAB_1A0E
LDY #$00 ; clear index
LDA (Rdptrl),Y ; get next byte
BNE LAB_1A1B ; error if not end of INPUT
RTS
; user typed too much
LAB_1A1B
LDA #<LAB_IMSG ; point to extra ignored message (low addr)
LDY #>LAB_IMSG ; point to extra ignored message (high addr)
JMP LAB_18C3 ; print null terminated string from memory and return
; search the stack for FOR activity
; exit with z=1 if FOR else exit with z=0
LAB_11A1
TSX ; copy stack pointer
INX ; +1 pass return address
INX ; +2 pass return address
INX ; +3 pass calling routine return address
INX ; +4 pass calling routine return address
LAB_11A6
LDA LAB_STAK+1,X ; get token byte from stack
CMP #TK_FOR ; is it FOR token
BNE LAB_11CE ; exit if not FOR token
; was FOR token
LDA Frnxth ; get var pointer for FOR/NEXT high byte
BNE LAB_11BB ; branch if not null
LDA LAB_STAK+2,X ; get FOR variable pointer low byte
STA Frnxtl ; save var pointer for FOR/NEXT low byte
LDA LAB_STAK+3,X ; get FOR variable pointer high byte
STA Frnxth ; save var pointer for FOR/NEXT high byte
LAB_11BB
CMP LAB_STAK+3,X ; compare var pointer with stacked var pointer (high byte)
BNE LAB_11C7 ; branch if no match
LDA Frnxtl ; get var pointer for FOR/NEXT low byte
CMP LAB_STAK+2,X ; compare var pointer with stacked var pointer (low byte)
BEQ LAB_11CE ; exit if match found
LAB_11C7
TXA ; copy index
CLC ; clear carry for add
ADC #$10 ; add FOR stack use size
TAX ; copy back to index
BNE LAB_11A6 ; loop if not at start of stack
LAB_11CE
RTS
; perform NEXT
LAB_NEXT
BNE LAB_1A46 ; branch if NEXT var
LDY #$00 ; else clear Y
BEQ LAB_1A49 ; branch always (no variable to search for)
; NEXT var
LAB_1A46
JSR LAB_GVAR ; get variable address
LAB_1A49
STA Frnxtl ; store variable pointer low byte
STY Frnxth ; store variable pointer high byte
; (both cleared if no variable defined)
JSR LAB_11A1 ; search the stack for FOR activity
BEQ LAB_1A56 ; branch if found
LDX #$00 ; else set error $00 ("NEXT without FOR" error)
LAB_1A54
BEQ LAB_1ABE ; do error #X, then warm start
LAB_1A56
TXS ; set stack pointer, X set by search, dumps return addresses
TXA ; copy stack pointer
SEC ; set carry for subtract
SBC #$F7 ; point to TO var
STA ut2_pl ; save pointer to TO var for compare
ADC #$FB ; point to STEP var
LDY #>LAB_STAK ; point to stack page high byte
JSR LAB_UFAC ; unpack memory (STEP value) into FAC1
TSX ; get stack pointer back
LDA LAB_STAK+8,X ; get step sign
STA FAC1_s ; save FAC1 sign (b7)
LDA Frnxtl ; get FOR variable pointer low byte
LDY Frnxth ; get FOR variable pointer high byte
JSR LAB_246C ; add (FOR variable) to FAC1
JSR LAB_PFAC ; pack FAC1 into (FOR variable)
LDY #>LAB_STAK ; point to stack page high byte
JSR LAB_27FA ; compare FAC1 with (Y,ut2_pl) (TO value)
TSX ; get stack pointer back
CMP LAB_STAK+8,X ; compare step sign
BEQ LAB_1A9B ; branch if = (loop complete)
; loop back and do it all again
LDA LAB_STAK+$0D,X ; get FOR line low byte
STA Clinel ; save current line low byte
LDA LAB_STAK+$0E,X ; get FOR line high byte
STA Clineh ; save current line high byte
LDA LAB_STAK+$10,X ; get BASIC execute pointer low byte
STA Bpntrl ; save BASIC execute pointer low byte
LDA LAB_STAK+$0F,X ; get BASIC execute pointer high byte
STA Bpntrh ; save BASIC execute pointer high byte
LAB_1A98
JMP LAB_15C2 ; go do interpreter inner loop
; loop complete so carry on
LAB_1A9B
TXA ; stack copy to A
ADC #$0F ; add $10 ($0F+carry) to dump FOR structure
TAX ; copy back to index
TXS ; copy to stack pointer
JSR LAB_GBYT ; scan memory
CMP #',' ; compare with ","
BNE LAB_1A98 ; branch if not "," (go do interpreter inner loop)
; was "," so another NEXT variable to do
JSR LAB_IGBY ; else increment and scan memory
JSR LAB_1A46 ; do NEXT (var)
; evaluate expression and check is numeric, else do type mismatch
LAB_EVNM
JSR LAB_EVEX ; evaluate expression
; check if source is numeric, else do type mismatch
LAB_CTNM
CLC ; destination is numeric
.byte $24 ; makes next line BIT $38
; check if source is string, else do type mismatch
LAB_CTST
SEC ; required type is string
; type match check, set C for string, clear C for numeric
LAB_CKTM
BIT Dtypef ; test data type flag, $FF=string, $00=numeric
BMI LAB_1ABA ; branch if data type is string
; else data type was numeric
BCS LAB_1ABC ; if required type is string do type mismatch error
LAB_1AB9
RTS
; data type was string, now check required type
LAB_1ABA
BCS LAB_1AB9 ; exit if required type is string
; else do type mismatch error
LAB_1ABC
LDX #$18 ; error code $18 ("Type mismatch" error)
LAB_1ABE
JMP LAB_XERR ; do error #X, then warm start
; evaluate expression
LAB_EVEX
LDX Bpntrl ; get BASIC execute pointer low byte
BNE LAB_1AC7 ; skip next if not zero
DEC Bpntrh ; else decrement BASIC execute pointer high byte
LAB_1AC7
DEC Bpntrl ; decrement BASIC execute pointer low byte
LAB_EVEZ
LDA #$00 ; set null precedence (flag done)
LAB_1ACC
PHA ; push precedence byte
LDA #$02 ; 2 bytes
JSR LAB_1212 ; check room on stack for A bytes
JSR LAB_GVAL ; get value from line
LDA #$00 ; clear A
STA comp_f ; clear compare function flag
LAB_1ADB
JSR LAB_GBYT ; scan memory
LAB_1ADE
SEC ; set carry for subtract
SBC #TK_GT ; subtract token for > (lowest comparison function)
BCC LAB_1AFA ; branch if < TK_GT
CMP #$03 ; compare with ">" to "<" tokens
BCS LAB_1AFA ; branch if >= TK_SGN (highest evaluation function +1)
; was token for > = or < (A = 0, 1 or 2)
CMP #$01 ; compare with token for =
ROL ; *2, b0 = carry (=1 if token was = or <)
; (A = 0, 3 or 5)
EOR #$01 ; toggle b0
; (A = 1, 2 or 4. 1 if >, 2 if =, 4 if <)
EOR comp_f ; EOR with compare function flag bits
CMP comp_f ; compare with compare function flag
BCC LAB_1B53 ; if <(comp_f) do syntax error then warm start
; was more than one <, = or >)
STA comp_f ; save new compare function flag
JSR LAB_IGBY ; increment and scan memory
JMP LAB_1ADE ; go do next character
; token is < ">" or > "<" tokens
LAB_1AFA
LDX comp_f ; get compare function flag
BNE LAB_1B2A ; branch if compare function
BCS LAB_1B78 ; go do functions
; else was < TK_GT so is operator or lower
ADC #TK_GT-TK_PLUS ; add # of operators (+, -, *, /, ^, AND, OR or EOR)
BCC LAB_1B78 ; branch if < + operator
; carry was set so token was +, -, *, /, ^, AND, OR or EOR
BNE LAB_1B0B ; branch if not + token
BIT Dtypef ; test data type flag, $FF=string, $00=numeric
BPL LAB_1B0B ; branch if not string
; will only be $00 if type is string and token was +
JMP LAB_224D ; add strings, string 1 is in descriptor des_pl, string 2
; is in line, and return
LAB_1B0B
STA ut1_pl ; save it
ASL ; *2
ADC ut1_pl ; *3
TAY ; copy to index
LAB_1B13
PLA ; pull previous precedence
CMP LAB_OPPT,Y ; compare with precedence byte
BCS LAB_1B7D ; branch if A >=
JSR LAB_CTNM ; check if source is numeric, else do type mismatch
LAB_1B1C
PHA ; save precedence
LAB_1B1D
JSR LAB_1B43 ; get vector, execute function then continue evaluation
PLA ; restore precedence
LDY prstk ; get precedence stacked flag
BPL LAB_1B3C ; branch if stacked values
TAX ; copy precedence (set flags)
BEQ LAB_1B9D ; exit if done
BNE LAB_1B86 ; else pop FAC2 and return, branch always
LAB_1B2A
ROL Dtypef ; shift data type flag into Cb
TXA ; copy compare function flag
STA Dtypef ; clear data type flag, X is 0xxx xxxx
ROL ; shift data type into compare function byte b0
LDX Bpntrl ; get BASIC execute pointer low byte
BNE LAB_1B34 ; branch if no underflow
DEC Bpntrh ; else decrement BASIC execute pointer high byte
LAB_1B34
DEC Bpntrl ; decrement BASIC execute pointer low byte
TK_LT_PLUS = TK_LT-TK_PLUS
LDY #TK_LT_PLUS*3 ; set offset to last operator entry
STA comp_f ; save new compare function flag
BNE LAB_1B13 ; branch always
LAB_1B3C
CMP LAB_OPPT,Y ;.compare with stacked function precedence
BCS LAB_1B86 ; branch if A >=, pop FAC2 and return
BCC LAB_1B1C ; branch always
;.get vector, execute function then continue evaluation
LAB_1B43
LDA LAB_OPPT+2,Y ; get function vector high byte
PHA ; onto stack
LDA LAB_OPPT+1,Y ; get function vector low byte
PHA ; onto stack
; now push sign, round FAC1 and put on stack
JSR LAB_1B5B ; function will return here, then the next RTS will call
; the function
LDA comp_f ; get compare function flag
PHA ; push compare evaluation byte
LDA LAB_OPPT,Y ; get precedence byte
JMP LAB_1ACC ; continue evaluating expression
LAB_1B53
JMP LAB_SNER ; do syntax error then warm start
; push sign, round FAC1 and put on stack
LAB_1B5B
PLA ; get return addr low byte
STA ut1_pl ; save it
INC ut1_pl ; increment it (was ret-1 pushed? yes!)
; note! no check is made on the high byte! if the calling
; routine assembles to a page edge then this all goes
; horribly wrong !!!
PLA ; get return addr high byte
STA ut1_ph ; save it
LDA FAC1_s ; get FAC1 sign (b7)
PHA ; push sign
; round FAC1 and put on stack
LAB_1B66
JSR LAB_27BA ; round FAC1
LDA FAC1_3 ; get FAC1 mantissa3
PHA ; push on stack
LDA FAC1_2 ; get FAC1 mantissa2
PHA ; push on stack
LDA FAC1_1 ; get FAC1 mantissa1
PHA ; push on stack
LDA FAC1_e ; get FAC1 exponent
PHA ; push on stack
JMP (ut1_pl) ; return, sort of
; do functions
LAB_1B78
LDY #$FF ; flag function
PLA ; pull precedence byte
LAB_1B7B
BEQ LAB_1B9D ; exit if done
LAB_1B7D
CMP #$64 ; compare previous precedence with $64
BEQ LAB_1B84 ; branch if was $64 (< function)
JSR LAB_CTNM ; check if source is numeric, else do type mismatch
LAB_1B84
STY prstk ; save precedence stacked flag
; pop FAC2 and return
LAB_1B86
PLA ; pop byte
LSR ; shift out comparison evaluation lowest bit
STA Cflag ; save comparison evaluation flag
PLA ; pop exponent
STA FAC2_e ; save FAC2 exponent
PLA ; pop mantissa1
STA FAC2_1 ; save FAC2 mantissa1
PLA ; pop mantissa2
STA FAC2_2 ; save FAC2 mantissa2
PLA ; pop mantissa3
STA FAC2_3 ; save FAC2 mantissa3
PLA ; pop sign
STA FAC2_s ; save FAC2 sign (b7)
EOR FAC1_s ; EOR FAC1 sign (b7)
STA FAC_sc ; save sign compare (FAC1 EOR FAC2)
LAB_1B9D
LDA FAC1_e ; get FAC1 exponent
RTS
; print "..." string to string util area
LAB_1BC1
LDA Bpntrl ; get BASIC execute pointer low byte
LDY Bpntrh ; get BASIC execute pointer high byte
ADC #$00 ; add carry to low byte
BCC LAB_1BCA ; branch if no overflow
INY ; increment high byte
LAB_1BCA
JSR LAB_20AE ; print " terminated string to Sutill/Sutilh
JMP LAB_23F3 ; restore BASIC execute pointer from temp and return
; get value from line
LAB_GVAL
JSR LAB_IGBY ; increment and scan memory
BCS LAB_1BAC ; branch if not numeric character
; else numeric string found (e.g. 123)
LAB_1BA9
JMP LAB_2887 ; get FAC1 from string and return
; get value from line .. continued
; wasn't a number so ..
LAB_1BAC
TAX ; set the flags
BMI LAB_1BD0 ; if -ve go test token values
; else it is either a string, number, variable or (<expr>)
CMP #'$' ; compare with "$"
BEQ LAB_1BA9 ; branch if "$", hex number
CMP #'%' ; else compare with "%"
BEQ LAB_1BA9 ; branch if "%", binary number
CMP #'.' ; compare with "."
BEQ LAB_1BA9 ; if so get FAC1 from string and return (e.g. was .123)
; it wasn't any sort of number so ..
CMP #$22 ; compare with "
BEQ LAB_1BC1 ; branch if open quote
; wasn't any sort of number so ..
; evaluate expression within parentheses
CMP #'(' ; compare with "("
BNE LAB_1C18 ; if not "(" get (var), return value in FAC1 and $ flag
LAB_1BF7
JSR LAB_EVEZ ; evaluate expression, no decrement
; all the 'scan for' routines return the character after the sought character
; scan for ")" , else do syntax error then warm start
LAB_1BFB
LDA #$29 ; load A with ")"
; scan for CHR$(A) , else do syntax error then warm start
LAB_SCCA
LDY #$00 ; clear index
CMP (Bpntrl),Y ; check next byte is = A
BNE LAB_SNER ; if not do syntax error then warm start
JMP LAB_IGBY ; increment and scan memory then return
; scan for "(" , else do syntax error then warm start
LAB_1BFE
LDA #$28 ; load A with "("
BNE LAB_SCCA ; scan for CHR$(A), else do syntax error then warm start
; (branch always)
; scan for "," , else do syntax error then warm start
LAB_1C01
LDA #$2C ; load A with ","
BNE LAB_SCCA ; scan for CHR$(A), else do syntax error then warm start
; (branch always)
; syntax error then warm start
LAB_SNER
LDX #$02 ; error code $02 ("Syntax" error)
JMP LAB_XERR ; do error #X, then warm start
; get value from line .. continued
; do tokens
LAB_1BD0
CMP #TK_MINUS ; compare with token for -
BEQ LAB_1C11 ; branch if - token (do set-up for functions)
; wasn't -n so ..
CMP #TK_PLUS ; compare with token for +
BEQ LAB_GVAL ; branch if + token (+n = n so ignore leading +)
CMP #TK_NOT ; compare with token for NOT
BNE LAB_1BE7 ; branch if not token for NOT
; was NOT token
TK_EQUAL_PLUS = TK_EQUAL-TK_PLUS
LDY #TK_EQUAL_PLUS*3 ; offset to NOT function
BNE LAB_1C13 ; do set-up for function then execute (branch always)
; do = compare
LAB_EQUAL
JSR LAB_EVIR ; evaluate integer expression (no sign check)
LDA FAC1_3 ; get FAC1 mantissa3
EOR #$FF ; invert it
TAY ; copy it
LDA FAC1_2 ; get FAC1 mantissa2
EOR #$FF ; invert it
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; get value from line .. continued
; wasn't +, -, or NOT so ..
LAB_1BE7
CMP #TK_FN ; compare with token for FN
BNE LAB_1BEE ; branch if not token for FN
JMP LAB_201E ; go evaluate FNx
; get value from line .. continued
; wasn't +, -, NOT or FN so ..
LAB_1BEE
SBC #TK_SGN ; subtract with token for SGN
BCS LAB_1C27 ; if a function token go do it
JMP LAB_SNER ; else do syntax error
; set-up for functions
LAB_1C11
TK_GT_PLUS = TK_GT-TK_PLUS
LDY #TK_GT_PLUS*3 ; set offset from base to > operator
LAB_1C13
PLA ; dump return address low byte
PLA ; dump return address high byte
JMP LAB_1B1D ; execute function then continue evaluation
; variable name set-up
; get (var), return value in FAC_1 and $ flag
LAB_1C18
JSR LAB_GVAR ; get (var) address
STA FAC1_2 ; save address low byte in FAC1 mantissa2
STY FAC1_3 ; save address high byte in FAC1 mantissa3
LDX Dtypef ; get data type flag, $FF=string, $00=numeric
BMI LAB_1C25 ; if string then return (does RTS)
LAB_1C24
JMP LAB_UFAC ; unpack memory (AY) into FAC1
LAB_1C25
RTS
; get value from line .. continued
; only functions left so ..
; set up function references
; new for V2.0+ this replaces a lot of IF .. THEN .. ELSEIF .. THEN .. that was needed
; to process function calls. now the function vector is computed and pushed on the stack
; and the preprocess offset is read. if the preprocess offset is non zero then the vector
; is calculated and the routine called, if not this routine just does RTS. whichever
; happens the RTS at the end of this routine, or the end of the preprocess routine, calls
; the function code
; this also removes some less than elegant code that was used to bypass type checking
; for functions that returned strings
LAB_1C27
ASL ; *2 (2 bytes per function address)
TAY ; copy to index
LDA LAB_FTBM,Y ; get function jump vector high byte
PHA ; push functions jump vector high byte
LDA LAB_FTBL,Y ; get function jump vector low byte
PHA ; push functions jump vector low byte
LDA LAB_FTPM,Y ; get function pre process vector high byte
BEQ LAB_1C56 ; skip pre process if null vector
PHA ; push functions pre process vector high byte
LDA LAB_FTPL,Y ; get function pre process vector low byte
PHA ; push functions pre process vector low byte
LAB_1C56
RTS ; do function, or pre process, call
; process string expression in parenthesis
LAB_PPFS
JSR LAB_1BF7 ; process expression in parenthesis
JMP LAB_CTST ; check if source is string then do function,
; else do type mismatch
; process numeric expression in parenthesis
LAB_PPFN
JSR LAB_1BF7 ; process expression in parenthesis
JMP LAB_CTNM ; check if source is numeric then do function,
; else do type mismatch
; set numeric data type and increment BASIC execute pointer
LAB_PPBI
LSR Dtypef ; clear data type flag, $FF=string, $00=numeric
JMP LAB_IGBY ; increment and scan memory then do function
; process string for LEFT$, RIGHT$ or MID$
LAB_LRMS
JSR LAB_EVEZ ; evaluate (should be string) expression
JSR LAB_1C01 ; scan for ",", else do syntax error then warm start
JSR LAB_CTST ; check if source is string, else do type mismatch
PLA ; get function jump vector low byte
TAX ; save functions jump vector low byte
PLA ; get function jump vector high byte
TAY ; save functions jump vector high byte
LDA des_ph ; get descriptor pointer high byte
PHA ; push string pointer high byte
LDA des_pl ; get descriptor pointer low byte
PHA ; push string pointer low byte
TYA ; get function jump vector high byte back
PHA ; save functions jump vector high byte
TXA ; get function jump vector low byte back
PHA ; save functions jump vector low byte
JSR LAB_GTBY ; get byte parameter
TXA ; copy byte parameter to A
RTS ; go do function
; process numeric expression(s) for BIN$ or HEX$
LAB_BHSS
JSR LAB_EVEZ ; process expression
JSR LAB_CTNM ; check if source is numeric, else do type mismatch
LDA FAC1_e ; get FAC1 exponent
CMP #$98 ; compare with exponent = 2^24
BCS LAB_BHER ; branch if n>=2^24 (is too big)
JSR LAB_2831 ; convert FAC1 floating-to-fixed
LDX #$02 ; 3 bytes to do
LAB_CFAC
LDA FAC1_1,X ; get byte from FAC1
STA nums_1,X ; save byte to temp
DEX ; decrement index
BPL LAB_CFAC ; copy FAC1 mantissa to temp
JSR LAB_GBYT ; get next BASIC byte
LDX #$00 ; set default to no leading "0"s
CMP #')' ; compare with close bracket
BEQ LAB_1C54 ; if ")" go do rest of function
JSR LAB_SCGB ; scan for "," and get byte
JSR LAB_GBYT ; get last byte back
CMP #')' ; is next character )
BNE LAB_BHER ; if not ")" go do error
LAB_1C54
RTS ; else do function
LAB_BHER
JMP LAB_FCER ; do function call error then warm start
; perform EOR
; added operator format is the same as AND or OR, precedence is the same as OR
; this bit worked first time but it took a while to sort out the operator table
; pointers and offsets afterwards!
LAB_EOR
JSR GetFirst ; get first integer expression (no sign check)
EOR XOAw_l ; EOR with expression 1 low byte
TAY ; save in Y
LDA FAC1_2 ; get FAC1 mantissa2
EOR XOAw_h ; EOR with expression 1 high byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; perform OR
LAB_OR
JSR GetFirst ; get first integer expression (no sign check)
ORA XOAw_l ; OR with expression 1 low byte
TAY ; save in Y
LDA FAC1_2 ; get FAC1 mantissa2
ORA XOAw_h ; OR with expression 1 high byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; perform AND
LAB_AND
JSR GetFirst ; get first integer expression (no sign check)
AND XOAw_l ; AND with expression 1 low byte
TAY ; save in Y
LDA FAC1_2 ; get FAC1 mantissa2
AND XOAw_h ; AND with expression 1 high byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; get first value for OR, AND or EOR
GetFirst
JSR LAB_EVIR ; evaluate integer expression (no sign check)
LDA FAC1_2 ; get FAC1 mantissa2
STA XOAw_h ; save it
LDA FAC1_3 ; get FAC1 mantissa3
STA XOAw_l ; save it
JSR LAB_279B ; copy FAC2 to FAC1 (get 2nd value in expression)
JSR LAB_EVIR ; evaluate integer expression (no sign check)
LDA FAC1_3 ; get FAC1 mantissa3
LAB_1C95
RTS
; perform comparisons
; do < compare
LAB_LTHAN
JSR LAB_CKTM ; type match check, set C for string
BCS LAB_1CAE ; branch if string
; do numeric < compare
LDA FAC2_s ; get FAC2 sign (b7)
ORA #$7F ; set all non sign bits
AND FAC2_1 ; and FAC2 mantissa1 (AND in sign bit)
STA FAC2_1 ; save FAC2 mantissa1
LDA #<FAC2_e ; set pointer low byte to FAC2
LDY #>FAC2_e ; set pointer high byte to FAC2
JSR LAB_27F8 ; compare FAC1 with FAC2 (AY)
TAX ; copy result
JMP LAB_1CE1 ; go evaluate result
; do string < compare
LAB_1CAE
LSR Dtypef ; clear data type flag, $FF=string, $00=numeric
DEC comp_f ; clear < bit in compare function flag
JSR LAB_22B6 ; pop string off descriptor stack, or from top of string
; space returns with A = length, X=pointer low byte,
; Y=pointer high byte
STA str_ln ; save length
STX str_pl ; save string pointer low byte
STY str_ph ; save string pointer high byte
LDA FAC2_2 ; get descriptor pointer low byte
LDY FAC2_3 ; get descriptor pointer high byte
JSR LAB_22BA ; pop (YA) descriptor off stack or from top of string space
; returns with A = length, X=pointer low byte,
; Y=pointer high byte
STX FAC2_2 ; save string pointer low byte
STY FAC2_3 ; save string pointer high byte
TAX ; copy length
SEC ; set carry for subtract
SBC str_ln ; subtract string 1 length
BEQ LAB_1CD6 ; branch if str 1 length = string 2 length
LDA #$01 ; set str 1 length > string 2 length
BCC LAB_1CD6 ; branch if so
LDX str_ln ; get string 1 length
LDA #$FF ; set str 1 length < string 2 length
LAB_1CD6
STA FAC1_s ; save length compare
LDY #$FF ; set index
INX ; adjust for loop
LAB_1CDB
INY ; increment index
DEX ; decrement count
BNE LAB_1CE6 ; branch if still bytes to do
LDX FAC1_s ; get length compare back
LAB_1CE1
BMI LAB_1CF2 ; branch if str 1 < str 2
CLC ; flag str 1 <= str 2
BCC LAB_1CF2 ; go evaluate result
LAB_1CE6
LDA (FAC2_2),Y ; get string 2 byte
CMP (FAC1_1),Y ; compare with string 1 byte
BEQ LAB_1CDB ; loop if bytes =
LDX #$FF ; set str 1 < string 2
BCS LAB_1CF2 ; branch if so
LDX #$01 ; set str 1 > string 2
LAB_1CF2
INX ; x = 0, 1 or 2
TXA ; copy to A
ROL ; *2 (1, 2 or 4)
AND Cflag ; AND with comparison evaluation flag
BEQ LAB_1CFB ; branch if 0 (compare is false)
LDA #$FF ; else set result true
LAB_1CFB
JMP LAB_27DB ; save A as integer byte and return
LAB_1CFE
JSR LAB_1C01 ; scan for ",", else do syntax error then warm start
; perform DIM
LAB_DIM
TAX ; copy "DIM" flag to X
JSR LAB_1D10 ; search for variable
JSR LAB_GBYT ; scan memory
BNE LAB_1CFE ; scan for "," and loop if not null
RTS
; perform << (left shift)
LAB_LSHIFT
JSR GetPair ; get integer expression and byte (no sign check)
LDA FAC1_2 ; get expression high byte
LDX TempB ; get shift count
BEQ NoShift ; branch if zero
CPX #$10 ; compare bit count with 16d
BCS TooBig ; branch if >=
Ls_loop
ASL FAC1_3 ; shift low byte
ROL ; shift high byte
DEX ; decrement bit count
BNE Ls_loop ; loop if shift not complete
LDY FAC1_3 ; get expression low byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; perform >> (right shift)
LAB_RSHIFT
JSR GetPair ; get integer expression and byte (no sign check)
LDA FAC1_2 ; get expression high byte
LDX TempB ; get shift count
BEQ NoShift ; branch if zero
CPX #$10 ; compare bit count with 16d
BCS TooBig ; branch if >=
Rs_loop
LSR ; shift high byte
ROR FAC1_3 ; shift low byte
DEX ; decrement bit count
BNE Rs_loop ; loop if shift not complete
NoShift
LDY FAC1_3 ; get expression low byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
TooBig
LDA #$00 ; clear high byte
TAY ; copy to low byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
GetPair
JSR LAB_EVBY ; evaluate byte expression, result in X
STX TempB ; save it
JSR LAB_279B ; copy FAC2 to FAC1 (get 2nd value in expression)
JMP LAB_EVIR ; evaluate integer expression (no sign check)
; search for variable
; return pointer to variable in Cvaral/Cvarah
LAB_GVAR
LDX #$00 ; set DIM flag = $00
JSR LAB_GBYT ; scan memory (1st character)
LAB_1D10
STX Defdim ; save DIM flag
LAB_1D12
STA Varnm1 ; save 1st character
AND #$7F ; clear FN flag bit
JSR LAB_CASC ; check byte, return C=0 if<"A" or >"Z"
BCS LAB_1D1F ; branch if ok
JMP LAB_SNER ; else syntax error then warm start
; was variable name so ..
LAB_1D1F
LDX #$00 ; clear 2nd character temp
STX Dtypef ; clear data type flag, $FF=string, $00=numeric
JSR LAB_IGBY ; increment and scan memory (2nd character)
BCC LAB_1D2D ; branch if character = "0"-"9" (ok)
; 2nd character wasn't "0" to "9" so ..
JSR LAB_CASC ; check byte, return C=0 if<"A" or >"Z"
BCC LAB_1D38 ; branch if <"A" or >"Z" (go check if string)
LAB_1D2D
TAX ; copy 2nd character
; ignore further (valid) characters in the variable name
LAB_1D2E
JSR LAB_IGBY ; increment and scan memory (3rd character)
BCC LAB_1D2E ; loop if character = "0"-"9" (ignore)
JSR LAB_CASC ; check byte, return C=0 if<"A" or >"Z"
BCS LAB_1D2E ; loop if character = "A"-"Z" (ignore)
; check if string variable
LAB_1D38
CMP #'$' ; compare with "$"
BNE LAB_1D47 ; branch if not string
; to introduce a new variable type (% suffix for integers say) then this branch
; will need to go to that check and then that branch, if it fails, go to LAB_1D47
; type is string
LDA #$FF ; set data type = string
STA Dtypef ; set data type flag, $FF=string, $00=numeric
TXA ; get 2nd character back
ORA #$80 ; set top bit (indicate string var)
TAX ; copy back to 2nd character temp
JSR LAB_IGBY ; increment and scan memory
; after we have determined the variable type we need to come back here to determine
; if it's an array of type. this would plug in a%(b[,c[,d]])) integer arrays nicely
LAB_1D47 ; gets here with character after var name in A
STX Varnm2 ; save 2nd character
ORA Sufnxf ; or with subscript/FNX flag (or FN name)
CMP #'(' ; compare with "("
BNE LAB_1D53 ; branch if not "("
JMP LAB_1E17 ; go find, or make, array
; either find or create var
; var name (1st two characters only!) is in Varnm1,Varnm2
; variable name wasn't var(... so look for plain var
LAB_1D53
LDA #$00 ; clear A
STA Sufnxf ; clear subscript/FNX flag
LDA Svarl ; get start of vars low byte
LDX Svarh ; get start of vars high byte
LDY #$00 ; clear index
LAB_1D5D
STX Vrschh ; save search address high byte
LAB_1D5F
STA Vrschl ; save search address low byte
CPX Sarryh ; compare high address with var space end
BNE LAB_1D69 ; skip next compare if <>
; high addresses were = so compare low addresses
CMP Sarryl ; compare low address with var space end
BEQ LAB_1D8B ; if not found go make new var
LAB_1D69
LDA Varnm1 ; get 1st character of var to find
CMP (Vrschl),Y ; compare with variable name 1st character
BNE LAB_1D77 ; branch if no match
; 1st characters match so compare 2nd characters
LDA Varnm2 ; get 2nd character of var to find
INY ; index to point to variable name 2nd character
CMP (Vrschl),Y ; compare with variable name 2nd character
BEQ LAB_1DD7 ; branch if match (found var)
DEY ; else decrement index (now = $00)
LAB_1D77
CLC ; clear carry for add
LDA Vrschl ; get search address low byte
ADC #$06 ; +6 (offset to next var name)
BCC LAB_1D5F ; loop if no overflow to high byte
INX ; else increment high byte
BNE LAB_1D5D ; loop always (RAM doesn't extend to $FFFF !)
; check byte, return C=0 if<"A" or >"Z" or "a" to "z"
LAB_CASC
CMP #'a' ; compare with "a"
BCS LAB_1D83 ; go check <"z"+1
; check byte, return C=0 if<"A" or >"Z"
LAB_1D82
CMP #'A' ; compare with "A"
BCC LAB_1D8A ; exit if less
; carry is set
SBC #$5B ; subtract "Z"+1
SEC ; set carry
SBC #$A5 ; subtract $A5 (restore byte)
; carry clear if byte>$5A
LAB_1D8A
RTS
LAB_1D83
SBC #$7B ; subtract "z"+1
SEC ; set carry
SBC #$85 ; subtract $85 (restore byte)
; carry clear if byte>$7A
RTS
; reached end of variable mem without match
; .. so create new variable
LAB_1D8B
PLA ; pop return address low byte
PHA ; push return address low byte
LAB_1C18p2 = LAB_1C18+2
CMP #<LAB_1C18p2 ; compare with expected calling routine return low byte
BNE LAB_1D98 ; if not get (var) go create new var
; This will only drop through if the call was from LAB_1C18 and is only called
; from there if it is searching for a variable from the RHS of a LET a=b statement
; it prevents the creation of variables not assigned a value.
; value returned by this is either numeric zero (exponent byte is $00) or null string
; (descriptor length byte is $00). in fact a pointer to any $00 byte would have done.
; doing this saves 6 bytes of variable memory and 168 machine cycles of time
; this is where you would put the undefined variable error call e.g.
; ; variable doesn't exist so flag error
; LDX #$24 ; error code $24 ("undefined variable" error)
; JMP LAB_XERR ; do error #X then warm start
; the above code has been tested and works a treat! (it replaces the three code lines
; below)
; else return dummy null value
LDA #<LAB_1D96 ; low byte point to $00,$00
; (uses part of misc constants table)
LDY #>LAB_1D96 ; high byte point to $00,$00
RTS
; create new numeric variable
LAB_1D98
LDA Sarryl ; get var mem end low byte
LDY Sarryh ; get var mem end high byte
STA Ostrtl ; save old block start low byte
STY Ostrth ; save old block start high byte
LDA Earryl ; get array mem end low byte
LDY Earryh ; get array mem end high byte
STA Obendl ; save old block end low byte
STY Obendh ; save old block end high byte
CLC ; clear carry for add
ADC #$06 ; +6 (space for one var)
BCC LAB_1DAE ; branch if no overflow to high byte
INY ; else increment high byte
LAB_1DAE
STA Nbendl ; set new block end low byte
STY Nbendh ; set new block end high byte
JSR LAB_11CF ; open up space in memory
LDA Nbendl ; get new start low byte
LDY Nbendh ; get new start high byte (-$100)
INY ; correct high byte
STA Sarryl ; save new var mem end low byte
STY Sarryh ; save new var mem end high byte
LDY #$00 ; clear index
LDA Varnm1 ; get var name 1st character
STA (Vrschl),Y ; save var name 1st character
INY ; increment index
LDA Varnm2 ; get var name 2nd character
STA (Vrschl),Y ; save var name 2nd character
LDA #$00 ; clear A
INY ; increment index
STA (Vrschl),Y ; initialise var byte
INY ; increment index
STA (Vrschl),Y ; initialise var byte
INY ; increment index
STA (Vrschl),Y ; initialise var byte
INY ; increment index
STA (Vrschl),Y ; initialise var byte
; found a match for var ((Vrschl) = ptr)
LAB_1DD7
LDA Vrschl ; get var address low byte
CLC ; clear carry for add
ADC #$02 ; +2 (offset past var name bytes)
LDY Vrschh ; get var address high byte
BCC LAB_1DE1 ; branch if no overflow from add
INY ; else increment high byte
LAB_1DE1
STA Cvaral ; save current var address low byte
STY Cvarah ; save current var address high byte
RTS
; set-up array pointer (Adatal/h) to first element in array
; set Adatal,Adatah to Astrtl,Astrth+2*Dimcnt+#$05
LAB_1DE6
LDA Dimcnt ; get # of dimensions (1, 2 or 3)
ASL ; *2 (also clears the carry !)
ADC #$05 ; +5 (result is 7, 9 or 11 here)
ADC Astrtl ; add array start pointer low byte
LDY Astrth ; get array pointer high byte
BCC LAB_1DF2 ; branch if no overflow
INY ; else increment high byte
LAB_1DF2
STA Adatal ; save array data pointer low byte
STY Adatah ; save array data pointer high byte
RTS
; evaluate integer expression
LAB_EVIN
JSR LAB_IGBY ; increment and scan memory
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
; evaluate integer expression (no check)
LAB_EVPI
LDA FAC1_s ; get FAC1 sign (b7)
BMI LAB_1E12 ; do function call error if -ve
; evaluate integer expression (no sign check)
LAB_EVIR
LDA FAC1_e ; get FAC1 exponent
CMP #$90 ; compare with exponent = 2^16 (n>2^15)
BCC LAB_1E14 ; branch if n<2^16 (is ok)
LDA #<LAB_1DF7 ; set pointer low byte to -32768
LDY #>LAB_1DF7 ; set pointer high byte to -32768
JSR LAB_27F8 ; compare FAC1 with (AY)
LAB_1E12
BNE LAB_FCER ; if <> do function call error then warm start
LAB_1E14
JMP LAB_2831 ; convert FAC1 floating-to-fixed and return
; find or make array
LAB_1E17
LDA Defdim ; get DIM flag
PHA ; push it
LDA Dtypef ; get data type flag, $FF=string, $00=numeric
PHA ; push it
LDY #$00 ; clear dimensions count
; now get the array dimension(s) and stack it (them) before the data type and DIM flag
LAB_1E1F
TYA ; copy dimensions count
PHA ; save it
LDA Varnm2 ; get array name 2nd byte
PHA ; save it
LDA Varnm1 ; get array name 1st byte
PHA ; save it
JSR LAB_EVIN ; evaluate integer expression
PLA ; pull array name 1st byte
STA Varnm1 ; restore array name 1st byte
PLA ; pull array name 2nd byte
STA Varnm2 ; restore array name 2nd byte
PLA ; pull dimensions count
TAY ; restore it
TSX ; copy stack pointer
LDA LAB_STAK+2,X ; get DIM flag
PHA ; push it
LDA LAB_STAK+1,X ; get data type flag
PHA ; push it
LDA FAC1_2 ; get this dimension size high byte
STA LAB_STAK+2,X ; stack before flag bytes
LDA FAC1_3 ; get this dimension size low byte
STA LAB_STAK+1,X ; stack before flag bytes
INY ; increment dimensions count
JSR LAB_GBYT ; scan memory
CMP #',' ; compare with ","
BEQ LAB_1E1F ; if found go do next dimension
STY Dimcnt ; store dimensions count
JSR LAB_1BFB ; scan for ")" , else do syntax error then warm start
PLA ; pull data type flag
STA Dtypef ; restore data type flag, $FF=string, $00=numeric
PLA ; pull DIM flag
STA Defdim ; restore DIM flag
LDX Sarryl ; get array mem start low byte
LDA Sarryh ; get array mem start high byte
; now check to see if we are at the end of array memory (we would be if there were
; no arrays).
LAB_1E5C
STX Astrtl ; save as array start pointer low byte
STA Astrth ; save as array start pointer high byte
CMP Earryh ; compare with array mem end high byte
BNE LAB_1E68 ; branch if not reached array mem end
CPX Earryl ; else compare with array mem end low byte
BEQ LAB_1EA1 ; go build array if not found
; search for array
LAB_1E68
LDY #$00 ; clear index
LDA (Astrtl),Y ; get array name first byte
INY ; increment index to second name byte
CMP Varnm1 ; compare with this array name first byte
BNE LAB_1E77 ; branch if no match
LDA Varnm2 ; else get this array name second byte
CMP (Astrtl),Y ; compare with array name second byte
BEQ LAB_1E8D ; array found so branch
; no match
LAB_1E77
INY ; increment index
LDA (Astrtl),Y ; get array size low byte
CLC ; clear carry for add
ADC Astrtl ; add array start pointer low byte
TAX ; copy low byte to X
INY ; increment index
LDA (Astrtl),Y ; get array size high byte
ADC Astrth ; add array mem pointer high byte
BCC LAB_1E5C ; if no overflow go check next array
; do array bounds error
LAB_1E85
LDX #$10 ; error code $10 ("Array bounds" error)
.byte $2C ; makes next bit BIT LAB_08A2
; do function call error
LAB_FCER
LDX #$08 ; error code $08 ("Function call" error)
LAB_1E8A
JMP LAB_XERR ; do error #X, then warm start
; found array, are we trying to dimension it?
LAB_1E8D
LDX #$12 ; set error $12 ("Double dimension" error)
LDA Defdim ; get DIM flag
BNE LAB_1E8A ; if we are trying to dimension it do error #X, then warm
; start
; found the array and we're not dimensioning it so we must find an element in it
JSR LAB_1DE6 ; set-up array pointer (Adatal/h) to first element in array
; (Astrtl,Astrth points to start of array)
LDA Dimcnt ; get dimensions count
LDY #$04 ; set index to array's # of dimensions
CMP (Astrtl),Y ; compare with no of dimensions
BNE LAB_1E85 ; if wrong do array bounds error, could do "Wrong
; dimensions" error here .. if we want a different
; error message
JMP LAB_1F28 ; found array so go get element
; (could jump to LAB_1F28 as all LAB_1F24 does is take
; Dimcnt and save it at (Astrtl),Y which is already the
; same or we would have taken the BNE)
; array not found, so build it
LAB_1EA1
JSR LAB_1DE6 ; set-up array pointer (Adatal/h) to first element in array
; (Astrtl,Astrth points to start of array)
JSR LAB_121F ; check available memory, "Out of memory" error if no room
; addr to check is in AY (low/high)
LDY #$00 ; clear Y (don't need to clear A)
STY Aspth ; clear array data size high byte
LDA Varnm1 ; get variable name 1st byte
STA (Astrtl),Y ; save array name 1st byte
INY ; increment index
LDA Varnm2 ; get variable name 2nd byte
STA (Astrtl),Y ; save array name 2nd byte
LDA Dimcnt ; get dimensions count
LDY #$04 ; index to dimension count
STY Asptl ; set array data size low byte (four bytes per element)
STA (Astrtl),Y ; set array's dimensions count
; now calculate the size of the data space for the array
CLC ; clear carry for add (clear on subsequent loops)
LAB_1EC0
LDX #$0B ; set default dimension value low byte
LDA #$00 ; set default dimension value high byte
BIT Defdim ; test default DIM flag
BVC LAB_1ED0 ; branch if b6 of Defdim is clear
PLA ; else pull dimension value low byte
ADC #$01 ; +1 (allow for zeroeth element)
TAX ; copy low byte to X
PLA ; pull dimension value high byte
ADC #$00 ; add carry from low byte
LAB_1ED0
INY ; index to dimension value high byte
STA (Astrtl),Y ; save dimension value high byte
INY ; index to dimension value high byte
TXA ; get dimension value low byte
STA (Astrtl),Y ; save dimension value low byte
JSR LAB_1F7C ; does XY = (Astrtl),Y * (Asptl)
STX Asptl ; save array data size low byte
STA Aspth ; save array data size high byte
LDY ut1_pl ; restore index (saved by subroutine)
DEC Dimcnt ; decrement dimensions count
BNE LAB_1EC0 ; loop while not = 0
ADC Adatah ; add size high byte to first element high byte
; (carry is always clear here)
BCS LAB_1F45 ; if overflow go do "Out of memory" error
STA Adatah ; save end of array high byte
TAY ; copy end high byte to Y
TXA ; get array size low byte
ADC Adatal ; add array start low byte
BCC LAB_1EF3 ; branch if no carry
INY ; else increment end of array high byte
BEQ LAB_1F45 ; if overflow go do "Out of memory" error
; set-up mostly complete, now zero the array
LAB_1EF3
JSR LAB_121F ; check available memory, "Out of memory" error if no room
; addr to check is in AY (low/high)
STA Earryl ; save array mem end low byte
STY Earryh ; save array mem end high byte
LDA #$00 ; clear byte for array clear
INC Aspth ; increment array size high byte (now block count)
LDY Asptl ; get array size low byte (now index to block)
BEQ LAB_1F07 ; branch if low byte = $00
LAB_1F02
DEY ; decrement index (do 0 to n-1)
STA (Adatal),Y ; zero byte
BNE LAB_1F02 ; loop until this block done
LAB_1F07
DEC Adatah ; decrement array pointer high byte
DEC Aspth ; decrement block count high byte
BNE LAB_1F02 ; loop until all blocks done
INC Adatah ; correct for last loop
SEC ; set carry for subtract
LDY #$02 ; index to array size low byte
LDA Earryl ; get array mem end low byte
SBC Astrtl ; subtract array start low byte
STA (Astrtl),Y ; save array size low byte
INY ; index to array size high byte
LDA Earryh ; get array mem end high byte
SBC Astrth ; subtract array start high byte
STA (Astrtl),Y ; save array size high byte
LDA Defdim ; get default DIM flag
BNE LAB_1F7B ; exit (RET) if this was a DIM command
; else, find element
INY ; index to # of dimensions
LAB_1F24
LDA (Astrtl),Y ; get array's dimension count
STA Dimcnt ; save it
; we have found, or built, the array. now we need to find the element
LAB_1F28
LDA #$00 ; clear byte
STA Asptl ; clear array data pointer low byte
LAB_1F2C
STA Aspth ; save array data pointer high byte
INY ; increment index (point to array bound high byte)
PLA ; pull array index low byte
TAX ; copy to X
STA FAC1_2 ; save index low byte to FAC1 mantissa2
PLA ; pull array index high byte
STA FAC1_3 ; save index high byte to FAC1 mantissa3
CMP (Astrtl),Y ; compare with array bound high byte
BCC LAB_1F48 ; branch if within bounds
BNE LAB_1F42 ; if outside bounds do array bounds error
; else high byte was = so test low bytes
INY ; index to array bound low byte
TXA ; get array index low byte
CMP (Astrtl),Y ; compare with array bound low byte
BCC LAB_1F49 ; branch if within bounds
LAB_1F42
JMP LAB_1E85 ; else do array bounds error
LAB_1F45
JMP LAB_OMER ; do "Out of memory" error then warm start
LAB_1F48
INY ; index to array bound low byte
LAB_1F49
LDA Aspth ; get array data pointer high byte
ORA Asptl ; OR with array data pointer low byte
BEQ LAB_1F5A ; branch if array data pointer = null (skip multiply)
JSR LAB_1F7C ; does XY = (Astrtl),Y * (Asptl)
TXA ; get result low byte
ADC FAC1_2 ; add index low byte from FAC1 mantissa2
TAX ; save result low byte
TYA ; get result high byte
LDY ut1_pl ; restore index
LAB_1F5A
ADC FAC1_3 ; add index high byte from FAC1 mantissa3
STX Asptl ; save array data pointer low byte
DEC Dimcnt ; decrement dimensions count
BNE LAB_1F2C ; loop if dimensions still to do
ASL Asptl ; array data pointer low byte * 2
ROL ; array data pointer high byte * 2
ASL Asptl ; array data pointer low byte * 4
ROL ; array data pointer high byte * 4
TAY ; copy high byte
LDA Asptl ; get low byte
ADC Adatal ; add array data start pointer low byte
STA Cvaral ; save as current var address low byte
TYA ; get high byte back
ADC Adatah ; add array data start pointer high byte
STA Cvarah ; save as current var address high byte
TAY ; copy high byte to Y
LDA Cvaral ; get current var address low byte
LAB_1F7B
RTS
; does XY = (Astrtl),Y * (Asptl)
LAB_1F7C
STY ut1_pl ; save index
LDA (Astrtl),Y ; get dimension size low byte
STA dims_l ; save dimension size low byte
DEY ; decrement index
LDA (Astrtl),Y ; get dimension size high byte
STA dims_h ; save dimension size high byte
LDA #$10 ; count = $10 (16 bit multiply)
STA numbit ; save bit count
LDX #$00 ; clear result low byte
LDY #$00 ; clear result high byte
LAB_1F8F
TXA ; get result low byte
ASL ; *2
TAX ; save result low byte
TYA ; get result high byte
ROL ; *2
TAY ; save result high byte
BCS LAB_1F45 ; if overflow go do "Out of memory" error
ASL Asptl ; shift multiplier low byte
ROL Aspth ; shift multiplier high byte
BCC LAB_1FA8 ; skip add if no carry
CLC ; else clear carry for add
TXA ; get result low byte
ADC dims_l ; add dimension size low byte
TAX ; save result low byte
TYA ; get result high byte
ADC dims_h ; add dimension size high byte
TAY ; save result high byte
BCS LAB_1F45 ; if overflow go do "Out of memory" error
LAB_1FA8
DEC numbit ; decrement bit count
BNE LAB_1F8F ; loop until all done
RTS
; perform FRE()
LAB_FRE
LDA Dtypef ; get data type flag, $FF=string, $00=numeric
BPL LAB_1FB4 ; branch if numeric
JSR LAB_22B6 ; pop string off descriptor stack, or from top of string
; space returns with A = length, X=$71=pointer low byte,
; Y=$72=pointer high byte
; FRE(n) was numeric so do this
LAB_1FB4
JSR LAB_GARB ; go do garbage collection
SEC ; set carry for subtract
LDA Sstorl ; get bottom of string space low byte
SBC Earryl ; subtract array mem end low byte
TAY ; copy result to Y
LDA Sstorh ; get bottom of string space high byte
SBC Earryh ; subtract array mem end high byte
; save and convert integer AY to FAC1
LAB_AYFC
LSR Dtypef ; clear data type flag, $FF=string, $00=numeric
STA FAC1_1 ; save FAC1 mantissa1
STY FAC1_2 ; save FAC1 mantissa2
LDX #$90 ; set exponent=2^16 (integer)
JMP LAB_27E3 ; set exp=X, clear FAC1_3, normalise and return
; perform POS()
LAB_POS
LDY TPos ; get terminal position
; convert Y to byte in FAC1
LAB_1FD0
LDA #$00 ; clear high byte
BEQ LAB_AYFC ; always save and convert integer AY to FAC1 and return
; check not Direct (used by DEF and INPUT)
LAB_CKRN
LDX Clineh ; get current line high byte
INX ; increment it
BNE LAB_1F7B ; return if can continue not direct mode
; else do illegal direct error
LAB_1FD9
LDX #$16 ; error code $16 ("Illegal direct" error)
LAB_1FDB
JMP LAB_XERR ; go do error #X, then warm start
; perform DEF
LAB_DEF
JSR LAB_200B ; check FNx syntax
STA func_l ; save function pointer low byte
STY func_h ; save function pointer high byte
JSR LAB_CKRN ; check not Direct (back here if ok)
JSR LAB_1BFE ; scan for "(" , else do syntax error then warm start
LDA #$80 ; set flag for FNx
STA Sufnxf ; save subscript/FNx flag
JSR LAB_GVAR ; get (var) address
JSR LAB_CTNM ; check if source is numeric, else do type mismatch
JSR LAB_1BFB ; scan for ")" , else do syntax error then warm start
LDA #TK_EQUAL ; get = token
JSR LAB_SCCA ; scan for CHR$(A), else do syntax error then warm start
LDA Cvarah ; get current var address high byte
PHA ; push it
LDA Cvaral ; get current var address low byte
PHA ; push it
LDA Bpntrh ; get BASIC execute pointer high byte
PHA ; push it
LDA Bpntrl ; get BASIC execute pointer low byte
PHA ; push it
JSR LAB_DATA ; go perform DATA
JMP LAB_207A ; put execute pointer and variable pointer into function
; and return
; check FNx syntax
LAB_200B
LDA #TK_FN ; get FN" token
JSR LAB_SCCA ; scan for CHR$(A) , else do syntax error then warm start
; return character after A
ORA #$80 ; set FN flag bit
STA Sufnxf ; save FN flag so array variable test fails
JSR LAB_1D12 ; search for FN variable
JMP LAB_CTNM ; check if source is numeric and return, else do type
; mismatch
; Evaluate FNx
LAB_201E
JSR LAB_200B ; check FNx syntax
PHA ; push function pointer low byte
TYA ; copy function pointer high byte
PHA ; push function pointer high byte
JSR LAB_1BFE ; scan for "(", else do syntax error then warm start
JSR LAB_EVEX ; evaluate expression
JSR LAB_1BFB ; scan for ")", else do syntax error then warm start
JSR LAB_CTNM ; check if source is numeric, else do type mismatch
PLA ; pop function pointer high byte
STA func_h ; restore it
PLA ; pop function pointer low byte
STA func_l ; restore it
LDX #$20 ; error code $20 ("Undefined function" error)
LDY #$03 ; index to variable pointer high byte
LDA (func_l),Y ; get variable pointer high byte
BEQ LAB_1FDB ; if zero go do undefined function error
STA Cvarah ; save variable address high byte
DEY ; index to variable address low byte
LDA (func_l),Y ; get variable address low byte
STA Cvaral ; save variable address low byte
TAX ; copy address low byte
; now stack the function variable value before use
INY ; index to mantissa_3
LAB_2043
LDA (Cvaral),Y ; get byte from variable
PHA ; stack it
DEY ; decrement index
BPL LAB_2043 ; loop until variable stacked
LDY Cvarah ; get variable address high byte
JSR LAB_2778 ; pack FAC1 (function expression value) into (XY)
; (function variable), return Y=0, always
LDA Bpntrh ; get BASIC execute pointer high byte
PHA ; push it
LDA Bpntrl ; get BASIC execute pointer low byte
PHA ; push it
LDA (func_l),Y ; get function execute pointer low byte
STA Bpntrl ; save as BASIC execute pointer low byte
INY ; index to high byte
LDA (func_l),Y ; get function execute pointer high byte
STA Bpntrh ; save as BASIC execute pointer high byte
LDA Cvarah ; get variable address high byte
PHA ; push it
LDA Cvaral ; get variable address low byte
PHA ; push it
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
PLA ; pull variable address low byte
STA func_l ; save variable address low byte
PLA ; pull variable address high byte
STA func_h ; save variable address high byte
JSR LAB_GBYT ; scan memory
BEQ LAB_2074 ; branch if null (should be [EOL] marker)
JMP LAB_SNER ; else syntax error then warm start
; restore Bpntrl,Bpntrh and function variable from stack
LAB_2074
PLA ; pull BASIC execute pointer low byte
STA Bpntrl ; restore BASIC execute pointer low byte
PLA ; pull BASIC execute pointer high byte
STA Bpntrh ; restore BASIC execute pointer high byte
; put execute pointer and variable pointer into function
LAB_207A
LDY #$00 ; clear index
PLA ; pull BASIC execute pointer low byte
STA (func_l),Y ; save to function
INY ; increment index
PLA ; pull BASIC execute pointer high byte
STA (func_l),Y ; save to function
INY ; increment index
PLA ; pull current var address low byte
STA (func_l),Y ; save to function
INY ; increment index
PLA ; pull current var address high byte
STA (func_l),Y ; save to function
RTS
; perform STR$()
LAB_STRS
JSR LAB_CTNM ; check if source is numeric, else do type mismatch
JSR LAB_296E ; convert FAC1 to string
LDA #<Decssp1 ; set result string low pointer
LDY #>Decssp1 ; set result string high pointer
BEQ LAB_20AE ; print null terminated string to Sutill/Sutilh
; Do string vector
; copy des_pl/h to des_2l/h and make string space A bytes long
LAB_209C
LDX des_pl ; get descriptor pointer low byte
LDY des_ph ; get descriptor pointer high byte
STX des_2l ; save descriptor pointer low byte
STY des_2h ; save descriptor pointer high byte
; make string space A bytes long
; A=length, X=Sutill=ptr low byte, Y=Sutilh=ptr high byte
LAB_MSSP
JSR LAB_2115 ; make space in string memory for string A long
; return X=Sutill=ptr low byte, Y=Sutilh=ptr high byte
STX str_pl ; save string pointer low byte
STY str_ph ; save string pointer high byte
STA str_ln ; save length
RTS
; Scan, set up string
; print " terminated string to Sutill/Sutilh
LAB_20AE
LDX #$22 ; set terminator to "
STX Srchc ; set search character (terminator 1)
STX Asrch ; set terminator 2
; print [Srchc] or [Asrch] terminated string to Sutill/Sutilh
; source is AY
LAB_20B4
STA ssptr_l ; store string start low byte
STY ssptr_h ; store string start high byte
STA str_pl ; save string pointer low byte
STY str_ph ; save string pointer high byte
LDY #$FF ; set length to -1
LAB_20BE
INY ; increment length
LDA (ssptr_l),Y ; get byte from string
BEQ LAB_20CF ; exit loop if null byte [EOS]
CMP Srchc ; compare with search character (terminator 1)
BEQ LAB_20CB ; branch if terminator
CMP Asrch ; compare with terminator 2
BNE LAB_20BE ; loop if not terminator 2
LAB_20CB
CMP #$22 ; compare with "
BEQ LAB_20D0 ; branch if " (carry set if = !)
LAB_20CF
CLC ; clear carry for add (only if [EOL] terminated string)
LAB_20D0
STY str_ln ; save length in FAC1 exponent
TYA ; copy length to A
ADC ssptr_l ; add string start low byte
STA Sendl ; save string end low byte
LDX ssptr_h ; get string start high byte
BCC LAB_20DC ; branch if no low byte overflow
INX ; else increment high byte
LAB_20DC
STX Sendh ; save string end high byte
LDA ssptr_h ; get string start high byte
CMP #>Ram_base ; compare with start of program memory
BCS LAB_RTST ; branch if not in utility area
; string in utility area, move to string memory
TYA ; copy length to A
JSR LAB_209C ; copy des_pl/h to des_2l/h and make string space A bytes
; long
LDX ssptr_l ; get string start low byte
LDY ssptr_h ; get string start high byte
JSR LAB_2298 ; store string A bytes long from XY to (Sutill)
; check for space on descriptor stack then ..
; put string address and length on descriptor stack and update stack pointers
LAB_RTST
LDX next_s ; get string stack pointer
CPX #des_sk+$09 ; compare with max+1
BNE LAB_20F8 ; branch if space on string stack
; else do string too complex error
LDX #$1C ; error code $1C ("String too complex" error)
LAB_20F5
JMP LAB_XERR ; do error #X, then warm start
; put string address and length on descriptor stack and update stack pointers
LAB_20F8
LDA str_ln ; get string length
STA PLUS_0,X ; put on string stack
LDA str_pl ; get string pointer low byte
STA PLUS_1,X ; put on string stack
LDA str_ph ; get string pointer high byte
STA PLUS_2,X ; put on string stack
LDY #$00 ; clear Y
STX des_pl ; save string descriptor pointer low byte
STY des_ph ; save string descriptor pointer high byte (always $00)
DEY ; Y = $FF
STY Dtypef ; save data type flag, $FF=string
STX last_sl ; save old stack pointer (current top item)
INX ; update stack pointer
INX ; update stack pointer
INX ; update stack pointer
STX next_s ; save new top item value
RTS
; Build descriptor
; make space in string memory for string A long
; return X=Sutill=ptr low byte, Y=Sutill=ptr high byte
LAB_2115
LSR Gclctd ; clear garbage collected flag (b7)
; make space for string A long
LAB_2117
PHA ; save string length
EOR #$FF ; complement it
SEC ; set carry for subtract (twos comp add)
ADC Sstorl ; add bottom of string space low byte (subtract length)
LDY Sstorh ; get bottom of string space high byte
BCS LAB_2122 ; skip decrement if no underflow
DEY ; decrement bottom of string space high byte
LAB_2122
CPY Earryh ; compare with array mem end high byte
BCC LAB_2137 ; do out of memory error if less
BNE LAB_212C ; if not = skip next test
CMP Earryl ; compare with array mem end low byte
BCC LAB_2137 ; do out of memory error if less
LAB_212C
STA Sstorl ; save bottom of string space low byte
STY Sstorh ; save bottom of string space high byte
STA Sutill ; save string utility ptr low byte
STY Sutilh ; save string utility ptr high byte
TAX ; copy low byte to X
PLA ; get string length back
RTS
LAB_2137
LDX #$0C ; error code $0C ("Out of memory" error)
LDA Gclctd ; get garbage collected flag
BMI LAB_20F5 ; if set then do error code X
JSR LAB_GARB ; else go do garbage collection
LDA #$80 ; flag for garbage collected
STA Gclctd ; set garbage collected flag
PLA ; pull length
BNE LAB_2117 ; go try again (loop always, length should never be = $00)
; garbage collection routine
LAB_GARB
LDX Ememl ; get end of mem low byte
LDA Ememh ; get end of mem high byte
; re-run routine from last ending
LAB_214B
STX Sstorl ; set string storage low byte
STA Sstorh ; set string storage high byte
LDY #$00 ; clear index
STY garb_h ; clear working pointer high byte (flag no strings to move)
LDA Earryl ; get array mem end low byte
LDX Earryh ; get array mem end high byte
STA Histrl ; save as highest string low byte
STX Histrh ; save as highest string high byte
LDA #des_sk ; set descriptor stack pointer
STA ut1_pl ; save descriptor stack pointer low byte
STY ut1_ph ; save descriptor stack pointer high byte ($00)
LAB_2161
CMP next_s ; compare with descriptor stack pointer
BEQ LAB_216A ; branch if =
JSR LAB_21D7 ; go garbage collect descriptor stack
BEQ LAB_2161 ; loop always
; done stacked strings, now do string vars
LAB_216A
ASL g_step ; set step size = $06
LDA Svarl ; get start of vars low byte
LDX Svarh ; get start of vars high byte
STA ut1_pl ; save as pointer low byte
STX ut1_ph ; save as pointer high byte
LAB_2176
CPX Sarryh ; compare start of arrays high byte
BNE LAB_217E ; branch if no high byte match
CMP Sarryl ; else compare start of arrays low byte
BEQ LAB_2183 ; branch if = var mem end
LAB_217E
JSR LAB_21D1 ; go garbage collect strings
BEQ LAB_2176 ; loop always
; done string vars, now do string arrays
LAB_2183
STA Nbendl ; save start of arrays low byte as working pointer
STX Nbendh ; save start of arrays high byte as working pointer
LDA #$04 ; set step size
STA g_step ; save step size
LAB_218B
LDA Nbendl ; get pointer low byte
LDX Nbendh ; get pointer high byte
LAB_218F
CPX Earryh ; compare with array mem end high byte
BNE LAB_219A ; branch if not at end
CMP Earryl ; else compare with array mem end low byte
BEQ LAB_2216 ; tidy up and exit if at end
LAB_219A
STA ut1_pl ; save pointer low byte
STX ut1_ph ; save pointer high byte
LDY #$02 ; set index
LDA (ut1_pl),Y ; get array size low byte
ADC Nbendl ; add start of this array low byte
STA Nbendl ; save start of next array low byte
INY ; increment index
LDA (ut1_pl),Y ; get array size high byte
ADC Nbendh ; add start of this array high byte
STA Nbendh ; save start of next array high byte
LDY #$01 ; set index
LDA (ut1_pl),Y ; get name second byte
BPL LAB_218B ; skip if not string array
; was string array so ..
LDY #$04 ; set index
LDA (ut1_pl),Y ; get # of dimensions
ASL ; *2
ADC #$05 ; +5 (array header size)
JSR LAB_2208 ; go set up for first element
LAB_21C4
CPX Nbendh ; compare with start of next array high byte
BNE LAB_21CC ; branch if <> (go do this array)
CMP Nbendl ; else compare element pointer low byte with next array
; low byte
BEQ LAB_218F ; if equal then go do next array
LAB_21CC
JSR LAB_21D7 ; go defrag array strings
BEQ LAB_21C4 ; go do next array string (loop always)
; defrag string variables
; enter with XA = variable pointer
; return with XA = next variable pointer
LAB_21D1
INY ; increment index (Y was $00)
LDA (ut1_pl),Y ; get var name byte 2
BPL LAB_2206 ; if not string, step pointer to next var and return
INY ; else increment index
LAB_21D7
LDA (ut1_pl),Y ; get string length
BEQ LAB_2206 ; if null, step pointer to next string and return
INY ; else increment index
LDA (ut1_pl),Y ; get string pointer low byte
TAX ; copy to X
INY ; increment index
LDA (ut1_pl),Y ; get string pointer high byte
CMP Sstorh ; compare bottom of string space high byte
BCC LAB_21EC ; branch if less
BNE LAB_2206 ; if greater, step pointer to next string and return
; high bytes were = so compare low bytes
CPX Sstorl ; compare bottom of string space low byte
BCS LAB_2206 ; if >=, step pointer to next string and return
; string pointer is < string storage pointer (pos in mem)
LAB_21EC
CMP Histrh ; compare to highest string high byte
BCC LAB_2207 ; if <, step pointer to next string and return
BNE LAB_21F6 ; if > update pointers, step to next and return
; high bytes were = so compare low bytes
CPX Histrl ; compare to highest string low byte
BCC LAB_2207 ; if <, step pointer to next string and return
; string is in string memory space
LAB_21F6
STX Histrl ; save as new highest string low byte
STA Histrh ; save as new highest string high byte
LDA ut1_pl ; get start of vars(descriptors) low byte
LDX ut1_ph ; get start of vars(descriptors) high byte
STA garb_l ; save as working pointer low byte
STX garb_h ; save as working pointer high byte
DEY ; decrement index DIFFERS
DEY ; decrement index (should point to descriptor start)
STY g_indx ; save index pointer
; step pointer to next string
LAB_2206
CLC ; clear carry for add
LAB_2207
LDA g_step ; get step size
LAB_2208
ADC ut1_pl ; add pointer low byte
STA ut1_pl ; save pointer low byte
BCC LAB_2211 ; branch if no overflow
INC ut1_ph ; else increment high byte
LAB_2211
LDX ut1_ph ; get pointer high byte
LDY #$00 ; clear Y
RTS
; search complete, now either exit or set-up and move string
LAB_2216
DEC g_step ; decrement step size (now $03 for descriptor stack)
LDX garb_h ; get string to move high byte
BEQ LAB_2211 ; exit if nothing to move
LDY g_indx ; get index byte back (points to descriptor)
CLC ; clear carry for add
LDA (garb_l),Y ; get string length
ADC Histrl ; add highest string low byte
STA Obendl ; save old block end low pointer
LDA Histrh ; get highest string high byte
ADC #$00 ; add any carry
STA Obendh ; save old block end high byte
LDA Sstorl ; get bottom of string space low byte
LDX Sstorh ; get bottom of string space high byte
STA Nbendl ; save new block end low byte
STX Nbendh ; save new block end high byte
JSR LAB_11D6 ; open up space in memory, don't set array end
LDY g_indx ; get index byte
INY ; point to descriptor low byte
LDA Nbendl ; get string pointer low byte
STA (garb_l),Y ; save new string pointer low byte
TAX ; copy string pointer low byte
INC Nbendh ; correct high byte (move sets high byte -1)
LDA Nbendh ; get new string pointer high byte
INY ; point to descriptor high byte
STA (garb_l),Y ; save new string pointer high byte
JMP LAB_214B ; re-run routine from last ending
; (but don't collect this string)
; concatenate
; add strings, string 1 is in descriptor des_pl, string 2 is in line
LAB_224D
LDA des_ph ; get descriptor pointer high byte
PHA ; put on stack
LDA des_pl ; get descriptor pointer low byte
PHA ; put on stack
JSR LAB_GVAL ; get value from line
JSR LAB_CTST ; check if source is string, else do type mismatch
PLA ; get descriptor pointer low byte back
STA ssptr_l ; set pointer low byte
PLA ; get descriptor pointer high byte back
STA ssptr_h ; set pointer high byte
LDY #$00 ; clear index
LDA (ssptr_l),Y ; get length_1 from descriptor
CLC ; clear carry for add
ADC (des_pl),Y ; add length_2
BCC LAB_226D ; branch if no overflow
LDX #$1A ; else set error code $1A ("String too long" error)
JMP LAB_XERR ; do error #X, then warm start
LAB_226D
JSR LAB_209C ; copy des_pl/h to des_2l/h and make string space A bytes
; long
JSR LAB_228A ; copy string from descriptor (sdescr) to (Sutill)
LDA des_2l ; get descriptor pointer low byte
LDY des_2h ; get descriptor pointer high byte
JSR LAB_22BA ; pop (YA) descriptor off stack or from top of string space
; returns with A = length, ut1_pl = pointer low byte,
; ut1_ph = pointer high byte
JSR LAB_229C ; store string A bytes long from (ut1_pl) to (Sutill)
LDA ssptr_l ;.set descriptor pointer low byte
LDY ssptr_h ;.set descriptor pointer high byte
JSR LAB_22BA ; pop (YA) descriptor off stack or from top of string space
; returns with A = length, X=ut1_pl=pointer low byte,
; Y=ut1_ph=pointer high byte
JSR LAB_RTST ; check for space on descriptor stack then put string
; address and length on descriptor stack and update stack
; pointers
JMP LAB_1ADB ;.continue evaluation
; copy string from descriptor (sdescr) to (Sutill)
LAB_228A
LDY #$00 ; clear index
LDA (sdescr),Y ; get string length
PHA ; save on stack
INY ; increment index
LDA (sdescr),Y ; get source string pointer low byte
TAX ; copy to X
INY ; increment index
LDA (sdescr),Y ; get source string pointer high byte
TAY ; copy to Y
PLA ; get length back
; store string A bytes long from YX to (Sutill)
LAB_2298
STX ut1_pl ; save source string pointer low byte
STY ut1_ph ; save source string pointer high byte
; store string A bytes long from (ut1_pl) to (Sutill)
LAB_229C
TAX ; copy length to index (don't count with Y)
BEQ LAB_22B2 ; branch if = $0 (null string) no need to add zero length
LDY #$00 ; zero pointer (copy forward)
LAB_22A0
LDA (ut1_pl),Y ; get source byte
STA (Sutill),Y ; save destination byte
INY ; increment index
DEX ; decrement counter
BNE LAB_22A0 ; loop while <> 0
TYA ; restore length from Y
LAB_22A9
CLC ; clear carry for add
ADC Sutill ; add string utility ptr low byte
STA Sutill ; save string utility ptr low byte
BCC LAB_22B2 ; branch if no carry
INC Sutilh ; else increment string utility ptr high byte
LAB_22B2
RTS
; evaluate string
LAB_EVST
JSR LAB_CTST ; check if source is string, else do type mismatch
; pop string off descriptor stack, or from top of string space
; returns with A = length, X=pointer low byte, Y=pointer high byte
LAB_22B6
LDA des_pl ; get descriptor pointer low byte
LDY des_ph ; get descriptor pointer high byte
; pop (YA) descriptor off stack or from top of string space
; returns with A = length, X=ut1_pl=pointer low byte, Y=ut1_ph=pointer high byte
LAB_22BA
STA ut1_pl ; save descriptor pointer low byte
STY ut1_ph ; save descriptor pointer high byte
JSR LAB_22EB ; clean descriptor stack, YA = pointer
PHP ; save status flags
LDY #$00 ; clear index
LDA (ut1_pl),Y ; get length from string descriptor
PHA ; put on stack
INY ; increment index
LDA (ut1_pl),Y ; get string pointer low byte from descriptor
TAX ; copy to X
INY ; increment index
LDA (ut1_pl),Y ; get string pointer high byte from descriptor
TAY ; copy to Y
PLA ; get string length back
PLP ; restore status
BNE LAB_22E6 ; branch if pointer <> last_sl,last_sh
CPY Sstorh ; compare bottom of string space high byte
BNE LAB_22E6 ; branch if <>
CPX Sstorl ; else compare bottom of string space low byte
BNE LAB_22E6 ; branch if <>
PHA ; save string length
CLC ; clear carry for add
ADC Sstorl ; add bottom of string space low byte
STA Sstorl ; save bottom of string space low byte
BCC LAB_22E5 ; skip increment if no overflow
INC Sstorh ; increment bottom of string space high byte
LAB_22E5
PLA ; restore string length
LAB_22E6
STX ut1_pl ; save string pointer low byte
STY ut1_ph ; save string pointer high byte
RTS
; clean descriptor stack, YA = pointer
; checks if AY is on the descriptor stack, if so does a stack discard
LAB_22EB
CPY last_sh ; compare pointer high byte
BNE LAB_22FB ; exit if <>
CMP last_sl ; compare pointer low byte
BNE LAB_22FB ; exit if <>
STA next_s ; save descriptor stack pointer
SBC #$03 ; -3
STA last_sl ; save low byte -3
LDY #$00 ; clear high byte
LAB_22FB
RTS
; perform CHR$()
LAB_CHRS
JSR LAB_EVBY ; evaluate byte expression, result in X
TXA ; copy to A
PHA ; save character
LDA #$01 ; string is single byte
JSR LAB_MSSP ; make string space A bytes long A=$AC=length,
; X=$AD=Sutill=ptr low byte, Y=$AE=Sutilh=ptr high byte
PLA ; get character back
LDY #$00 ; clear index
STA (str_pl),Y ; save byte in string (byte IS string!)
JMP LAB_RTST ; check for space on descriptor stack then put string
; address and length on descriptor stack and update stack
; pointers
; perform LEFT$()
LAB_LEFT
PHA ; push byte parameter
JSR LAB_236F ; pull string data and byte parameter from stack
; return pointer in des_2l/h, byte in A (and X), Y=0
CMP (des_2l),Y ; compare byte parameter with string length
TYA ; clear A
BEQ LAB_2316 ; go do string copy (branch always)
; perform RIGHT$()
LAB_RIGHT
PHA ; push byte parameter
JSR LAB_236F ; pull string data and byte parameter from stack
; return pointer in des_2l/h, byte in A (and X), Y=0
CLC ; clear carry for add-1
SBC (des_2l),Y ; subtract string length
EOR #$FF ; invert it (A=LEN(expression$)-l)
LAB_2316
BCC LAB_231C ; branch if string length > byte parameter
LDA (des_2l),Y ; else make parameter = length
TAX ; copy to byte parameter copy
TYA ; clear string start offset
LAB_231C
PHA ; save string start offset
LAB_231D
TXA ; copy byte parameter (or string length if <)
LAB_231E
PHA ; save string length
JSR LAB_MSSP ; make string space A bytes long A=$AC=length,
; X=$AD=Sutill=ptr low byte, Y=$AE=Sutilh=ptr high byte
LDA des_2l ; get descriptor pointer low byte
LDY des_2h ; get descriptor pointer high byte
JSR LAB_22BA ; pop (YA) descriptor off stack or from top of string space
; returns with A = length, X=ut1_pl=pointer low byte,
; Y=ut1_ph=pointer high byte
PLA ; get string length back
TAY ; copy length to Y
PLA ; get string start offset back
CLC ; clear carry for add
ADC ut1_pl ; add start offset to string start pointer low byte
STA ut1_pl ; save string start pointer low byte
BCC LAB_2335 ; branch if no overflow
INC ut1_ph ; else increment string start pointer high byte
LAB_2335
TYA ; copy length to A
JSR LAB_229C ; store string A bytes long from (ut1_pl) to (Sutill)
JMP LAB_RTST ; check for space on descriptor stack then put string
; address and length on descriptor stack and update stack
; pointers
; perform MID$()
LAB_MIDS
PHA ; push byte parameter
LDA #$FF ; set default length = 255
STA mids_l ; save default length
JSR LAB_GBYT ; scan memory
CMP #')' ; compare with ")"
BEQ LAB_2358 ; branch if = ")" (skip second byte get)
JSR LAB_1C01 ; scan for "," , else do syntax error then warm start
JSR LAB_GTBY ; get byte parameter (use copy in mids_l)
LAB_2358
JSR LAB_236F ; pull string data and byte parameter from stack
; return pointer in des_2l/h, byte in A (and X), Y=0
DEX ; decrement start index
TXA ; copy to A
PHA ; save string start offset
CLC ; clear carry for sub-1
LDX #$00 ; clear output string length
SBC (des_2l),Y ; subtract string length
BCS LAB_231D ; if start>string length go do null string
EOR #$FF ; complement -length
CMP mids_l ; compare byte parameter
BCC LAB_231E ; if length>remaining string go do RIGHT$
LDA mids_l ; get length byte
BCS LAB_231E ; go do string copy (branch always)
; pull string data and byte parameter from stack
; return pointer in des_2l/h, byte in A (and X), Y=0
LAB_236F
JSR LAB_1BFB ; scan for ")" , else do syntax error then warm start
PLA ; pull return address low byte (return address)
STA Fnxjpl ; save functions jump vector low byte
PLA ; pull return address high byte (return address)
STA Fnxjph ; save functions jump vector high byte
PLA ; pull byte parameter
TAX ; copy byte parameter to X
PLA ; pull string pointer low byte
STA des_2l ; save it
PLA ; pull string pointer high byte
STA des_2h ; save it
LDY #$00 ; clear index
TXA ; copy byte parameter
BEQ LAB_23A8 ; if null do function call error then warm start
INC Fnxjpl ; increment function jump vector low byte
; (JSR pushes return addr-1. this is all very nice
; but will go tits up if either call is on a page
; boundary!)
JMP (Fnxjpl) ; in effect, RTS
; perform LCASE$()
LAB_LCASE
JSR LAB_EVST ; evaluate string
STA str_ln ; set string length
TAY ; copy length to Y
BEQ NoString ; branch if null string
JSR LAB_MSSP ; make string space A bytes long A=length,
; X=Sutill=ptr low byte, Y=Sutilh=ptr high byte
STX str_pl ; save string pointer low byte
STY str_ph ; save string pointer high byte
TAY ; get string length back
LC_loop
DEY ; decrement index
LDA (ut1_pl),Y ; get byte from string
JSR LAB_1D82 ; is character "A" to "Z"
BCC NoUcase ; branch if not upper case alpha
ORA #$20 ; convert upper to lower case
NoUcase
STA (Sutill),Y ; save byte back to string
TYA ; test index
BNE LC_loop ; loop if not all done
BEQ NoString ; tidy up and exit, branch always
; perform UCASE$()
LAB_UCASE
JSR LAB_EVST ; evaluate string
STA str_ln ; set string length
TAY ; copy length to Y
BEQ NoString ; branch if null string
JSR LAB_MSSP ; make string space A bytes long A=length,
; X=Sutill=ptr low byte, Y=Sutilh=ptr high byte
STX str_pl ; save string pointer low byte
STY str_ph ; save string pointer high byte
TAY ; get string length back
UC_loop
DEY ; decrement index
LDA (ut1_pl),Y ; get byte from string
JSR LAB_CASC ; is character "a" to "z" (or "A" to "Z")
BCC NoLcase ; branch if not alpha
AND #$DF ; convert lower to upper case
NoLcase
STA (Sutill),Y ; save byte back to string
TYA ; test index
BNE UC_loop ; loop if not all done
NoString
JMP LAB_RTST ; check for space on descriptor stack then put string
; address and length on descriptor stack and update stack
; pointers
; perform SADD()
LAB_SADD
JSR LAB_IGBY ; increment and scan memory
JSR LAB_GVAR ; get var address
JSR LAB_1BFB ; scan for ")", else do syntax error then warm start
JSR LAB_CTST ; check if source is string, else do type mismatch
LDY #$02 ; index to string pointer high byte
LDA (Cvaral),Y ; get string pointer high byte
TAX ; copy string pointer high byte to X
DEY ; index to string pointer low byte
LDA (Cvaral),Y ; get string pointer low byte
TAY ; copy string pointer low byte to Y
TXA ; copy string pointer high byte to A
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; perform LEN()
LAB_LENS
JSR LAB_ESGL ; evaluate string, get length in A (and Y)
JMP LAB_1FD0 ; convert Y to byte in FAC1 and return
; evaluate string, get length in Y
LAB_ESGL
JSR LAB_EVST ; evaluate string
TAY ; copy length to Y
RTS
; perform ASC()
LAB_ASC
JSR LAB_ESGL ; evaluate string, get length in A (and Y)
BEQ LAB_23A8 ; if null do function call error then warm start
LDY #$00 ; set index to first character
LDA (ut1_pl),Y ; get byte
TAY ; copy to Y
JMP LAB_1FD0 ; convert Y to byte in FAC1 and return
; do function call error then warm start
LAB_23A8
JMP LAB_FCER ; do function call error then warm start
; scan and get byte parameter
LAB_SGBY
JSR LAB_IGBY ; increment and scan memory
; get byte parameter
LAB_GTBY
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
; evaluate byte expression, result in X
LAB_EVBY
JSR LAB_EVPI ; evaluate integer expression (no check)
LDY FAC1_2 ; get FAC1 mantissa2
BNE LAB_23A8 ; if top byte <> 0 do function call error then warm start
LDX FAC1_3 ; get FAC1 mantissa3
JMP LAB_GBYT ; scan memory and return
; perform VAL()
LAB_VAL
JSR LAB_ESGL ; evaluate string, get length in A (and Y)
BNE LAB_23C5 ; branch if not null string
; string was null so set result = $00
JMP LAB_24F1 ; clear FAC1 exponent and sign and return
LAB_23C5
LDX Bpntrl ; get BASIC execute pointer low byte
LDY Bpntrh ; get BASIC execute pointer high byte
STX Btmpl ; save BASIC execute pointer low byte
STY Btmph ; save BASIC execute pointer high byte
LDX ut1_pl ; get string pointer low byte
STX Bpntrl ; save as BASIC execute pointer low byte
CLC ; clear carry
ADC ut1_pl ; add string length
STA ut2_pl ; save string end low byte
LDA ut1_ph ; get string pointer high byte
STA Bpntrh ; save as BASIC execute pointer high byte
ADC #$00 ; add carry to high byte
STA ut2_ph ; save string end high byte
LDY #$00 ; set index to $00
LDA (ut2_pl),Y ; get string end +1 byte
PHA ; push it
TYA ; clear A
STA (ut2_pl),Y ; terminate string with $00
JSR LAB_GBYT ; scan memory
JSR LAB_2887 ; get FAC1 from string
PLA ; restore string end +1 byte
LDY #$00 ; set index to zero
STA (ut2_pl),Y ; put string end byte back
; restore BASIC execute pointer from temp (Btmpl/Btmph)
LAB_23F3
LDX Btmpl ; get BASIC execute pointer low byte back
LDY Btmph ; get BASIC execute pointer high byte back
STX Bpntrl ; save BASIC execute pointer low byte
STY Bpntrh ; save BASIC execute pointer high byte
RTS
; get two parameters for POKE or WAIT
LAB_GADB
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
JSR LAB_F2FX ; save integer part of FAC1 in temporary integer
; scan for "," and get byte, else do Syntax error then warm start
LAB_SCGB
JSR LAB_1C01 ; scan for "," , else do syntax error then warm start
LDA Itemph ; save temporary integer high byte
PHA ; on stack
LDA Itempl ; save temporary integer low byte
PHA ; on stack
JSR LAB_GTBY ; get byte parameter
PLA ; pull low byte
STA Itempl ; restore temporary integer low byte
PLA ; pull high byte
STA Itemph ; restore temporary integer high byte
RTS
; convert float to fixed routine. accepts any value that fits in 24 bits, +ve or
; -ve and converts it into a right truncated integer in Itempl and Itemph
; save unsigned 16 bit integer part of FAC1 in temporary integer
LAB_F2FX
LDA FAC1_e ; get FAC1 exponent
CMP #$98 ; compare with exponent = 2^24
BCS LAB_23A8 ; if >= do function call error then warm start
LAB_F2FU
JSR LAB_2831 ; convert FAC1 floating-to-fixed
LDA FAC1_2 ; get FAC1 mantissa2
LDY FAC1_3 ; get FAC1 mantissa3
STY Itempl ; save temporary integer low byte
STA Itemph ; save temporary integer high byte
RTS
; perform PEEK()
LAB_PEEK
JSR LAB_F2FX ; save integer part of FAC1 in temporary integer
LDX #$00 ; clear index
LDA (Itempl,X) ; get byte via temporary integer (addr)
TAY ; copy byte to Y
JMP LAB_1FD0 ; convert Y to byte in FAC1 and return
; perform POKE
LAB_POKE
JSR LAB_GADB ; get two parameters for POKE or WAIT
TXA ; copy byte argument to A
LDX #$00 ; clear index
STA (Itempl,X) ; save byte via temporary integer (addr)
RTS
; perform DEEK()
LAB_DEEK
JSR LAB_F2FX ; save integer part of FAC1 in temporary integer
LDX #$00 ; clear index
LDA (Itempl,X) ; PEEK low byte
TAY ; copy to Y
INC Itempl ; increment pointer low byte
BNE Deekh ; skip high increment if no rollover
INC Itemph ; increment pointer high byte
Deekh
LDA (Itempl,X) ; PEEK high byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; perform DOKE
LAB_DOKE
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
JSR LAB_F2FX ; convert floating-to-fixed
STY Frnxtl ; save pointer low byte (float to fixed returns word in AY)
STA Frnxth ; save pointer high byte
JSR LAB_1C01 ; scan for "," , else do syntax error then warm start
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
JSR LAB_F2FX ; convert floating-to-fixed
TYA ; copy value low byte (float to fixed returns word in AY)
LDX #$00 ; clear index
STA (Frnxtl,X) ; POKE low byte
INC Frnxtl ; increment pointer low byte
BNE Dokeh ; skip high increment if no rollover
INC Frnxth ; increment pointer high byte
Dokeh
LDA Itemph ; get value high byte
STA (Frnxtl,X) ; POKE high byte
JMP LAB_GBYT ; scan memory and return
; perform SWAP
LAB_SWAP
JSR LAB_GVAR ; get var1 address
STA Lvarpl ; save var1 address low byte
STY Lvarph ; save var1 address high byte
LDA Dtypef ; get data type flag, $FF=string, $00=numeric
PHA ; save data type flag
JSR LAB_1C01 ; scan for "," , else do syntax error then warm start
JSR LAB_GVAR ; get var2 address (pointer in Cvaral/h)
PLA ; pull var1 data type flag
EOR Dtypef ; compare with var2 data type
BPL SwapErr ; exit if not both the same type
LDY #$03 ; four bytes to swap (either value or descriptor+1)
SwapLp
LDA (Lvarpl),Y ; get byte from var1
TAX ; save var1 byte
LDA (Cvaral),Y ; get byte from var2
STA (Lvarpl),Y ; save byte to var1
TXA ; restore var1 byte
STA (Cvaral),Y ; save byte to var2
DEY ; decrement index
BPL SwapLp ; loop until done
RTS
SwapErr
JMP LAB_1ABC ; do "Type mismatch" error then warm start
; perform CALL
LAB_CALL
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
JSR LAB_F2FX ; convert floating-to-fixed
LDA #>CallExit ; set return address high byte
PHA ; put on stack
LDA #<CallExit-1 ; set return address low byte
PHA ; put on stack
JMP (Itempl) ; do indirect jump to user routine
; if the called routine exits correctly then it will return to here. this will then get
; the next byte for the interpreter and return
CallExit
JMP LAB_GBYT ; scan memory and return
; perform WAIT
LAB_WAIT
JSR LAB_GADB ; get two parameters for POKE or WAIT
STX Frnxtl ; save byte
LDX #$00 ; clear mask
JSR LAB_GBYT ; scan memory
BEQ LAB_2441 ; skip if no third argument
JSR LAB_SCGB ; scan for "," and get byte, else SN error then warm start
LAB_2441
STX Frnxth ; save EOR argument
LAB_2445
LDA (Itempl),Y ; get byte via temporary integer (addr)
EOR Frnxth ; EOR with second argument (mask)
AND Frnxtl ; AND with first argument (byte)
BEQ LAB_2445 ; loop if result is zero
LAB_244D
RTS
; perform subtraction, FAC1 from (AY)
LAB_2455
JSR LAB_264D ; unpack memory (AY) into FAC2
; perform subtraction, FAC1 from FAC2
LAB_SUBTRACT
LDA FAC1_s ; get FAC1 sign (b7)
EOR #$FF ; complement it
STA FAC1_s ; save FAC1 sign (b7)
EOR FAC2_s ; EOR with FAC2 sign (b7)
STA FAC_sc ; save sign compare (FAC1 EOR FAC2)
LDA FAC1_e ; get FAC1 exponent
JMP LAB_ADD ; go add FAC2 to FAC1
; perform addition
LAB_2467
JSR LAB_257B ; shift FACX A times right (>8 shifts)
BCC LAB_24A8 ;.go subtract mantissas
; add 0.5 to FAC1
LAB_244E
LDA #<LAB_2A96 ; set 0.5 pointer low byte
LDY #>LAB_2A96 ; set 0.5 pointer high byte
; add (AY) to FAC1
LAB_246C
JSR LAB_264D ; unpack memory (AY) into FAC2
; add FAC2 to FAC1
LAB_ADD
BNE LAB_2474 ; branch if FAC1 was not zero
; copy FAC2 to FAC1
LAB_279B
LDA FAC2_s ; get FAC2 sign (b7)
; save FAC1 sign and copy ABS(FAC2) to FAC1
LAB_279D
STA FAC1_s ; save FAC1 sign (b7)
LDX #$04 ; 4 bytes to copy
LAB_27A1
LDA FAC1_o,X ; get byte from FAC2,X
STA FAC1_e-1,X ; save byte at FAC1,X
DEX ; decrement count
BNE LAB_27A1 ; loop if not all done
STX FAC1_r ; clear FAC1 rounding byte
RTS
; FAC1 is non zero
LAB_2474
LDX FAC1_r ; get FAC1 rounding byte
STX FAC2_r ; save as FAC2 rounding byte
LDX #FAC2_e ; set index to FAC2 exponent addr
LDA FAC2_e ; get FAC2 exponent
LAB_247C
TAY ; copy exponent
BEQ LAB_244D ; exit if zero
SEC ; set carry for subtract
SBC FAC1_e ; subtract FAC1 exponent
BEQ LAB_24A8 ; branch if = (go add mantissa)
BCC LAB_2498 ; branch if <
; FAC2>FAC1
STY FAC1_e ; save FAC1 exponent
LDY FAC2_s ; get FAC2 sign (b7)
STY FAC1_s ; save FAC1 sign (b7)
EOR #$FF ; complement A
ADC #$00 ; +1 (twos complement, carry is set)
LDY #$00 ; clear Y
STY FAC2_r ; clear FAC2 rounding byte
LDX #FAC1_e ; set index to FAC1 exponent addr
BNE LAB_249C ; branch always
LAB_2498
LDY #$00 ; clear Y
STY FAC1_r ; clear FAC1 rounding byte
LAB_249C
CMP #$F9 ; compare exponent diff with $F9
BMI LAB_2467 ; branch if range $79-$F8
TAY ; copy exponent difference to Y
LDA FAC1_r ; get FAC1 rounding byte
LSR PLUS_1,X ; shift FAC? mantissa1
JSR LAB_2592 ; shift FACX Y times right
; exponents are equal now do mantissa subtract
LAB_24A8
BIT FAC_sc ; test sign compare (FAC1 EOR FAC2)
BPL LAB_24F8 ; if = add FAC2 mantissa to FAC1 mantissa and return
LDY #FAC1_e ; set index to FAC1 exponent addr
CPX #FAC2_e ; compare X to FAC2 exponent addr
BEQ LAB_24B4 ; branch if =
LDY #FAC2_e ; else set index to FAC2 exponent addr
; subtract smaller from bigger (take sign of bigger)
LAB_24B4
SEC ; set carry for subtract
EOR #$FF ; ones complement A
ADC FAC2_r ; add FAC2 rounding byte
STA FAC1_r ; save FAC1 rounding byte
LDA PLUS_3,Y ; get FACY mantissa3
SBC PLUS_3,X ; subtract FACX mantissa3
STA FAC1_3 ; save FAC1 mantissa3
LDA PLUS_2,Y ; get FACY mantissa2
SBC PLUS_2,X ; subtract FACX mantissa2
STA FAC1_2 ; save FAC1 mantissa2
LDA PLUS_1,Y ; get FACY mantissa1
SBC PLUS_1,X ; subtract FACX mantissa1
STA FAC1_1 ; save FAC1 mantissa1
; do ABS and normalise FAC1
LAB_24D0
BCS LAB_24D5 ; branch if number is +ve
JSR LAB_2537 ; negate FAC1
; normalise FAC1
LAB_24D5
LDY #$00 ; clear Y
TYA ; clear A
CLC ; clear carry for add
LAB_24D9
LDX FAC1_1 ; get FAC1 mantissa1
BNE LAB_251B ; if not zero normalise FAC1
LDX FAC1_2 ; get FAC1 mantissa2
STX FAC1_1 ; save FAC1 mantissa1
LDX FAC1_3 ; get FAC1 mantissa3
STX FAC1_2 ; save FAC1 mantissa2
LDX FAC1_r ; get FAC1 rounding byte
STX FAC1_3 ; save FAC1 mantissa3
STY FAC1_r ; clear FAC1 rounding byte
ADC #$08 ; add x to exponent offset
CMP #$18 ; compare with $18 (max offset, all bits would be =0)
BNE LAB_24D9 ; loop if not max
; clear FAC1 exponent and sign
LAB_24F1
LDA #$00 ; clear A
LAB_24F3
STA FAC1_e ; set FAC1 exponent
; save FAC1 sign
LAB_24F5
STA FAC1_s ; save FAC1 sign (b7)
RTS
; add FAC2 mantissa to FAC1 mantissa
LAB_24F8
ADC FAC2_r ; add FAC2 rounding byte
STA FAC1_r ; save FAC1 rounding byte
LDA FAC1_3 ; get FAC1 mantissa3
ADC FAC2_3 ; add FAC2 mantissa3
STA FAC1_3 ; save FAC1 mantissa3
LDA FAC1_2 ; get FAC1 mantissa2
ADC FAC2_2 ; add FAC2 mantissa2
STA FAC1_2 ; save FAC1 mantissa2
LDA FAC1_1 ; get FAC1 mantissa1
ADC FAC2_1 ; add FAC2 mantissa1
STA FAC1_1 ; save FAC1 mantissa1
BCS LAB_252A ; if carry then normalise FAC1 for C=1
RTS ; else just exit
LAB_2511
ADC #$01 ; add 1 to exponent offset
ASL FAC1_r ; shift FAC1 rounding byte
ROL FAC1_3 ; shift FAC1 mantissa3
ROL FAC1_2 ; shift FAC1 mantissa2
ROL FAC1_1 ; shift FAC1 mantissa1
; normalise FAC1
LAB_251B
BPL LAB_2511 ; loop if not normalised
SEC ; set carry for subtract
SBC FAC1_e ; subtract FAC1 exponent
BCS LAB_24F1 ; branch if underflow (set result = $0)
EOR #$FF ; complement exponent
ADC #$01 ; +1 (twos complement)
STA FAC1_e ; save FAC1 exponent
; test and normalise FAC1 for C=0/1
LAB_2528
BCC LAB_2536 ; exit if no overflow
; normalise FAC1 for C=1
LAB_252A
INC FAC1_e ; increment FAC1 exponent
BEQ LAB_2564 ; if zero do overflow error and warm start
ROR FAC1_1 ; shift FAC1 mantissa1
ROR FAC1_2 ; shift FAC1 mantissa2
ROR FAC1_3 ; shift FAC1 mantissa3
ROR FAC1_r ; shift FAC1 rounding byte
LAB_2536
RTS
; negate FAC1
LAB_2537
LDA FAC1_s ; get FAC1 sign (b7)
EOR #$FF ; complement it
STA FAC1_s ; save FAC1 sign (b7)
; twos complement FAC1 mantissa
LAB_253D
LDA FAC1_1 ; get FAC1 mantissa1
EOR #$FF ; complement it
STA FAC1_1 ; save FAC1 mantissa1
LDA FAC1_2 ; get FAC1 mantissa2
EOR #$FF ; complement it
STA FAC1_2 ; save FAC1 mantissa2
LDA FAC1_3 ; get FAC1 mantissa3
EOR #$FF ; complement it
STA FAC1_3 ; save FAC1 mantissa3
LDA FAC1_r ; get FAC1 rounding byte
EOR #$FF ; complement it
STA FAC1_r ; save FAC1 rounding byte
INC FAC1_r ; increment FAC1 rounding byte
BNE LAB_2563 ; exit if no overflow
; increment FAC1 mantissa
LAB_2559
INC FAC1_3 ; increment FAC1 mantissa3
BNE LAB_2563 ; finished if no rollover
INC FAC1_2 ; increment FAC1 mantissa2
BNE LAB_2563 ; finished if no rollover
INC FAC1_1 ; increment FAC1 mantissa1
LAB_2563
RTS
; do overflow error (overflow exit)
LAB_2564
LDX #$0A ; error code $0A ("Overflow" error)
JMP LAB_XERR ; do error #X, then warm start
; shift FCAtemp << A+8 times
LAB_2569
LDX #FACt_1-1 ; set offset to FACtemp
LAB_256B
LDY PLUS_3,X ; get FACX mantissa3
STY FAC1_r ; save as FAC1 rounding byte
LDY PLUS_2,X ; get FACX mantissa2
STY PLUS_3,X ; save FACX mantissa3
LDY PLUS_1,X ; get FACX mantissa1
STY PLUS_2,X ; save FACX mantissa2
LDY FAC1_o ; get FAC1 overflow byte
STY PLUS_1,X ; save FACX mantissa1
; shift FACX -A times right (> 8 shifts)
LAB_257B
ADC #$08 ; add 8 to shift count
BMI LAB_256B ; go do 8 shift if still -ve
BEQ LAB_256B ; go do 8 shift if zero
SBC #$08 ; else subtract 8 again
TAY ; save count to Y
LDA FAC1_r ; get FAC1 rounding byte
BCS LAB_259A ;.
LAB_2588
ASL PLUS_1,X ; shift FACX mantissa1
BCC LAB_258E ; branch if +ve
INC PLUS_1,X ; this sets b7 eventually
LAB_258E
ROR PLUS_1,X ; shift FACX mantissa1 (correct for ASL)
ROR PLUS_1,X ; shift FACX mantissa1 (put carry in b7)
; shift FACX Y times right
LAB_2592
ROR PLUS_2,X ; shift FACX mantissa2
ROR PLUS_3,X ; shift FACX mantissa3
ROR ; shift FACX rounding byte
INY ; increment exponent diff
BNE LAB_2588 ; branch if range adjust not complete
LAB_259A
CLC ; just clear it
RTS
; perform LOG()
LAB_LOG
JSR LAB_27CA ; test sign and zero
BEQ LAB_25C4 ; if zero do function call error then warm start
BPL LAB_25C7 ; skip error if +ve
LAB_25C4
JMP LAB_FCER ; do function call error then warm start (-ve)
LAB_25C7
LDA FAC1_e ; get FAC1 exponent
SBC #$7F ; normalise it
PHA ; save it
LDA #$80 ; set exponent to zero
STA FAC1_e ; save FAC1 exponent
LDA #<LAB_25AD ; set 1/root2 pointer low byte
LDY #>LAB_25AD ; set 1/root2 pointer high byte
JSR LAB_246C ; add (AY) to FAC1 (1/root2)
LDA #<LAB_25B1 ; set root2 pointer low byte
LDY #>LAB_25B1 ; set root2 pointer high byte
JSR LAB_26CA ; convert AY and do (AY)/FAC1 (root2/(x+(1/root2)))
LDA #<LAB_259C ; set 1 pointer low byte
LDY #>LAB_259C ; set 1 pointer high byte
JSR LAB_2455 ; subtract (AY) from FAC1 ((root2/(x+(1/root2)))-1)
LDA #<LAB_25A0 ; set pointer low byte to counter
LDY #>LAB_25A0 ; set pointer high byte to counter
JSR LAB_2B6E ; ^2 then series evaluation
LDA #<LAB_25B5 ; set -0.5 pointer low byte
LDY #>LAB_25B5 ; set -0.5 pointer high byte
JSR LAB_246C ; add (AY) to FAC1
PLA ; restore FAC1 exponent
JSR LAB_2912 ; evaluate new ASCII digit
LDA #<LAB_25B9 ; set LOG(2) pointer low byte
LDY #>LAB_25B9 ; set LOG(2) pointer high byte
; do convert AY, FCA1*(AY)
LAB_25FB
JSR LAB_264D ; unpack memory (AY) into FAC2
LAB_MULTIPLY
BEQ LAB_264C ; exit if zero
JSR LAB_2673 ; test and adjust accumulators
LDA #$00 ; clear A
STA FACt_1 ; clear temp mantissa1
STA FACt_2 ; clear temp mantissa2
STA FACt_3 ; clear temp mantissa3
LDA FAC1_r ; get FAC1 rounding byte
JSR LAB_2622 ; go do shift/add FAC2
LDA FAC1_3 ; get FAC1 mantissa3
JSR LAB_2622 ; go do shift/add FAC2
LDA FAC1_2 ; get FAC1 mantissa2
JSR LAB_2622 ; go do shift/add FAC2
LDA FAC1_1 ; get FAC1 mantissa1
JSR LAB_2627 ; go do shift/add FAC2
JMP LAB_273C ; copy temp to FAC1, normalise and return
LAB_2622
BNE LAB_2627 ; branch if byte <> zero
JMP LAB_2569 ; shift FCAtemp << A+8 times
; else do shift and add
LAB_2627
LSR ; shift byte
ORA #$80 ; set top bit (mark for 8 times)
LAB_262A
TAY ; copy result
BCC LAB_2640 ; skip next if bit was zero
CLC ; clear carry for add
LDA FACt_3 ; get temp mantissa3
ADC FAC2_3 ; add FAC2 mantissa3
STA FACt_3 ; save temp mantissa3
LDA FACt_2 ; get temp mantissa2
ADC FAC2_2 ; add FAC2 mantissa2
STA FACt_2 ; save temp mantissa2
LDA FACt_1 ; get temp mantissa1
ADC FAC2_1 ; add FAC2 mantissa1
STA FACt_1 ; save temp mantissa1
LAB_2640
ROR FACt_1 ; shift temp mantissa1
ROR FACt_2 ; shift temp mantissa2
ROR FACt_3 ; shift temp mantissa3
ROR FAC1_r ; shift temp rounding byte
TYA ; get byte back
LSR ; shift byte
BNE LAB_262A ; loop if all bits not done
LAB_264C
RTS
; unpack memory (AY) into FAC2
LAB_264D
STA ut1_pl ; save pointer low byte
STY ut1_ph ; save pointer high byte
LDY #$03 ; 4 bytes to get (0-3)
LDA (ut1_pl),Y ; get mantissa3
STA FAC2_3 ; save FAC2 mantissa3
DEY ; decrement index
LDA (ut1_pl),Y ; get mantissa2
STA FAC2_2 ; save FAC2 mantissa2
DEY ; decrement index
LDA (ut1_pl),Y ; get mantissa1+sign
STA FAC2_s ; save FAC2 sign (b7)
EOR FAC1_s ; EOR with FAC1 sign (b7)
STA FAC_sc ; save sign compare (FAC1 EOR FAC2)
LDA FAC2_s ; recover FAC2 sign (b7)
ORA #$80 ; set 1xxx xxx (set normal bit)
STA FAC2_1 ; save FAC2 mantissa1
DEY ; decrement index
LDA (ut1_pl),Y ; get exponent byte
STA FAC2_e ; save FAC2 exponent
LDA FAC1_e ; get FAC1 exponent
RTS
; test and adjust accumulators
LAB_2673
LDA FAC2_e ; get FAC2 exponent
LAB_2675
BEQ LAB_2696 ; branch if FAC2 = $00 (handle underflow)
CLC ; clear carry for add
ADC FAC1_e ; add FAC1 exponent
BCC LAB_2680 ; branch if sum of exponents <$0100
BMI LAB_269B ; do overflow error
CLC ; clear carry for the add
.byte $2C ; makes next line BIT $1410
LAB_2680
BPL LAB_2696 ; if +ve go handle underflow
ADC #$80 ; adjust exponent
STA FAC1_e ; save FAC1 exponent
BNE LAB_268B ; branch if not zero
JMP LAB_24F5 ; save FAC1 sign and return
LAB_268B
LDA FAC_sc ; get sign compare (FAC1 EOR FAC2)
STA FAC1_s ; save FAC1 sign (b7)
LAB_268F
RTS
; handle overflow and underflow
LAB_2690
LDA FAC1_s ; get FAC1 sign (b7)
BPL LAB_269B ; do overflow error
; handle underflow
LAB_2696
PLA ; pop return address low byte
PLA ; pop return address high byte
JMP LAB_24F1 ; clear FAC1 exponent and sign and return
; multiply by 10
LAB_269E
JSR LAB_27AB ; round and copy FAC1 to FAC2
TAX ; copy exponent (set the flags)
BEQ LAB_268F ; exit if zero
CLC ; clear carry for add
ADC #$02 ; add two to exponent (*4)
BCS LAB_269B ; do overflow error if > $FF
LDX #$00 ; clear byte
STX FAC_sc ; clear sign compare (FAC1 EOR FAC2)
JSR LAB_247C ; add FAC2 to FAC1 (*5)
INC FAC1_e ; increment FAC1 exponent (*10)
BNE LAB_268F ; if non zero just do RTS
LAB_269B
JMP LAB_2564 ; do overflow error and warm start
; divide by 10
LAB_26B9
JSR LAB_27AB ; round and copy FAC1 to FAC2
LDA #<LAB_26B5 ; set pointer to 10d low addr
LDY #>LAB_26B5 ; set pointer to 10d high addr
LDX #$00 ; clear sign
; divide by (AY) (X=sign)
LAB_26C2
STX FAC_sc ; save sign compare (FAC1 EOR FAC2)
JSR LAB_UFAC ; unpack memory (AY) into FAC1
JMP LAB_DIVIDE ; do FAC2/FAC1
; Perform divide-by
; convert AY and do (AY)/FAC1
LAB_26CA
JSR LAB_264D ; unpack memory (AY) into FAC2
; Perform divide-into
LAB_DIVIDE
BEQ LAB_2737 ; if zero go do /0 error
JSR LAB_27BA ; round FAC1
LDA #$00 ; clear A
SEC ; set carry for subtract
SBC FAC1_e ; subtract FAC1 exponent (2s complement)
STA FAC1_e ; save FAC1 exponent
JSR LAB_2673 ; test and adjust accumulators
INC FAC1_e ; increment FAC1 exponent
BEQ LAB_269B ; if zero do overflow error
LDX #$FF ; set index for pre increment
LDA #$01 ; set bit to flag byte save
LAB_26E4
LDY FAC2_1 ; get FAC2 mantissa1
CPY FAC1_1 ; compare FAC1 mantissa1
BNE LAB_26F4 ; branch if <>
LDY FAC2_2 ; get FAC2 mantissa2
CPY FAC1_2 ; compare FAC1 mantissa2
BNE LAB_26F4 ; branch if <>
LDY FAC2_3 ; get FAC2 mantissa3
CPY FAC1_3 ; compare FAC1 mantissa3
LAB_26F4
PHP ; save FAC2-FAC1 compare status
ROL ; shift the result byte
BCC LAB_2702 ; if no carry skip the byte save
LDY #$01 ; set bit to flag byte save
INX ; else increment the index to FACt
CPX #$02 ; compare with the index to FACt_3
BMI LAB_2701 ; if not last byte just go save it
BNE LAB_272B ; if all done go save FAC1 rounding byte, normalise and
; return
LDY #$40 ; set bit to flag byte save for the rounding byte
LAB_2701
STA FACt_1,X ; write result byte to FACt_1 + index
TYA ; copy the next save byte flag
LAB_2702
PLP ; restore FAC2-FAC1 compare status
BCC LAB_2704 ; if FAC2 < FAC1 then skip the subtract
TAY ; save FAC2-FAC1 compare status
LDA FAC2_3 ; get FAC2 mantissa3
SBC FAC1_3 ; subtract FAC1 mantissa3
STA FAC2_3 ; save FAC2 mantissa3
LDA FAC2_2 ; get FAC2 mantissa2
SBC FAC1_2 ; subtract FAC1 mantissa2
STA FAC2_2 ; save FAC2 mantissa2
LDA FAC2_1 ; get FAC2 mantissa1
SBC FAC1_1 ; subtract FAC1 mantissa1
STA FAC2_1 ; save FAC2 mantissa1
TYA ; restore FAC2-FAC1 compare status
; FAC2 = FAC2*2
LAB_2704
ASL FAC2_3 ; shift FAC2 mantissa3
ROL FAC2_2 ; shift FAC2 mantissa2
ROL FAC2_1 ; shift FAC2 mantissa1
BCS LAB_26F4 ; loop with no compare
BMI LAB_26E4 ; loop with compare
BPL LAB_26F4 ; loop always with no compare
; do A<<6, save as FAC1 rounding byte, normalise and return
LAB_272B
LSR ; shift b1 - b0 ..
ROR ; ..
ROR ; .. to b7 - b6
STA FAC1_r ; save FAC1 rounding byte
PLP ; dump FAC2-FAC1 compare status
JMP LAB_273C ; copy temp to FAC1, normalise and return
; do "Divide by zero" error
LAB_2737
LDX #$14 ; error code $14 ("Divide by zero" error)
JMP LAB_XERR ; do error #X, then warm start
; copy temp to FAC1 and normalise
LAB_273C
LDA FACt_1 ; get temp mantissa1
STA FAC1_1 ; save FAC1 mantissa1
LDA FACt_2 ; get temp mantissa2
STA FAC1_2 ; save FAC1 mantissa2
LDA FACt_3 ; get temp mantissa3
STA FAC1_3 ; save FAC1 mantissa3
JMP LAB_24D5 ; normalise FAC1 and return
; unpack memory (AY) into FAC1
LAB_UFAC
STA ut1_pl ; save pointer low byte
STY ut1_ph ; save pointer high byte
LDY #$03 ; 4 bytes to do
LDA (ut1_pl),Y ; get last byte
STA FAC1_3 ; save FAC1 mantissa3
DEY ; decrement index
LDA (ut1_pl),Y ; get last-1 byte
STA FAC1_2 ; save FAC1 mantissa2
DEY ; decrement index
LDA (ut1_pl),Y ; get second byte
STA FAC1_s ; save FAC1 sign (b7)
ORA #$80 ; set 1xxx xxxx (add normal bit)
STA FAC1_1 ; save FAC1 mantissa1
DEY ; decrement index
LDA (ut1_pl),Y ; get first byte (exponent)
STA FAC1_e ; save FAC1 exponent
STY FAC1_r ; clear FAC1 rounding byte
RTS
; pack FAC1 into Adatal
LAB_276E
LDX #<Adatal ; set pointer low byte
LAB_2770
LDY #>Adatal ; set pointer high byte
BEQ LAB_2778 ; pack FAC1 into (XY) and return
; pack FAC1 into (Lvarpl)
LAB_PFAC
LDX Lvarpl ; get destination pointer low byte
LDY Lvarph ; get destination pointer high byte
; pack FAC1 into (XY)
LAB_2778
JSR LAB_27BA ; round FAC1
STX ut1_pl ; save pointer low byte
STY ut1_ph ; save pointer high byte
LDY #$03 ; set index
LDA FAC1_3 ; get FAC1 mantissa3
STA (ut1_pl),Y ; store in destination
DEY ; decrement index
LDA FAC1_2 ; get FAC1 mantissa2
STA (ut1_pl),Y ; store in destination
DEY ; decrement index
LDA FAC1_s ; get FAC1 sign (b7)
ORA #$7F ; set bits x111 1111
AND FAC1_1 ; AND in FAC1 mantissa1
STA (ut1_pl),Y ; store in destination
DEY ; decrement index
LDA FAC1_e ; get FAC1 exponent
STA (ut1_pl),Y ; store in destination
STY FAC1_r ; clear FAC1 rounding byte
RTS
; round and copy FAC1 to FAC2
LAB_27AB
JSR LAB_27BA ; round FAC1
; copy FAC1 to FAC2
LAB_27AE
LDX #$05 ; 5 bytes to copy
LAB_27B0
LDA FAC1_e-1,X ; get byte from FAC1,X
STA FAC1_o,X ; save byte at FAC2,X
DEX ; decrement count
BNE LAB_27B0 ; loop if not all done
STX FAC1_r ; clear FAC1 rounding byte
LAB_27B9
RTS
; round FAC1
LAB_27BA
LDA FAC1_e ; get FAC1 exponent
BEQ LAB_27B9 ; exit if zero
ASL FAC1_r ; shift FAC1 rounding byte
BCC LAB_27B9 ; exit if no overflow
; round FAC1 (no check)
LAB_27C2
JSR LAB_2559 ; increment FAC1 mantissa
BNE LAB_27B9 ; branch if no overflow
JMP LAB_252A ; normalise FAC1 for C=1 and return
; get FAC1 sign
; return A=FF,C=1/-ve A=01,C=0/+ve
LAB_27CA
LDA FAC1_e ; get FAC1 exponent
BEQ LAB_27D7 ; exit if zero (already correct SGN(0)=0)
; return A=FF,C=1/-ve A=01,C=0/+ve
; no = 0 check
LAB_27CE
LDA FAC1_s ; else get FAC1 sign (b7)
; return A=FF,C=1/-ve A=01,C=0/+ve
; no = 0 check, sign in A
LAB_27D0
ROL ; move sign bit to carry
LDA #$FF ; set byte for -ve result
BCS LAB_27D7 ; return if sign was set (-ve)
LDA #$01 ; else set byte for +ve result
LAB_27D7
RTS
; perform SGN()
LAB_SGN
JSR LAB_27CA ; get FAC1 sign
; return A=$FF/-ve A=$01/+ve
; save A as integer byte
LAB_27DB
STA FAC1_1 ; save FAC1 mantissa1
LDA #$00 ; clear A
STA FAC1_2 ; clear FAC1 mantissa2
LDX #$88 ; set exponent
; set exp=X, clearFAC1 mantissa3 and normalise
LAB_27E3
LDA FAC1_1 ; get FAC1 mantissa1
EOR #$FF ; complement it
ROL ; sign bit into carry
; set exp=X, clearFAC1 mantissa3 and normalise
LAB_STFA
LDA #$00 ; clear A
STA FAC1_3 ; clear FAC1 mantissa3
STX FAC1_e ; set FAC1 exponent
STA FAC1_r ; clear FAC1 rounding byte
STA FAC1_s ; clear FAC1 sign (b7)
JMP LAB_24D0 ; do ABS and normalise FAC1
; perform ABS()
LAB_ABS
LSR FAC1_s ; clear FAC1 sign (put zero in b7)
RTS
; compare FAC1 with (AY)
; returns A=$00 if FAC1 = (AY)
; returns A=$01 if FAC1 > (AY)
; returns A=$FF if FAC1 < (AY)
LAB_27F8
STA ut2_pl ; save pointer low byte
LAB_27FA
STY ut2_ph ; save pointer high byte
LDY #$00 ; clear index
LDA (ut2_pl),Y ; get exponent
INY ; increment index
TAX ; copy (AY) exponent to X
BEQ LAB_27CA ; branch if (AY) exponent=0 and get FAC1 sign
; A=FF,C=1/-ve A=01,C=0/+ve
LDA (ut2_pl),Y ; get (AY) mantissa1 (with sign)
EOR FAC1_s ; EOR FAC1 sign (b7)
BMI LAB_27CE ; if signs <> do return A=FF,C=1/-ve
; A=01,C=0/+ve and return
CPX FAC1_e ; compare (AY) exponent with FAC1 exponent
BNE LAB_2828 ; branch if different
LDA (ut2_pl),Y ; get (AY) mantissa1 (with sign)
ORA #$80 ; normalise top bit
CMP FAC1_1 ; compare with FAC1 mantissa1
BNE LAB_2828 ; branch if different
INY ; increment index
LDA (ut2_pl),Y ; get mantissa2
CMP FAC1_2 ; compare with FAC1 mantissa2
BNE LAB_2828 ; branch if different
INY ; increment index
LDA #$7F ; set for 1/2 value rounding byte
CMP FAC1_r ; compare with FAC1 rounding byte (set carry)
LDA (ut2_pl),Y ; get mantissa3
SBC FAC1_3 ; subtract FAC1 mantissa3
BEQ LAB_2850 ; exit if mantissa3 equal
; gets here if number <> FAC1
LAB_2828
LDA FAC1_s ; get FAC1 sign (b7)
BCC LAB_282E ; branch if FAC1 > (AY)
EOR #$FF ; else toggle FAC1 sign
LAB_282E
JMP LAB_27D0 ; return A=FF,C=1/-ve A=01,C=0/+ve
; convert FAC1 floating-to-fixed
LAB_2831
LDA FAC1_e ; get FAC1 exponent
BEQ LAB_287F ; if zero go clear FAC1 and return
SEC ; set carry for subtract
SBC #$98 ; subtract maximum integer range exponent
BIT FAC1_s ; test FAC1 sign (b7)
BPL LAB_2845 ; branch if FAC1 +ve
; FAC1 was -ve
TAX ; copy subtracted exponent
LDA #$FF ; overflow for -ve number
STA FAC1_o ; set FAC1 overflow byte
JSR LAB_253D ; twos complement FAC1 mantissa
TXA ; restore subtracted exponent
LAB_2845
LDX #FAC1_e ; set index to FAC1
CMP #$F9 ; compare exponent result
BPL LAB_2851 ; if < 8 shifts shift FAC1 A times right and return
JSR LAB_257B ; shift FAC1 A times right (> 8 shifts)
STY FAC1_o ; clear FAC1 overflow byte
LAB_2850
RTS
; shift FAC1 A times right
LAB_2851
TAY ; copy shift count
LDA FAC1_s ; get FAC1 sign (b7)
AND #$80 ; mask sign bit only (x000 0000)
LSR FAC1_1 ; shift FAC1 mantissa1
ORA FAC1_1 ; OR sign in b7 FAC1 mantissa1
STA FAC1_1 ; save FAC1 mantissa1
JSR LAB_2592 ; shift FAC1 Y times right
STY FAC1_o ; clear FAC1 overflow byte
RTS
; perform INT()
LAB_INT
LDA FAC1_e ; get FAC1 exponent
CMP #$98 ; compare with max int
BCS LAB_2886 ; exit if >= (already int, too big for fractional part!)
JSR LAB_2831 ; convert FAC1 floating-to-fixed
STY FAC1_r ; save FAC1 rounding byte
LDA FAC1_s ; get FAC1 sign (b7)
STY FAC1_s ; save FAC1 sign (b7)
EOR #$80 ; toggle FAC1 sign
ROL ; shift into carry
LDA #$98 ; set new exponent
STA FAC1_e ; save FAC1 exponent
LDA FAC1_3 ; get FAC1 mantissa3
STA Temp3 ; save for EXP() function
JMP LAB_24D0 ; do ABS and normalise FAC1
; clear FAC1 and return
LAB_287F
STA FAC1_1 ; clear FAC1 mantissa1
STA FAC1_2 ; clear FAC1 mantissa2
STA FAC1_3 ; clear FAC1 mantissa3
TAY ; clear Y
LAB_2886
RTS
; get FAC1 from string
; this routine now handles hex and binary values from strings
; starting with "$" and "%" respectively
LAB_2887
LDY #$00 ; clear Y
STY Dtypef ; clear data type flag, $FF=string, $00=numeric
LDX #$09 ; set index
LAB_288B
STY numexp,X ; clear byte
DEX ; decrement index
BPL LAB_288B ; loop until numexp to negnum (and FAC1) = $00
BCC LAB_28FE ; branch if 1st character numeric
; get FAC1 from string .. first character wasn't numeric
CMP #'-' ; else compare with "-"
BNE LAB_289A ; branch if not "-"
STX negnum ; set flag for -ve number (X = $FF)
BEQ LAB_289C ; branch always (go scan and check for hex/bin)
; get FAC1 from string .. first character wasn't numeric or -
LAB_289A
CMP #'+' ; else compare with "+"
BNE LAB_289D ; branch if not "+" (go check for hex/bin)
; was "+" or "-" to start, so get next character
LAB_289C
JSR LAB_IGBY ; increment and scan memory
BCC LAB_28FE ; branch if numeric character
; code here for hex and binary numbers
LAB_289D
CMP #'$' ; else compare with "$"
BNE LAB_NHEX ; branch if not "$"
JMP LAB_CHEX ; branch if "$"
LAB_NHEX
CMP #'%' ; else compare with "%"
BNE LAB_28A3 ; branch if not "%" (continue original code)
JMP LAB_CBIN ; branch if "%"
LAB_289E
JSR LAB_IGBY ; increment and scan memory (ignore + or get next number)
LAB_28A1
BCC LAB_28FE ; branch if numeric character
; get FAC1 from string .. character wasn't numeric, -, +, hex or binary
LAB_28A3
CMP #'.' ; else compare with "."
BEQ LAB_28D5 ; branch if "."
; get FAC1 from string .. character wasn't numeric, -, + or .
CMP #'E' ; else compare with "E"
BNE LAB_28DB ; branch if not "E"
; was "E" so evaluate exponential part
JSR LAB_IGBY ; increment and scan memory
BCC LAB_28C7 ; branch if numeric character
CMP #TK_MINUS ; else compare with token for -
BEQ LAB_28C2 ; branch if token for -
CMP #'-' ; else compare with "-"
BEQ LAB_28C2 ; branch if "-"
CMP #TK_PLUS ; else compare with token for +
BEQ LAB_28C4 ; branch if token for +
CMP #'+' ; else compare with "+"
BEQ LAB_28C4 ; branch if "+"
BNE LAB_28C9 ; branch always
LAB_28C2
ROR expneg ; set exponent -ve flag (C, which=1, into b7)
LAB_28C4
JSR LAB_IGBY ; increment and scan memory
LAB_28C7
BCC LAB_2925 ; branch if numeric character
LAB_28C9
BIT expneg ; test exponent -ve flag
BPL LAB_28DB ; if +ve go evaluate exponent
; else do exponent = -exponent
LDA #$00 ; clear result
SEC ; set carry for subtract
SBC expcnt ; subtract exponent byte
JMP LAB_28DD ; go evaluate exponent
LAB_28D5
ROR numdpf ; set decimal point flag
BIT numdpf ; test decimal point flag
BVC LAB_289E ; branch if only one decimal point so far
; evaluate exponent
LAB_28DB
LDA expcnt ; get exponent count byte
LAB_28DD
SEC ; set carry for subtract
SBC numexp ; subtract numerator exponent
STA expcnt ; save exponent count byte
BEQ LAB_28F6 ; branch if no adjustment
BPL LAB_28EF ; else if +ve go do FAC1*10^expcnt
; else go do FAC1/10^(0-expcnt)
LAB_28E6
JSR LAB_26B9 ; divide by 10
INC expcnt ; increment exponent count byte
BNE LAB_28E6 ; loop until all done
BEQ LAB_28F6 ; branch always
LAB_28EF
JSR LAB_269E ; multiply by 10
DEC expcnt ; decrement exponent count byte
BNE LAB_28EF ; loop until all done
LAB_28F6
LDA negnum ; get -ve flag
BMI LAB_28FB ; if -ve do - FAC1 and return
RTS
; do - FAC1 and return
LAB_28FB
JMP LAB_GTHAN ; do - FAC1 and return
; do unsigned FAC1*10+number
LAB_28FE
PHA ; save character
BIT numdpf ; test decimal point flag
BPL LAB_2905 ; skip exponent increment if not set
INC numexp ; else increment number exponent
LAB_2905
JSR LAB_269E ; multiply FAC1 by 10
PLA ; restore character
AND #$0F ; convert to binary
JSR LAB_2912 ; evaluate new ASCII digit
JMP LAB_289E ; go do next character
; evaluate new ASCII digit
LAB_2912
PHA ; save digit
JSR LAB_27AB ; round and copy FAC1 to FAC2
PLA ; restore digit
JSR LAB_27DB ; save A as integer byte
LDA FAC2_s ; get FAC2 sign (b7)
EOR FAC1_s ; toggle with FAC1 sign (b7)
STA FAC_sc ; save sign compare (FAC1 EOR FAC2)
LDX FAC1_e ; get FAC1 exponent
JMP LAB_ADD ; add FAC2 to FAC1 and return
; evaluate next character of exponential part of number
LAB_2925
LDA expcnt ; get exponent count byte
CMP #$0A ; compare with 10 decimal
BCC LAB_2934 ; branch if less
LDA #$64 ; make all -ve exponents = -100 decimal (causes underflow)
BIT expneg ; test exponent -ve flag
BMI LAB_2942 ; branch if -ve
JMP LAB_2564 ; else do overflow error
LAB_2934
ASL ; * 2
ASL ; * 4
ADC expcnt ; * 5
ASL ; * 10
LDY #$00 ; set index
ADC (Bpntrl),Y ; add character (will be $30 too much!)
SBC #'0'-1 ; convert character to binary
LAB_2942
STA expcnt ; save exponent count byte
JMP LAB_28C4 ; go get next character
; print " in line [LINE #]"
LAB_2953
LDA #<LAB_LMSG ; point to " in line " message low byte
LDY #>LAB_LMSG ; point to " in line " message high byte
JSR LAB_18C3 ; print null terminated string from memory
; print Basic line #
LDA Clineh ; get current line high byte
LDX Clinel ; get current line low byte
; print XA as unsigned integer
LAB_295E
STA FAC1_1 ; save low byte as FAC1 mantissa1
STX FAC1_2 ; save high byte as FAC1 mantissa2
LDX #$90 ; set exponent to 16d bits
SEC ; set integer is +ve flag
JSR LAB_STFA ; set exp=X, clearFAC1 mantissa3 and normalise
LDY #$00 ; clear index
TYA ; clear A
JSR LAB_297B ; convert FAC1 to string, skip sign character save
JMP LAB_18C3 ; print null terminated string from memory and return
; convert FAC1 to ASCII string result in (AY)
; not any more, moved scratchpad to page 0
LAB_296E
LDY #$01 ; set index = 1
LDA #$20 ; character = " " (assume +ve)
BIT FAC1_s ; test FAC1 sign (b7)
BPL LAB_2978 ; branch if +ve
LDA #$2D ; else character = "-"
LAB_2978
STA Decss,Y ; save leading character (" " or "-")
LAB_297B
STA FAC1_s ; clear FAC1 sign (b7)
STY Sendl ; save index
INY ; increment index
LDX FAC1_e ; get FAC1 exponent
BNE LAB_2989 ; branch if FAC1<>0
; exponent was $00 so FAC1 is 0
LDA #'0' ; set character = "0"
JMP LAB_2A89 ; save last character, [EOT] and exit
; FAC1 is some non zero value
LAB_2989
LDA #$00 ; clear (number exponent count)
CPX #$81 ; compare FAC1 exponent with $81 (>1.00000)
BCS LAB_299A ; branch if FAC1=>1
; FAC1<1
LDA #<LAB_294F ; set pointer low byte to 1,000,000
LDY #>LAB_294F ; set pointer high byte to 1,000,000
JSR LAB_25FB ; do convert AY, FCA1*(AY)
LDA #$FA ; set number exponent count (-6)
LAB_299A
STA numexp ; save number exponent count
LAB_299C
LDA #<LAB_294B ; set pointer low byte to 999999.4375 (max before sci note)
LDY #>LAB_294B ; set pointer high byte to 999999.4375
JSR LAB_27F8 ; compare FAC1 with (AY)
BEQ LAB_29C3 ; exit if FAC1 = (AY)
BPL LAB_29B9 ; go do /10 if FAC1 > (AY)
; FAC1 < (AY)
LAB_29A7
LDA #<LAB_2947 ; set pointer low byte to 99999.9375
LDY #>LAB_2947 ; set pointer high byte to 99999.9375
JSR LAB_27F8 ; compare FAC1 with (AY)
BEQ LAB_29B2 ; branch if FAC1 = (AY) (allow decimal places)
BPL LAB_29C0 ; branch if FAC1 > (AY) (no decimal places)
; FAC1 <= (AY)
LAB_29B2
JSR LAB_269E ; multiply by 10
DEC numexp ; decrement number exponent count
BNE LAB_29A7 ; go test again (branch always)
LAB_29B9
JSR LAB_26B9 ; divide by 10
INC numexp ; increment number exponent count
BNE LAB_299C ; go test again (branch always)
; now we have just the digits to do
LAB_29C0
JSR LAB_244E ; add 0.5 to FAC1 (round FAC1)
LAB_29C3
JSR LAB_2831 ; convert FAC1 floating-to-fixed
LDX #$01 ; set default digits before dp = 1
LDA numexp ; get number exponent count
CLC ; clear carry for add
ADC #$07 ; up to 6 digits before point
BMI LAB_29D8 ; if -ve then 1 digit before dp
CMP #$08 ; A>=8 if n>=1E6
BCS LAB_29D9 ; branch if >= $08
; carry is clear
ADC #$FF ; take 1 from digit count
TAX ; copy to A
LDA #$02 ;.set exponent adjust
LAB_29D8
SEC ; set carry for subtract
LAB_29D9
SBC #$02 ; -2
STA expcnt ;.save exponent adjust
STX numexp ; save digits before dp count
TXA ; copy to A
BEQ LAB_29E4 ; branch if no digits before dp
BPL LAB_29F7 ; branch if digits before dp
LAB_29E4
LDY Sendl ; get output string index
LDA #$2E ; character "."
INY ; increment index
STA Decss,Y ; save to output string
TXA ;.
BEQ LAB_29F5 ;.
LDA #'0' ; character "0"
INY ; increment index
STA Decss,Y ; save to output string
LAB_29F5
STY Sendl ; save output string index
LAB_29F7
LDY #$00 ; clear index (point to 100,000)
LDX #$80 ;
LAB_29FB
LDA FAC1_3 ; get FAC1 mantissa3
CLC ; clear carry for add
ADC LAB_2A9C,Y ; add -ve LSB
STA FAC1_3 ; save FAC1 mantissa3
LDA FAC1_2 ; get FAC1 mantissa2
ADC LAB_2A9B,Y ; add -ve NMSB
STA FAC1_2 ; save FAC1 mantissa2
LDA FAC1_1 ; get FAC1 mantissa1
ADC LAB_2A9A,Y ; add -ve MSB
STA FAC1_1 ; save FAC1 mantissa1
INX ;
BCS LAB_2A18 ;
BPL LAB_29FB ; not -ve so try again
BMI LAB_2A1A ;
LAB_2A18
BMI LAB_29FB ;
LAB_2A1A
TXA ;
BCC LAB_2A21 ;
EOR #$FF ;
ADC #$0A ;
LAB_2A21
ADC #'0'-1 ; add "0"-1 to result
INY ; increment index ..
INY ; .. to next less ..
INY ; .. power of ten
STY Cvaral ; save as current var address low byte
LDY Sendl ; get output string index
INY ; increment output string index
TAX ; copy character to X
AND #$7F ; mask out top bit
STA Decss,Y ; save to output string
DEC numexp ; decrement # of characters before the dp
BNE LAB_2A3B ; branch if still characters to do
; else output the point
LDA #$2E ; character "."
INY ; increment output string index
STA Decss,Y ; save to output string
LAB_2A3B
STY Sendl ; save output string index
LDY Cvaral ; get current var address low byte
TXA ; get character back
EOR #$FF ;
AND #$80 ;
TAX ;
CPY #$12 ; compare index with max
BNE LAB_29FB ; loop if not max
; now remove trailing zeroes
LDY Sendl ; get output string index
LAB_2A4B
LDA Decss,Y ; get character from output string
DEY ; decrement output string index
CMP #'0' ; compare with "0"
BEQ LAB_2A4B ; loop until non "0" character found
CMP #'.' ; compare with "."
BEQ LAB_2A58 ; branch if was dp
; restore last character
INY ; increment output string index
LAB_2A58
LDA #$2B ; character "+"
LDX expcnt ; get exponent count
BEQ LAB_2A8C ; if zero go set null terminator and exit
; exponent isn't zero so write exponent
BPL LAB_2A68 ; branch if exponent count +ve
LDA #$00 ; clear A
SEC ; set carry for subtract
SBC expcnt ; subtract exponent count adjust (convert -ve to +ve)
TAX ; copy exponent count to X
LDA #'-' ; character "-"
LAB_2A68
STA Decss+2,Y ; save to output string
LDA #$45 ; character "E"
STA Decss+1,Y ; save exponent sign to output string
TXA ; get exponent count back
LDX #'0'-1 ; one less than "0" character
SEC ; set carry for subtract
LAB_2A74
INX ; increment 10's character
SBC #$0A ;.subtract 10 from exponent count
BCS LAB_2A74 ; loop while still >= 0
ADC #':' ; add character ":" ($30+$0A, result is 10 less that value)
STA Decss+4,Y ; save to output string
TXA ; copy 10's character
STA Decss+3,Y ; save to output string
LDA #$00 ; set null terminator
STA Decss+5,Y ; save to output string
BEQ LAB_2A91 ; go set string pointer (AY) and exit (branch always)
; save last character, [EOT] and exit
LAB_2A89
STA Decss,Y ; save last character to output string
; set null terminator and exit
LAB_2A8C
LDA #$00 ; set null terminator
STA Decss+1,Y ; save after last character
; set string pointer (AY) and exit
LAB_2A91
LDA #<Decssp1 ; set result string low pointer
LDY #>Decssp1 ; set result string high pointer
RTS
; perform power function
LAB_POWER
BEQ LAB_EXP ; go do EXP()
LDA FAC2_e ; get FAC2 exponent
BNE LAB_2ABF ; branch if FAC2<>0
JMP LAB_24F3 ; clear FAC1 exponent and sign and return
LAB_2ABF
LDX #<func_l ; set destination pointer low byte
LDY #>func_l ; set destination pointer high byte
JSR LAB_2778 ; pack FAC1 into (XY)
LDA FAC2_s ; get FAC2 sign (b7)
BPL LAB_2AD9 ; branch if FAC2>0
; else FAC2 is -ve and can only be raised to an
; integer power which gives an x +j0 result
JSR LAB_INT ; perform INT
LDA #<func_l ; set source pointer low byte
LDY #>func_l ; set source pointer high byte
JSR LAB_27F8 ; compare FAC1 with (AY)
BNE LAB_2AD9 ; branch if FAC1 <> (AY) to allow Function Call error
; this will leave FAC1 -ve and cause a Function Call
; error when LOG() is called
TYA ; clear sign b7
LDY Temp3 ; save mantissa 3 from INT() function as sign in Y
; for possible later negation, b0
LAB_2AD9
JSR LAB_279D ; save FAC1 sign and copy ABS(FAC2) to FAC1
TYA ; copy sign back ..
PHA ; .. and save it
JSR LAB_LOG ; do LOG(n)
LDA #<garb_l ; set pointer low byte
LDY #>garb_l ; set pointer high byte
JSR LAB_25FB ; do convert AY, FCA1*(AY) (square the value)
JSR LAB_EXP ; go do EXP(n)
PLA ; pull sign from stack
LSR ; b0 is to be tested, shift to Cb
BCC LAB_2AF9 ; if no bit then exit
; Perform negation
; do - FAC1
LAB_GTHAN
LDA FAC1_e ; get FAC1 exponent
BEQ LAB_2AF9 ; exit if FAC1_e = $00
LDA FAC1_s ; get FAC1 sign (b7)
EOR #$FF ; complement it
STA FAC1_s ; save FAC1 sign (b7)
LAB_2AF9
RTS
; perform EXP() (x^e)
LAB_EXP
LDA #<LAB_2AFA ; set 1.443 pointer low byte
LDY #>LAB_2AFA ; set 1.443 pointer high byte
JSR LAB_25FB ; do convert AY, FCA1*(AY)
LDA FAC1_r ; get FAC1 rounding byte
ADC #$50 ; +$50/$100
BCC LAB_2B2B ; skip rounding if no carry
JSR LAB_27C2 ; round FAC1 (no check)
LAB_2B2B
STA FAC2_r ; save FAC2 rounding byte
JSR LAB_27AE ; copy FAC1 to FAC2
LDA FAC1_e ; get FAC1 exponent
CMP #$88 ; compare with EXP limit (256d)
BCC LAB_2B39 ; branch if less
LAB_2B36
JSR LAB_2690 ; handle overflow and underflow
LAB_2B39
JSR LAB_INT ; perform INT
LDA Temp3 ; get mantissa 3 from INT() function
CLC ; clear carry for add
ADC #$81 ; normalise +1
BEQ LAB_2B36 ; if $00 go handle overflow
SEC ; set carry for subtract
SBC #$01 ; now correct for exponent
PHA ; save FAC2 exponent
; swap FAC1 and FAC2
LDX #$04 ; 4 bytes to do
LAB_2B49
LDA FAC2_e,X ; get FAC2,X
LDY FAC1_e,X ; get FAC1,X
STA FAC1_e,X ; save FAC1,X
STY FAC2_e,X ; save FAC2,X
DEX ; decrement count/index
BPL LAB_2B49 ; loop if not all done
LDA FAC2_r ; get FAC2 rounding byte
STA FAC1_r ; save as FAC1 rounding byte
JSR LAB_SUBTRACT ; perform subtraction, FAC2 from FAC1
JSR LAB_GTHAN ; do - FAC1
LDA #<LAB_2AFE ; set counter pointer low byte
LDY #>LAB_2AFE ; set counter pointer high byte
JSR LAB_2B84 ; go do series evaluation
LDA #$00 ; clear A
STA FAC_sc ; clear sign compare (FAC1 EOR FAC2)
PLA ;.get saved FAC2 exponent
JMP LAB_2675 ; test and adjust accumulators and return
; ^2 then series evaluation
LAB_2B6E
STA Cptrl ; save count pointer low byte
STY Cptrh ; save count pointer high byte
JSR LAB_276E ; pack FAC1 into Adatal
LDA #<Adatal ; set pointer low byte (Y already $00)
JSR LAB_25FB ; do convert AY, FCA1*(AY)
JSR LAB_2B88 ; go do series evaluation
LDA #<Adatal ; pointer to original # low byte
LDY #>Adatal ; pointer to original # high byte
JMP LAB_25FB ; do convert AY, FCA1*(AY) and return
; series evaluation
LAB_2B84
STA Cptrl ; save count pointer low byte
STY Cptrh ; save count pointer high byte
LAB_2B88
LDX #<numexp ; set pointer low byte
JSR LAB_2770 ; set pointer high byte and pack FAC1 into numexp
LDA (Cptrl),Y ; get constants count
STA numcon ; save constants count
LDY Cptrl ; get count pointer low byte
INY ; increment it (now constants pointer)
TYA ; copy it
BNE LAB_2B97 ; skip next if no overflow
INC Cptrh ; else increment high byte
LAB_2B97
STA Cptrl ; save low byte
LDY Cptrh ; get high byte
LAB_2B9B
JSR LAB_25FB ; do convert AY, FCA1*(AY)
LDA Cptrl ; get constants pointer low byte
LDY Cptrh ; get constants pointer high byte
CLC ; clear carry for add
ADC #$04 ; +4 to low pointer (4 bytes per constant)
BCC LAB_2BA8 ; skip next if no overflow
INY ; increment high byte
LAB_2BA8
STA Cptrl ; save pointer low byte
STY Cptrh ; save pointer high byte
JSR LAB_246C ; add (AY) to FAC1
LDA #<numexp ; set pointer low byte to partial @ numexp
LDY #>numexp ; set pointer high byte to partial @ numexp
DEC numcon ; decrement constants count
BNE LAB_2B9B ; loop until all done
RTS
; RND(n), 32 bit Galoise version. make n=0 for 19th next number in sequence or n<>0
; to get 19th next number in sequence after seed n. This version of the PRNG uses
; the Galois method and a sample of 65536 bytes produced gives the following values.
; Entropy = 7.997442 bits per byte
; Optimum compression would reduce these 65536 bytes by 0 percent
; Chi square distribution for 65536 samples is 232.01, and
; randomly would exceed this value 75.00 percent of the time
; Arithmetic mean value of data bytes is 127.6724, 127.5 would be random
; Monte Carlo value for Pi is 3.122871269, error 0.60 percent
; Serial correlation coefficient is -0.000370, totally uncorrelated would be 0.0
LAB_RND
LDA FAC1_e ; get FAC1 exponent
BEQ NextPRN ; do next random # if zero
; else get seed into random number store
LDX #Rbyte4 ; set PRNG pointer low byte
LDY #$00 ; set PRNG pointer high byte
JSR LAB_2778 ; pack FAC1 into (XY)
NextPRN
LDX #$AF ; set EOR byte
LDY #$13 ; do this nineteen times
LoopPRN
ASL Rbyte1 ; shift PRNG most significant byte
ROL Rbyte2 ; shift PRNG middle byte
ROL Rbyte3 ; shift PRNG least significant byte
ROL Rbyte4 ; shift PRNG extra byte
BCC Ninc1 ; branch if bit 32 clear
TXA ; set EOR byte
EOR Rbyte1 ; EOR PRNG extra byte
STA Rbyte1 ; save new PRNG extra byte
Ninc1
DEY ; decrement loop count
BNE LoopPRN ; loop if not all done
LDX #$02 ; three bytes to copy
CopyPRNG
LDA Rbyte1,X ; get PRNG byte
STA FAC1_1,X ; save FAC1 byte
DEX
BPL CopyPRNG ; loop if not complete
LDA #$80 ; set the exponent
STA FAC1_e ; save FAC1 exponent
ASL ; clear A
STA FAC1_s ; save FAC1 sign
JMP LAB_24D5 ; normalise FAC1 and return
; perform COS()
LAB_COS
LDA #<LAB_2C78 ; set (pi/2) pointer low byte
LDY #>LAB_2C78 ; set (pi/2) pointer high byte
JSR LAB_246C ; add (AY) to FAC1
; perform SIN()
LAB_SIN
JSR LAB_27AB ; round and copy FAC1 to FAC2
LDA #<LAB_2C7C ; set (2*pi) pointer low byte
LDY #>LAB_2C7C ; set (2*pi) pointer high byte
LDX FAC2_s ; get FAC2 sign (b7)
JSR LAB_26C2 ; divide by (AY) (X=sign)
JSR LAB_27AB ; round and copy FAC1 to FAC2
JSR LAB_INT ; perform INT
LDA #$00 ; clear byte
STA FAC_sc ; clear sign compare (FAC1 EOR FAC2)
JSR LAB_SUBTRACT ; perform subtraction, FAC2 from FAC1
LDA #<LAB_2C80 ; set 0.25 pointer low byte
LDY #>LAB_2C80 ; set 0.25 pointer high byte
JSR LAB_2455 ; perform subtraction, (AY) from FAC1
LDA FAC1_s ; get FAC1 sign (b7)
PHA ; save FAC1 sign
BPL LAB_2C35 ; branch if +ve
; FAC1 sign was -ve
JSR LAB_244E ; add 0.5 to FAC1
LDA FAC1_s ; get FAC1 sign (b7)
BMI LAB_2C38 ; branch if -ve
LDA Cflag ; get comparison evaluation flag
EOR #$FF ; toggle flag
STA Cflag ; save comparison evaluation flag
LAB_2C35
JSR LAB_GTHAN ; do - FAC1
LAB_2C38
LDA #<LAB_2C80 ; set 0.25 pointer low byte
LDY #>LAB_2C80 ; set 0.25 pointer high byte
JSR LAB_246C ; add (AY) to FAC1
PLA ; restore FAC1 sign
BPL LAB_2C45 ; branch if was +ve
; else correct FAC1
JSR LAB_GTHAN ; do - FAC1
LAB_2C45
LDA #<LAB_2C84 ; set pointer low byte to counter
LDY #>LAB_2C84 ; set pointer high byte to counter
JMP LAB_2B6E ; ^2 then series evaluation and return
; perform TAN()
LAB_TAN
JSR LAB_276E ; pack FAC1 into Adatal
LDA #$00 ; clear byte
STA Cflag ; clear comparison evaluation flag
JSR LAB_SIN ; go do SIN(n)
LDX #<func_l ; set sin(n) pointer low byte
LDY #>func_l ; set sin(n) pointer high byte
JSR LAB_2778 ; pack FAC1 into (XY)
LDA #<Adatal ; set n pointer low addr
LDY #>Adatal ; set n pointer high addr
JSR LAB_UFAC ; unpack memory (AY) into FAC1
LDA #$00 ; clear byte
STA FAC1_s ; clear FAC1 sign (b7)
LDA Cflag ; get comparison evaluation flag
JSR LAB_2C74 ; save flag and go do series evaluation
LDA #<func_l ; set sin(n) pointer low byte
LDY #>func_l ; set sin(n) pointer high byte
JMP LAB_26CA ; convert AY and do (AY)/FAC1
LAB_2C74
PHA ; save comparison evaluation flag
JMP LAB_2C35 ; go do series evaluation
; perform USR()
LAB_USR
JSR Usrjmp ; call user code
JMP LAB_1BFB ; scan for ")", else do syntax error then warm start
; perform ATN()
LAB_ATN
LDA FAC1_s ; get FAC1 sign (b7)
PHA ; save sign
BPL LAB_2CA1 ; branch if +ve
JSR LAB_GTHAN ; else do - FAC1
LAB_2CA1
LDA FAC1_e ; get FAC1 exponent
PHA ; push exponent
CMP #$81 ; compare with 1
BCC LAB_2CAF ; branch if FAC1<1
LDA #<LAB_259C ; set 1 pointer low byte
LDY #>LAB_259C ; set 1 pointer high byte
JSR LAB_26CA ; convert AY and do (AY)/FAC1
LAB_2CAF
LDA #<LAB_2CC9 ; set pointer low byte to counter
LDY #>LAB_2CC9 ; set pointer high byte to counter
JSR LAB_2B6E ; ^2 then series evaluation
PLA ; restore old FAC1 exponent
CMP #$81 ; compare with 1
BCC LAB_2CC2 ; branch if FAC1<1
LDA #<LAB_2C78 ; set (pi/2) pointer low byte
LDY #>LAB_2C78 ; set (pi/2) pointer high byte
JSR LAB_2455 ; perform subtraction, (AY) from FAC1
LAB_2CC2
PLA ; restore FAC1 sign
BPL LAB_2D04 ; exit if was +ve
JMP LAB_GTHAN ; else do - FAC1 and return
; perform BITSET
LAB_BITSET
JSR LAB_GADB ; get two parameters for POKE or WAIT
CPX #$08 ; only 0 to 7 are allowed
BCS FCError ; branch if > 7
LDA #$00 ; clear A
SEC ; set the carry
S_Bits
ROL ; shift bit
DEX ; decrement bit number
BPL S_Bits ; loop if still +ve
INX ; make X = $00
ORA (Itempl,X) ; or with byte via temporary integer (addr)
STA (Itempl,X) ; save byte via temporary integer (addr)
LAB_2D04
RTS
; perform BITCLR
LAB_BITCLR
JSR LAB_GADB ; get two parameters for POKE or WAIT
CPX #$08 ; only 0 to 7 are allowed
BCS FCError ; branch if > 7
LDA #$FF ; set A
S_Bitc
ROL ; shift bit
DEX ; decrement bit number
BPL S_Bitc ; loop if still +ve
INX ; make X = $00
AND (Itempl,X) ; and with byte via temporary integer (addr)
STA (Itempl,X) ; save byte via temporary integer (addr)
RTS
FCError
JMP LAB_FCER ; do function call error then warm start
; perform BITTST()
LAB_BTST
JSR LAB_IGBY ; increment BASIC pointer
JSR LAB_GADB ; get two parameters for POKE or WAIT
CPX #$08 ; only 0 to 7 are allowed
BCS FCError ; branch if > 7
JSR LAB_GBYT ; get next BASIC byte
CMP #')' ; is next character ")"
BEQ TST_OK ; if ")" go do rest of function
JMP LAB_SNER ; do syntax error then warm start
TST_OK
JSR LAB_IGBY ; update BASIC execute pointer (to character past ")")
LDA #$00 ; clear A
SEC ; set the carry
T_Bits
ROL ; shift bit
DEX ; decrement bit number
BPL T_Bits ; loop if still +ve
INX ; make X = $00
AND (Itempl,X) ; AND with byte via temporary integer (addr)
BEQ LAB_NOTT ; branch if zero (already correct)
LDA #$FF ; set for -1 result
LAB_NOTT
JMP LAB_27DB ; go do SGN tail
; perform BIN$()
LAB_BINS
CPX #$19 ; max + 1
BCS BinFErr ; exit if too big ( > or = )
STX TempB ; save # of characters ($00 = leading zero remove)
LDA #$18 ; need A byte long space
JSR LAB_MSSP ; make string space A bytes long
LDY #$17 ; set index
LDX #$18 ; character count
NextB1
LSR nums_1 ; shift highest byte
ROR nums_2 ; shift middle byte
ROR nums_3 ; shift lowest byte bit 0 to carry
TXA ; load with "0"/2
ROL ; shift in carry
STA (str_pl),Y ; save to temp string + index
DEY ; decrement index
BPL NextB1 ; loop if not done
LDA TempB ; get # of characters
BEQ EndBHS ; branch if truncate
TAX ; copy length to X
SEC ; set carry for add !
EOR #$FF ; 1's complement
ADC #$18 ; add 24d
BEQ GoPr2 ; if zero print whole string
BNE GoPr1 ; else go make output string
; this is the exit code and is also used by HEX$()
; truncate string to remove leading "0"s
EndBHS
TAY ; clear index (A=0, X=length here)
NextB2
LDA (str_pl),Y ; get character from string
CMP #'0' ; compare with "0"
BNE GoPr ; if not "0" then go print string from here
DEX ; decrement character count
BEQ GoPr3 ; if zero then end of string so go print it
INY ; else increment index
BPL NextB2 ; loop always
; make fixed length output string - ignore overflows!
GoPr3
INX ; need at least 1 character
GoPr
TYA ; copy result
GoPr1
CLC ; clear carry for add
ADC str_pl ; add low address
STA str_pl ; save low address
LDA #$00 ; do high byte
ADC str_ph ; add high address
STA str_ph ; save high address
GoPr2
STX str_ln ; X holds string length
JSR LAB_IGBY ; update BASIC execute pointer (to character past ")")
JMP LAB_RTST ; check for space on descriptor stack then put address
; and length on descriptor stack and update stack pointers
BinFErr
JMP LAB_FCER ; do function call error then warm start
; perform HEX$()
LAB_HEXS
CPX #$07 ; max + 1
BCS BinFErr ; exit if too big ( > or = )
STX TempB ; save # of characters
LDA #$06 ; need 6 bytes for string
JSR LAB_MSSP ; make string space A bytes long
LDY #$05 ; set string index
SED ; need decimal mode for nibble convert
LDA nums_3 ; get lowest byte
JSR LAB_A2HX ; convert A to ASCII hex byte and output
LDA nums_2 ; get middle byte
JSR LAB_A2HX ; convert A to ASCII hex byte and output
LDA nums_1 ; get highest byte
JSR LAB_A2HX ; convert A to ASCII hex byte and output
CLD ; back to binary
LDX #$06 ; character count
LDA TempB ; get # of characters
BEQ EndBHS ; branch if truncate
TAX ; copy length to X
SEC ; set carry for add !
EOR #$FF ; 1's complement
ADC #$06 ; add 6d
BEQ GoPr2 ; if zero print whole string
BNE GoPr1 ; else go make output string (branch always)
; convert A to ASCII hex byte and output .. note set decimal mode before calling
LAB_A2HX
TAX ; save byte
AND #$0F ; mask off top bits
JSR LAB_AL2X ; convert low nibble to ASCII and output
TXA ; get byte back
LSR ; /2 shift high nibble to low nibble
LSR ; /4
LSR ; /8
LSR ; /16
LAB_AL2X
CMP #$0A ; set carry for +1 if >9
ADC #'0' ; add ASCII "0"
STA (str_pl),Y ; save to temp string
DEY ; decrement counter
RTS
LAB_NLTO
STA FAC1_e ; save FAC1 exponent
LDA #$00 ; clear sign compare
LAB_MLTE
STA FAC_sc ; save sign compare (FAC1 EOR FAC2)
TXA ; restore character
JSR LAB_2912 ; evaluate new ASCII digit
; gets here if the first character was "$" for hex
; get hex number
LAB_CHEX
JSR LAB_IGBY ; increment and scan memory
BCC LAB_ISHN ; branch if numeric character
ORA #$20 ; case convert, allow "A" to "F" and "a" to "f"
SBC #'a' ; subtract "a" (carry set here)
CMP #$06 ; compare normalised with $06 (max+1)
BCS LAB_EXCH ; exit if >"f" or <"0"
ADC #$0A ; convert to nibble
LAB_ISHN
AND #$0F ; convert to binary
TAX ; save nibble
LDA FAC1_e ; get FAC1 exponent
BEQ LAB_MLTE ; skip multiply if zero
ADC #$04 ; add four to exponent (*16 - carry clear here)
BCC LAB_NLTO ; if no overflow do evaluate digit
LAB_MLTO
JMP LAB_2564 ; do overflow error and warm start
LAB_NXCH
TAX ; save bit
LDA FAC1_e ; get FAC1 exponent
BEQ LAB_MLBT ; skip multiply if zero
INC FAC1_e ; increment FAC1 exponent (*2)
BEQ LAB_MLTO ; do overflow error if = $00
LDA #$00 ; clear sign compare
LAB_MLBT
STA FAC_sc ; save sign compare (FAC1 EOR FAC2)
TXA ; restore bit
JSR LAB_2912 ; evaluate new ASCII digit
; gets here if the first character was "%" for binary
; get binary number
LAB_CBIN
JSR LAB_IGBY ; increment and scan memory
EOR #'0' ; convert "0" to 0 etc.
CMP #$02 ; compare with max+1
BCC LAB_NXCH ; branch exit if < 2
LAB_EXCH
JMP LAB_28F6 ; evaluate -ve flag and return
; ctrl-c check routine. includes limited "life" byte save for INGET routine
; now also the code that checks to see if an interrupt has occurred
CTRLC
LDA ccflag ; get [CTRL-C] check flag
BNE LAB_FBA2 ; exit if inhibited
JSR V_INPT ; scan input device
BCC LAB_FBA0 ; exit if buffer empty
STA ccbyte ; save received byte
LDX #$20 ; "life" timer for bytes
STX ccnull ; set countdown
JMP LAB_1636 ; return to BASIC
LAB_FBA0
LDX ccnull ; get countdown byte
BEQ LAB_FBA2 ; exit if finished
DEC ccnull ; else decrement countdown
LAB_FBA2
LDX #NmiBase ; set pointer to NMI values
JSR LAB_CKIN ; go check interrupt
LDX #IrqBase ; set pointer to IRQ values
JSR LAB_CKIN ; go check interrupt
LAB_CRTS
RTS
; check whichever interrupt is indexed by X
LAB_CKIN
LDA PLUS_0,X ; get interrupt flag byte
BPL LAB_CRTS ; branch if interrupt not enabled
; we disable the interrupt here and make two new commands RETIRQ and RETNMI to
; automatically enable the interrupt when we exit
ASL ; move happened bit to setup bit
AND #$40 ; mask happened bits
BEQ LAB_CRTS ; if no interrupt then exit
STA PLUS_0,X ; save interrupt flag byte
TXA ; copy index ..
TAY ; .. to Y
PLA ; dump return address low byte, call from CTRL-C
PLA ; dump return address high byte
LDA #$05 ; need 5 bytes for GOSUB
JSR LAB_1212 ; check room on stack for A bytes
LDA Bpntrh ; get BASIC execute pointer high byte
PHA ; push on stack
LDA Bpntrl ; get BASIC execute pointer low byte
PHA ; push on stack
LDA Clineh ; get current line high byte
PHA ; push on stack
LDA Clinel ; get current line low byte
PHA ; push on stack
LDA #TK_GOSUB ; token for GOSUB
PHA ; push on stack
LDA PLUS_1,Y ; get interrupt code pointer low byte
STA Bpntrl ; save as BASIC execute pointer low byte
LDA PLUS_2,Y ; get interrupt code pointer high byte
STA Bpntrh ; save as BASIC execute pointer high byte
JMP LAB_15C2 ; go do interpreter inner loop
; can't RTS, we used the stack! the RTS from the ctrl-c
; check will be taken when the RETIRQ/RETNMI/RETURN is
; executed at the end of the subroutine
; get byte from input device, no waiting
; returns with carry set if byte in A
INGET
JSR V_INPT ; call scan input device
BCS LAB_FB95 ; if byte go reset timer
LDA ccnull ; get countdown
BEQ LAB_FB96 ; exit if empty
LDA ccbyte ; get last received byte
SEC ; flag we got a byte
LAB_FB95
LDX #$00 ; clear X
STX ccnull ; clear timer because we got a byte
LAB_FB96
RTS
; these routines only enable the interrupts if the set-up flag is set
; if not they have no effect
; perform IRQ {ON|OFF|CLEAR}
LAB_IRQ
LDX #IrqBase ; set pointer to IRQ values
.byte $2C ; make next line BIT abs.
; perform NMI {ON|OFF|CLEAR}
LAB_NMI
LDX #NmiBase ; set pointer to NMI values
CMP #TK_ON ; compare with token for ON
BEQ LAB_INON ; go turn on interrupt
CMP #TK_OFF ; compare with token for OFF
BEQ LAB_IOFF ; go turn off interrupt
EOR #TK_CLEAR ; compare with token for CLEAR, A = $00 if = TK_CLEAR
BEQ LAB_INEX ; go clear interrupt flags and return
JMP LAB_SNER ; do syntax error then warm start
LAB_IOFF
LDA #$7F ; clear A
AND PLUS_0,X ; AND with interrupt setup flag
BPL LAB_INEX ; go clear interrupt enabled flag and return
LAB_INON
LDA PLUS_0,X ; get interrupt setup flag
ASL ; Shift bit to enabled flag
ORA PLUS_0,X ; OR with flag byte
LAB_INEX
STA PLUS_0,X ; save interrupt flag byte
JMP LAB_IGBY ; update BASIC execute pointer and return
; these routines set up the pointers and flags for the interrupt routines
; note that the interrupts are also enabled by these commands
; perform ON IRQ
LAB_SIRQ
CLI ; enable interrupts
LDX #IrqBase ; set pointer to IRQ values
.byte $2C ; make next line BIT abs.
; perform ON NMI
LAB_SNMI
LDX #NmiBase ; set pointer to NMI values
STX TempB ; save interrupt pointer
JSR LAB_IGBY ; increment and scan memory (past token)
JSR LAB_GFPN ; get fixed-point number into temp integer
LDA Smeml ; get start of mem low byte
LDX Smemh ; get start of mem high byte
JSR LAB_SHLN ; search Basic for temp integer line number from AX
BCS LAB_LFND ; if carry set go set-up interrupt
JMP LAB_16F7 ; else go do "Undefined statement" error and warm start
LAB_LFND
LDX TempB ; get interrupt pointer
LDA Baslnl ; get pointer low byte
SBC #$01 ; -1 (carry already set for subtract)
STA PLUS_1,X ; save as interrupt pointer low byte
LDA Baslnh ; get pointer high byte
SBC #$00 ; subtract carry
STA PLUS_2,X ; save as interrupt pointer high byte
LDA #$C0 ; set interrupt enabled/setup bits
STA PLUS_0,X ; set interrupt flags
LAB_IRTS
RTS
; return from IRQ service, restores the enabled flag.
; perform RETIRQ
LAB_RETIRQ
BNE LAB_IRTS ; exit if following token (to allow syntax error)
LDA IrqBase ; get interrupt flags
ASL ; copy setup to enabled (b7)
ORA IrqBase ; OR in setup flag
STA IrqBase ; save enabled flag
JMP LAB_16E8 ; go do rest of RETURN
; return from NMI service, restores the enabled flag.
; perform RETNMI
LAB_RETNMI
BNE LAB_IRTS ; exit if following token (to allow syntax error)
LDA NmiBase ; get set-up flag
ASL ; copy setup to enabled (b7)
ORA NmiBase ; OR in setup flag
STA NmiBase ; save enabled flag
JMP LAB_16E8 ; go do rest of RETURN
; MAX() MIN() pre process
LAB_MMPP
JSR LAB_EVEZ ; process expression
JMP LAB_CTNM ; check if source is numeric, else do type mismatch
; perform MAX()
LAB_MAX
JSR LAB_PHFA ; push FAC1, evaluate expression,
; pull FAC2 and compare with FAC1
BPL LAB_MAX ; branch if no swap to do
LDA FAC2_1 ; get FAC2 mantissa1
ORA #$80 ; set top bit (clear sign from compare)
STA FAC2_1 ; save FAC2 mantissa1
JSR LAB_279B ; copy FAC2 to FAC1
BEQ LAB_MAX ; go do next (branch always)
; perform MIN()
LAB_MIN
JSR LAB_PHFA ; push FAC1, evaluate expression,
; pull FAC2 and compare with FAC1
BMI LAB_MIN ; branch if no swap to do
BEQ LAB_MIN ; branch if no swap to do
LDA FAC2_1 ; get FAC2 mantissa1
ORA #$80 ; set top bit (clear sign from compare)
STA FAC2_1 ; save FAC2 mantissa1
JSR LAB_279B ; copy FAC2 to FAC1
BEQ LAB_MIN ; go do next (branch always)
; exit routine. don't bother returning to the loop code
; check for correct exit, else so syntax error
LAB_MMEC
CMP #')' ; is it end of function?
BNE LAB_MMSE ; if not do MAX MIN syntax error
PLA ; dump return address low byte
PLA ; dump return address high byte
JMP LAB_IGBY ; update BASIC execute pointer (to chr past ")")
LAB_MMSE
JMP LAB_SNER ; do syntax error then warm start
; check for next, evaluate and return or exit
; this is the routine that does most of the work
LAB_PHFA
JSR LAB_GBYT ; get next BASIC byte
CMP #',' ; is there more ?
BNE LAB_MMEC ; if not go do end check
; push FAC1
JSR LAB_27BA ; round FAC1
LDA FAC1_s ; get FAC1 sign
ORA #$7F ; set all non sign bits
AND FAC1_1 ; AND FAC1 mantissa1 (AND in sign bit)
PHA ; push on stack
LDA FAC1_2 ; get FAC1 mantissa2
PHA ; push on stack
LDA FAC1_3 ; get FAC1 mantissa3
PHA ; push on stack
LDA FAC1_e ; get FAC1 exponent
PHA ; push on stack
JSR LAB_IGBY ; scan and get next BASIC byte (after ",")
JSR LAB_EVNM ; evaluate expression and check is numeric,
; else do type mismatch
; pop FAC2 (MAX/MIN expression so far)
PLA ; pop exponent
STA FAC2_e ; save FAC2 exponent
PLA ; pop mantissa3
STA FAC2_3 ; save FAC2 mantissa3
PLA ; pop mantissa1
STA FAC2_2 ; save FAC2 mantissa2
PLA ; pop sign/mantissa1
STA FAC2_1 ; save FAC2 sign/mantissa1
STA FAC2_s ; save FAC2 sign
; compare FAC1 with (packed) FAC2
LDA #<FAC2_e ; set pointer low byte to FAC2
LDY #>FAC2_e ; set pointer high byte to FAC2
JMP LAB_27F8 ; compare FAC1 with FAC2 (AY) and return
; returns A=$00 if FAC1 = (AY)
; returns A=$01 if FAC1 > (AY)
; returns A=$FF if FAC1 < (AY)
; perform WIDTH
LAB_WDTH
CMP #',' ; is next byte ","
BEQ LAB_TBSZ ; if so do tab size
JSR LAB_GTBY ; get byte parameter
TXA ; copy width to A
BEQ LAB_NSTT ; branch if set for infinite line
CPX #$10 ; else make min width = 16d
BCC TabErr ; if less do function call error and exit
; this next compare ensures that we can't exit WIDTH via an error leaving the
; tab size greater than the line length.
CPX TabSiz ; compare with tab size
BCS LAB_NSTT ; branch if >= tab size
STX TabSiz ; else make tab size = terminal width
LAB_NSTT
STX TWidth ; set the terminal width
JSR LAB_GBYT ; get BASIC byte back
BEQ WExit ; exit if no following
CMP #',' ; else is it ","
BNE LAB_MMSE ; if not do syntax error
LAB_TBSZ
JSR LAB_SGBY ; scan and get byte parameter
TXA ; copy TAB size
BMI TabErr ; if >127 do function call error and exit
CPX #$01 ; compare with min-1
BCC TabErr ; if <=1 do function call error and exit
LDA TWidth ; set flags for width
BEQ LAB_SVTB ; skip check if infinite line
CPX TWidth ; compare TAB with width
BEQ LAB_SVTB ; ok if =
BCS TabErr ; branch if too big
LAB_SVTB
STX TabSiz ; save TAB size
; calculate tab column limit from TAB size. The Iclim is set to the last tab
; position on a line that still has at least one whole tab width between it
; and the end of the line.
WExit
LDA TWidth ; get width
BEQ LAB_SULP ; branch if infinite line
CMP TabSiz ; compare with tab size
BCS LAB_WDLP ; branch if >= tab size
STA TabSiz ; else make tab size = terminal width
LAB_SULP
SEC ; set carry for subtract
LAB_WDLP
SBC TabSiz ; subtract tab size
BCS LAB_WDLP ; loop while no borrow
ADC TabSiz ; add tab size back
CLC ; clear carry for add
ADC TabSiz ; add tab size back again
STA Iclim ; save for now
LDA TWidth ; get width back
SEC ; set carry for subtract
SBC Iclim ; subtract remainder
STA Iclim ; save tab column limit
LAB_NOSQ
RTS
TabErr
JMP LAB_FCER ; do function call error then warm start
; perform SQR()
LAB_SQR
LDA FAC1_s ; get FAC1 sign
BMI TabErr ; if -ve do function call error
LDA FAC1_e ; get exponent
BEQ LAB_NOSQ ; if zero just return
; else do root
JSR LAB_27AB ; round and copy FAC1 to FAC2
LDA #$00 ; clear A
STA FACt_3 ; clear remainder
STA FACt_2 ; ..
STA FACt_1 ; ..
STA TempB ; ..
STA FAC1_3 ; clear root
STA FAC1_2 ; ..
STA FAC1_1 ; ..
LDX #$18 ; 24 pairs of bits to do
LDA FAC2_e ; get exponent
LSR ; check odd/even
BCS LAB_SQE2 ; if odd only 1 shift first time
LAB_SQE1
ASL FAC2_3 ; shift highest bit of number ..
ROL FAC2_2 ; ..
ROL FAC2_1 ; ..
ROL FACt_3 ; .. into remainder
ROL FACt_2 ; ..
ROL FACt_1 ; ..
ROL TempB ; .. never overflows
LAB_SQE2
ASL FAC2_3 ; shift highest bit of number ..
ROL FAC2_2 ; ..
ROL FAC2_1 ; ..
ROL FACt_3 ; .. into remainder
ROL FACt_2 ; ..
ROL FACt_1 ; ..
ROL TempB ; .. never overflows
ASL FAC1_3 ; root = root * 2
ROL FAC1_2 ; ..
ROL FAC1_1 ; .. never overflows
LDA FAC1_3 ; get root low byte
ROL ; *2
STA Temp3 ; save partial low byte
LDA FAC1_2 ; get root low mid byte
ROL ; *2
STA Temp3+1 ; save partial low mid byte
LDA FAC1_1 ; get root high mid byte
ROL ; *2
STA Temp3+2 ; save partial high mid byte
LDA #$00 ; get root high byte (always $00)
ROL ; *2
STA Temp3+3 ; save partial high byte
; carry clear for subtract +1
LDA FACt_3 ; get remainder low byte
SBC Temp3 ; subtract partial low byte
STA Temp3 ; save partial low byte
LDA FACt_2 ; get remainder low mid byte
SBC Temp3+1 ; subtract partial low mid byte
STA Temp3+1 ; save partial low mid byte
LDA FACt_1 ; get remainder high mid byte
SBC Temp3+2 ; subtract partial high mid byte
TAY ; copy partial high mid byte
LDA TempB ; get remainder high byte
SBC Temp3+3 ; subtract partial high byte
BCC LAB_SQNS ; skip sub if remainder smaller
STA TempB ; save remainder high byte
STY FACt_1 ; save remainder high mid byte
LDA Temp3+1 ; get remainder low mid byte
STA FACt_2 ; save remainder low mid byte
LDA Temp3 ; get partial low byte
STA FACt_3 ; save remainder low byte
INC FAC1_3 ; increment root low byte (never any rollover)
LAB_SQNS
DEX ; decrement bit pair count
BNE LAB_SQE1 ; loop if not all done
SEC ; set carry for subtract
LDA FAC2_e ; get exponent
SBC #$80 ; normalise
ROR ; /2 and re-bias to $80
ADC #$00 ; add bit zero back in (allow for half shift)
STA FAC1_e ; save it
JMP LAB_24D5 ; normalise FAC1 and return
; perform VARPTR()
LAB_VARPTR
JSR LAB_IGBY ; increment and scan memory
JSR LAB_GVAR ; get var address
JSR LAB_1BFB ; scan for ")" , else do syntax error then warm start
LDY Cvaral ; get var address low byte
LDA Cvarah ; get var address high byte
JMP LAB_AYFC ; save and convert integer AY to FAC1 and return
; perform PI
LAB_PI
LDA #<LAB_2C7C ; set (2*pi) pointer low byte
LDY #>LAB_2C7C ; set (2*pi) pointer high byte
JSR LAB_UFAC ; unpack memory (AY) into FAC1
DEC FAC1_e ; make result = PI
RTS
; perform TWOPI
LAB_TWOPI
LDA #<LAB_2C7C ; set (2*pi) pointer low byte
LDY #>LAB_2C7C ; set (2*pi) pointer high byte
JMP LAB_UFAC ; unpack memory (AY) into FAC1 and return
; system dependant i/o vectors
; these are in RAM and are set by the monitor at start-up
V_INPT
JMP (VEC_IN) ; non halting scan input device
V_OUTP
JMP (VEC_OUT) ; send byte to output device
V_LOAD
JMP (VEC_LD) ; load BASIC program
V_SAVE
JMP (VEC_SV) ; save BASIC program
; The rest are tables messages and code for RAM
; the rest of the code is tables and BASIC start-up code
PG2_TABS
.byte $00 ; ctrl-c flag - $00 = enabled
.byte $00 ; ctrl-c byte - GET needs this
.byte $00 ; ctrl-c byte timeout - GET needs this
.word CTRLC ; ctrl c check vector
; .word xxxx ; non halting key input - monitor to set this
; .word xxxx ; output vector - monitor to set this
; .word xxxx ; load vector - monitor to set this
; .word xxxx ; save vector - monitor to set this
PG2_TABE
; character get subroutine for zero page
; For a 1.8432MHz 6502 including the JSR and RTS
; fastest (>=":") = 29 cycles = 15.7uS
; slowest (<":") = 40 cycles = 21.7uS
; space skip = +21 cycles = +11.4uS
; inc across page = +4 cycles = +2.2uS
; the target address for the LDA at LAB_2CF4 becomes the BASIC execute pointer once the
; block is copied to it's destination, any non zero page address will do at assembly
; time, to assemble a three byte instruction.
; page 0 initialisation table from $BC
; increment and scan memory
LAB_2CEE
INC Bpntrl ; increment BASIC execute pointer low byte
BNE LAB_2CF4 ; branch if no carry
; else
INC Bpntrh ; increment BASIC execute pointer high byte
; page 0 initialisation table from $C2
; scan memory
LAB_2CF4
LDA $FFFF ; get byte to scan (addr set by call routine)
CMP #TK_ELSE ; compare with the token for ELSE
BEQ LAB_2D05 ; exit if ELSE, not numeric, carry set
CMP #':' ; compare with ":"
BCS LAB_2D05 ; exit if >= ":", not numeric, carry set
CMP #' ' ; compare with " "
BEQ LAB_2CEE ; if " " go do next
SEC ; set carry for SBC
SBC #'0' ; subtract "0"
SEC ; set carry for SBC
SBC #$D0 ; subtract -"0"
; clear carry if byte = "0"-"9"
LAB_2D05
RTS
; page zero initialisation table $00-$12 inclusive
StrTab
.byte $4C ; JMP opcode
.word LAB_COLD ; initial warm start vector (cold start)
.byte $00 ; these bytes are not used by BASIC
.word $0000 ;
.word $0000 ;
.word $0000 ;
.byte $4C ; JMP opcode
.word LAB_FCER ; initial user function vector ("Function call" error)
.byte $00 ; default NULL count
.byte $00 ; clear terminal position
.byte $00 ; default terminal width byte
.byte $F2 ; default limit for TAB = 14
.word Ram_base ; start of user RAM
EndTab
LAB_MSZM
.byte $0D,$0A,"Memory size ",$00
LAB_SMSG
.byte " Bytes free",$0D,$0A,$0A
.byte "Enhanced BASIC 2.22",$0A,$00
; numeric constants and series
; constants and series for LOG(n)
LAB_25A0
.byte $02 ; counter
.byte $80,$19,$56,$62 ; 0.59898
.byte $80,$76,$22,$F3 ; 0.96147
;## .byte $80,$76,$22,$F1 ; 0.96147
.byte $82,$38,$AA,$40 ; 2.88539
;## .byte $82,$38,$AA,$45 ; 2.88539
LAB_25AD
.byte $80,$35,$04,$F3 ; 0.70711 1/root 2
LAB_25B1
.byte $81,$35,$04,$F3 ; 1.41421 root 2
LAB_25B5
.byte $80,$80,$00,$00 ; -0.5
LAB_25B9
.byte $80,$31,$72,$18 ; 0.69315 LOG(2)
; numeric PRINT constants
LAB_2947
.byte $91,$43,$4F,$F8 ; 99999.9375 (max value with at least one decimal)
LAB_294B
.byte $94,$74,$23,$F7 ; 999999.4375 (max value before scientific notation)
LAB_294F
.byte $94,$74,$24,$00 ; 1000000
; EXP(n) constants and series
LAB_2AFA
.byte $81,$38,$AA,$3B ; 1.4427 (1/LOG base 2 e)
LAB_2AFE
.byte $06 ; counter
.byte $74,$63,$90,$8C ; 2.17023e-4
.byte $77,$23,$0C,$AB ; 0.00124
.byte $7A,$1E,$94,$00 ; 0.00968
.byte $7C,$63,$42,$80 ; 0.05548
.byte $7E,$75,$FE,$D0 ; 0.24023
.byte $80,$31,$72,$15 ; 0.69315
.byte $81,$00,$00,$00 ; 1.00000
;## .byte $07 ; counter
;## .byte $74,$94,$2E,$40 ; -1/7! (-1/5040)
;## .byte $77,$2E,$4F,$70 ; 1/6! ( 1/720)
;## .byte $7A,$88,$02,$6E ; -1/5! (-1/120)
;## .byte $7C,$2A,$A0,$E6 ; 1/4! ( 1/24)
;## .byte $7E,$AA,$AA,$50 ; -1/3! (-1/6)
;## .byte $7F,$7F,$FF,$FF ; 1/2! ( 1/2)
;## .byte $81,$80,$00,$00 ; -1/1! (-1/1)
;## .byte $81,$00,$00,$00 ; 1/0! ( 1/1)
; trigonometric constants and series
LAB_2C78
.byte $81,$49,$0F,$DB ; 1.570796371 (pi/2) as floating #
LAB_2C84
.byte $04 ; counter
.byte $86,$1E,$D7,$FB ; 39.7109
;## .byte $86,$1E,$D7,$BA ; 39.7109
.byte $87,$99,$26,$65 ;-76.575
;## .byte $87,$99,$26,$64 ;-76.575
.byte $87,$23,$34,$58 ; 81.6022
.byte $86,$A5,$5D,$E1 ;-41.3417
;## .byte $86,$A5,$5D,$E0 ;-41.3417
LAB_2C7C
.byte $83,$49,$0F,$DB ; 6.28319 (2*pi) as floating #
;## .byte $83,$49,$0F,$DA ; 6.28319 (2*pi) as floating #
LAB_2CC9
.byte $08 ; counter
.byte $78,$3A,$C5,$37 ; 0.00285
.byte $7B,$83,$A2,$5C ;-0.0160686
.byte $7C,$2E,$DD,$4D ; 0.0426915
.byte $7D,$99,$B0,$1E ;-0.0750429
.byte $7D,$59,$ED,$24 ; 0.106409
.byte $7E,$91,$72,$00 ;-0.142036
.byte $7E,$4C,$B9,$73 ; 0.199926
.byte $7F,$AA,$AA,$53 ;-0.333331
;## .byte $08 ; counter
;## .byte $78,$3B,$D7,$4A ; 1/17
;## .byte $7B,$84,$6E,$02 ;-1/15
;## .byte $7C,$2F,$C1,$FE ; 1/13
;## .byte $7D,$9A,$31,$74 ;-1/11
;## .byte $7D,$5A,$3D,$84 ; 1/9
;## .byte $7E,$91,$7F,$C8 ;-1/7
;## .byte $7E,$4C,$BB,$E4 ; 1/5
;## .byte $7F,$AA,$AA,$6C ;-1/3
LAB_1D96 = *+1 ; $00,$00 used for undefined variables
LAB_259C
.byte $81,$00,$00,$00 ; 1.000000, used for INC
LAB_2AFD
.byte $81,$80,$00,$00 ; -1.00000, used for DEC. must be on the same page as +1.00
; misc constants
LAB_1DF7
.byte $90 ;-32768 (uses first three bytes from 0.5)
LAB_2A96
.byte $80,$00,$00,$00 ; 0.5
LAB_2C80
.byte $7F,$00,$00,$00 ; 0.25
LAB_26B5
.byte $84,$20,$00,$00 ; 10.0000 divide by 10 constant
; This table is used in converting numbers to ASCII.
LAB_2A9A
LAB_2A9B = LAB_2A9A+1
LAB_2A9C = LAB_2A9B+1
.byte $FE,$79,$60 ; -100000
.byte $00,$27,$10 ; 10000
.byte $FF,$FC,$18 ; -1000
.byte $00,$00,$64 ; 100
.byte $FF,$FF,$F6 ; -10
.byte $00,$00,$01 ; 1
LAB_CTBL
.word LAB_END-1 ; END
.word LAB_FOR-1 ; FOR
.word LAB_NEXT-1 ; NEXT
.word LAB_DATA-1 ; DATA
.word LAB_INPUT-1 ; INPUT
.word LAB_DIM-1 ; DIM
.word LAB_READ-1 ; READ
.word LAB_LET-1 ; LET
.word LAB_DEC-1 ; DEC new command
.word LAB_GOTO-1 ; GOTO
.word LAB_RUN-1 ; RUN
.word LAB_IF-1 ; IF
.word LAB_RESTORE-1 ; RESTORE modified command
.word LAB_GOSUB-1 ; GOSUB
.word LAB_RETIRQ-1 ; RETIRQ new command
.word LAB_RETNMI-1 ; RETNMI new command
.word LAB_RETURN-1 ; RETURN
.word LAB_REM-1 ; REM
.word LAB_STOP-1 ; STOP
.word LAB_ON-1 ; ON modified command
.word LAB_NULL-1 ; NULL modified command
.word LAB_INC-1 ; INC new command
.word LAB_WAIT-1 ; WAIT
.word V_LOAD-1 ; LOAD
.word V_SAVE-1 ; SAVE
.word LAB_DEF-1 ; DEF
.word LAB_POKE-1 ; POKE
.word LAB_DOKE-1 ; DOKE new command
.word LAB_CALL-1 ; CALL new command
.word LAB_DO-1 ; DO new command
.word LAB_LOOP-1 ; LOOP new command
.word LAB_PRINT-1 ; PRINT
.word LAB_CONT-1 ; CONT
.word LAB_LIST-1 ; LIST
.word LAB_CLEAR-1 ; CLEAR
.word LAB_NEW-1 ; NEW
.word LAB_WDTH-1 ; WIDTH new command
.word LAB_GET-1 ; GET new command
.word LAB_SWAP-1 ; SWAP new command
.word LAB_BITSET-1 ; BITSET new command
.word LAB_BITCLR-1 ; BITCLR new command
.word LAB_IRQ-1 ; IRQ new command
.word LAB_NMI-1 ; NMI new command
; function pre process routine table
LAB_FTPL
LAB_FTPM = LAB_FTPL+$01
.word LAB_PPFN-1 ; SGN(n) process numeric expression in ()
.word LAB_PPFN-1 ; INT(n) "
.word LAB_PPFN-1 ; ABS(n) "
.word LAB_EVEZ-1 ; USR(x) process any expression
.word LAB_1BF7-1 ; FRE(x) "
.word LAB_1BF7-1 ; POS(x) "
.word LAB_PPFN-1 ; SQR(n) process numeric expression in ()
.word LAB_PPFN-1 ; RND(n) "
.word LAB_PPFN-1 ; LOG(n) "
.word LAB_PPFN-1 ; EXP(n) "
.word LAB_PPFN-1 ; COS(n) "
.word LAB_PPFN-1 ; SIN(n) "
.word LAB_PPFN-1 ; TAN(n) "
.word LAB_PPFN-1 ; ATN(n) "
.word LAB_PPFN-1 ; PEEK(n) "
.word LAB_PPFN-1 ; DEEK(n) "
.word $0000 ; SADD() none
.word LAB_PPFS-1 ; LEN($) process string expression in ()
.word LAB_PPFN-1 ; STR$(n) process numeric expression in ()
.word LAB_PPFS-1 ; VAL($) process string expression in ()
.word LAB_PPFS-1 ; ASC($) "
.word LAB_PPFS-1 ; UCASE$($) "
.word LAB_PPFS-1 ; LCASE$($) "
.word LAB_PPFN-1 ; CHR$(n) process numeric expression in ()
.word LAB_BHSS-1 ; HEX$(n) "
.word LAB_BHSS-1 ; BIN$(n) "
.word $0000 ; BITTST() none
.word LAB_MMPP-1 ; MAX() process numeric expression
.word LAB_MMPP-1 ; MIN() "
.word LAB_PPBI-1 ; PI advance pointer
.word LAB_PPBI-1 ; TWOPI "
.word $0000 ; VARPTR() none
.word LAB_LRMS-1 ; LEFT$() process string expression
.word LAB_LRMS-1 ; RIGHT$() "
.word LAB_LRMS-1 ; MID$() "
; action addresses for functions
LAB_FTBL
LAB_FTBM = LAB_FTBL+$01
.word LAB_SGN-1 ; SGN()
.word LAB_INT-1 ; INT()
.word LAB_ABS-1 ; ABS()
.word LAB_USR-1 ; USR()
.word LAB_FRE-1 ; FRE()
.word LAB_POS-1 ; POS()
.word LAB_SQR-1 ; SQR()
.word LAB_RND-1 ; RND() modified function
.word LAB_LOG-1 ; LOG()
.word LAB_EXP-1 ; EXP()
.word LAB_COS-1 ; COS()
.word LAB_SIN-1 ; SIN()
.word LAB_TAN-1 ; TAN()
.word LAB_ATN-1 ; ATN()
.word LAB_PEEK-1 ; PEEK()
.word LAB_DEEK-1 ; DEEK() new function
.word LAB_SADD-1 ; SADD() new function
.word LAB_LENS-1 ; LEN()
.word LAB_STRS-1 ; STR$()
.word LAB_VAL-1 ; VAL()
.word LAB_ASC-1 ; ASC()
.word LAB_UCASE-1 ; UCASE$() new function
.word LAB_LCASE-1 ; LCASE$() new function
.word LAB_CHRS-1 ; CHR$()
.word LAB_HEXS-1 ; HEX$() new function
.word LAB_BINS-1 ; BIN$() new function
.word LAB_BTST-1 ; BITTST() new function
.word LAB_MAX-1 ; MAX() new function
.word LAB_MIN-1 ; MIN() new function
.word LAB_PI-1 ; PI new function
.word LAB_TWOPI-1 ; TWOPI new function
.word LAB_VARPTR-1 ; VARPTR() new function
.word LAB_LEFT-1 ; LEFT$()
.word LAB_RIGHT-1 ; RIGHT$()
.word LAB_MIDS-1 ; MID$()
; hierarchy and action addresses for operator
LAB_OPPT
.byte $79 ; +
.word LAB_ADD-1
.byte $79 ; -
.word LAB_SUBTRACT-1
.byte $7B ; *
.word LAB_MULTIPLY-1
.byte $7B ; /
.word LAB_DIVIDE-1
.byte $7F ; ^
.word LAB_POWER-1
.byte $50 ; AND
.word LAB_AND-1
.byte $46 ; EOR new operator
.word LAB_EOR-1
.byte $46 ; OR
.word LAB_OR-1
.byte $56 ; >> new operator
.word LAB_RSHIFT-1
.byte $56 ; << new operator
.word LAB_LSHIFT-1
.byte $7D ; >
.word LAB_GTHAN-1
.byte $5A ; =
.word LAB_EQUAL-1
.byte $64 ; <
.word LAB_LTHAN-1
; keywords start with ..
; this is the first character table and must be in alphabetic order
TAB_1STC
.byte "*"
.byte "+"
.byte "-"
.byte "/"
.byte "<"
.byte "="
.byte ">"
.byte "?"
.byte "A"
.byte "B"
.byte "C"
.byte "D"
.byte "E"
.byte "F"
.byte "G"
.byte "H"
.byte "I"
.byte "L"
.byte "M"
.byte "N"
.byte "O"
.byte "P"
.byte "R"
.byte "S"
.byte "T"
.byte "U"
.byte "V"
.byte "W"
.byte "^"
.byte $00 ; table terminator
; pointers to keyword tables
TAB_CHRT
.word TAB_STAR ; table for "*"
.word TAB_PLUS ; table for "+"
.word TAB_MNUS ; table for "-"
.word TAB_SLAS ; table for "/"
.word TAB_LESS ; table for "<"
.word TAB_EQUL ; table for "="
.word TAB_MORE ; table for ">"
.word TAB_QEST ; table for "?"
.word TAB_ASCA ; table for "A"
.word TAB_ASCB ; table for "B"
.word TAB_ASCC ; table for "C"
.word TAB_ASCD ; table for "D"
.word TAB_ASCE ; table for "E"
.word TAB_ASCF ; table for "F"
.word TAB_ASCG ; table for "G"
.word TAB_ASCH ; table for "H"
.word TAB_ASCI ; table for "I"
.word TAB_ASCL ; table for "L"
.word TAB_ASCM ; table for "M"
.word TAB_ASCN ; table for "N"
.word TAB_ASCO ; table for "O"
.word TAB_ASCP ; table for "P"
.word TAB_ASCR ; table for "R"
.word TAB_ASCS ; table for "S"
.word TAB_ASCT ; table for "T"
.word TAB_ASCU ; table for "U"
.word TAB_ASCV ; table for "V"
.word TAB_ASCW ; table for "W"
.word TAB_POWR ; table for "^"
; tables for each start character, note if a longer keyword with the same start
; letters as a shorter one exists then it must come first, else the list is in
; alphabetical order as follows ..
; [keyword,token
; [keyword,token]]
; end marker (#$00)
TAB_STAR
.byte TK_MUL,$00 ; *
TAB_PLUS
.byte TK_PLUS,$00 ; +
TAB_MNUS
.byte TK_MINUS,$00 ; -
TAB_SLAS
.byte TK_DIV,$00 ; /
TAB_LESS
LBB_LSHIFT
.byte "<",TK_LSHIFT ; << note - "<<" must come before "<"
.byte TK_LT ; <
.byte $00
TAB_EQUL
.byte TK_EQUAL,$00 ; =
TAB_MORE
LBB_RSHIFT
.byte ">",TK_RSHIFT ; >> note - ">>" must come before ">"
.byte TK_GT ; >
.byte $00
TAB_QEST
.byte TK_PRINT,$00 ; ?
TAB_ASCA
LBB_ABS
.byte "BS(",TK_ABS ; ABS(
LBB_AND
.byte "ND",TK_AND ; AND
LBB_ASC
.byte "SC(",TK_ASC ; ASC(
LBB_ATN
.byte "TN(",TK_ATN ; ATN(
.byte $00
TAB_ASCB
LBB_BINS
.byte "IN$(",TK_BINS ; BIN$(
LBB_BITCLR
.byte "ITCLR",TK_BITCLR ; BITCLR
LBB_BITSET
.byte "ITSET",TK_BITSET ; BITSET
LBB_BITTST
.byte "ITTST(",TK_BITTST
; BITTST(
.byte $00
TAB_ASCC
LBB_CALL
.byte "ALL",TK_CALL ; CALL
LBB_CHRS
.byte "HR$(",TK_CHRS ; CHR$(
LBB_CLEAR
.byte "LEAR",TK_CLEAR ; CLEAR
LBB_CONT
.byte "ONT",TK_CONT ; CONT
LBB_COS
.byte "OS(",TK_COS ; COS(
.byte $00
TAB_ASCD
LBB_DATA
.byte "ATA",TK_DATA ; DATA
LBB_DEC
.byte "EC",TK_DEC ; DEC
LBB_DEEK
.byte "EEK(",TK_DEEK ; DEEK(
LBB_DEF
.byte "EF",TK_DEF ; DEF
LBB_DIM
.byte "IM",TK_DIM ; DIM
LBB_DOKE
.byte "OKE",TK_DOKE ; DOKE note - "DOKE" must come before "DO"
LBB_DO
.byte "O",TK_DO ; DO
.byte $00
TAB_ASCE
LBB_ELSE
.byte "LSE",TK_ELSE ; ELSE
LBB_END
.byte "ND",TK_END ; END
LBB_EOR
.byte "OR",TK_EOR ; EOR
LBB_EXP
.byte "XP(",TK_EXP ; EXP(
.byte $00
TAB_ASCF
LBB_FN
.byte "N",TK_FN ; FN
LBB_FOR
.byte "OR",TK_FOR ; FOR
LBB_FRE
.byte "RE(",TK_FRE ; FRE(
.byte $00
TAB_ASCG
LBB_GET
.byte "ET",TK_GET ; GET
LBB_GOSUB
.byte "OSUB",TK_GOSUB ; GOSUB
LBB_GOTO
.byte "OTO",TK_GOTO ; GOTO
.byte $00
TAB_ASCH
LBB_HEXS
.byte "EX$(",TK_HEXS ; HEX$(
.byte $00
TAB_ASCI
LBB_IF
.byte "F",TK_IF ; IF
LBB_INC
.byte "NC",TK_INC ; INC
LBB_INPUT
.byte "NPUT",TK_INPUT ; INPUT
LBB_INT
.byte "NT(",TK_INT ; INT(
LBB_IRQ
.byte "RQ",TK_IRQ ; IRQ
.byte $00
TAB_ASCL
LBB_LCASES
.byte "CASE$(",TK_LCASES
; LCASE$(
LBB_LEFTS
.byte "EFT$(",TK_LEFTS ; LEFT$(
LBB_LEN
.byte "EN(",TK_LEN ; LEN(
LBB_LET
.byte "ET",TK_LET ; LET
LBB_LIST
.byte "IST",TK_LIST ; LIST
LBB_LOAD
.byte "OAD",TK_LOAD ; LOAD
LBB_LOG
.byte "OG(",TK_LOG ; LOG(
LBB_LOOP
.byte "OOP",TK_LOOP ; LOOP
.byte $00
TAB_ASCM
LBB_MAX
.byte "AX(",TK_MAX ; MAX(
LBB_MIDS
.byte "ID$(",TK_MIDS ; MID$(
LBB_MIN
.byte "IN(",TK_MIN ; MIN(
.byte $00
TAB_ASCN
LBB_NEW
.byte "EW",TK_NEW ; NEW
LBB_NEXT
.byte "EXT",TK_NEXT ; NEXT
LBB_NMI
.byte "MI",TK_NMI ; NMI
LBB_NOT
.byte "OT",TK_NOT ; NOT
LBB_NULL
.byte "ULL",TK_NULL ; NULL
.byte $00
TAB_ASCO
LBB_OFF
.byte "FF",TK_OFF ; OFF
LBB_ON
.byte "N",TK_ON ; ON
LBB_OR
.byte "R",TK_OR ; OR
.byte $00
TAB_ASCP
LBB_PEEK
.byte "EEK(",TK_PEEK ; PEEK(
LBB_PI
.byte "I",TK_PI ; PI
LBB_POKE
.byte "OKE",TK_POKE ; POKE
LBB_POS
.byte "OS(",TK_POS ; POS(
LBB_PRINT
.byte "RINT",TK_PRINT ; PRINT
.byte $00
TAB_ASCR
LBB_READ
.byte "EAD",TK_READ ; READ
LBB_REM
.byte "EM",TK_REM ; REM
LBB_RESTORE
.byte "ESTORE",TK_RESTORE
; RESTORE
LBB_RETIRQ
.byte "ETIRQ",TK_RETIRQ ; RETIRQ
LBB_RETNMI
.byte "ETNMI",TK_RETNMI ; RETNMI
LBB_RETURN
.byte "ETURN",TK_RETURN ; RETURN
LBB_RIGHTS
.byte "IGHT$(",TK_RIGHTS
; RIGHT$(
LBB_RND
.byte "ND(",TK_RND ; RND(
LBB_RUN
.byte "UN",TK_RUN ; RUN
.byte $00
TAB_ASCS
LBB_SADD
.byte "ADD(",TK_SADD ; SADD(
LBB_SAVE
.byte "AVE",TK_SAVE ; SAVE
LBB_SGN
.byte "GN(",TK_SGN ; SGN(
LBB_SIN
.byte "IN(",TK_SIN ; SIN(
LBB_SPC
.byte "PC(",TK_SPC ; SPC(
LBB_SQR
.byte "QR(",TK_SQR ; SQR(
LBB_STEP
.byte "TEP",TK_STEP ; STEP
LBB_STOP
.byte "TOP",TK_STOP ; STOP
LBB_STRS
.byte "TR$(",TK_STRS ; STR$(
LBB_SWAP
.byte "WAP",TK_SWAP ; SWAP
.byte $00
TAB_ASCT
LBB_TAB
.byte "AB(",TK_TAB ; TAB(
LBB_TAN
.byte "AN(",TK_TAN ; TAN(
LBB_THEN
.byte "HEN",TK_THEN ; THEN
LBB_TO
.byte "O",TK_TO ; TO
LBB_TWOPI
.byte "WOPI",TK_TWOPI ; TWOPI
.byte $00
TAB_ASCU
LBB_UCASES
.byte "CASE$(",TK_UCASES
; UCASE$(
LBB_UNTIL
.byte "NTIL",TK_UNTIL ; UNTIL
LBB_USR
.byte "SR(",TK_USR ; USR(
.byte $00
TAB_ASCV
LBB_VAL
.byte "AL(",TK_VAL ; VAL(
LBB_VPTR
.byte "ARPTR(",TK_VPTR ; VARPTR(
.byte $00
TAB_ASCW
LBB_WAIT
.byte "AIT",TK_WAIT ; WAIT
LBB_WHILE
.byte "HILE",TK_WHILE ; WHILE
LBB_WIDTH
.byte "IDTH",TK_WIDTH ; WIDTH
.byte $00
TAB_POWR
.byte TK_POWER,$00 ; ^
; new decode table for LIST
; Table is ..
; byte - keyword length, keyword first character
; word - pointer to rest of keyword from dictionary
; note if length is 1 then the pointer is ignored
LAB_KEYT
.byte 3,'E'
.word LBB_END ; END
.byte 3,'F'
.word LBB_FOR ; FOR
.byte 4,'N'
.word LBB_NEXT ; NEXT
.byte 4,'D'
.word LBB_DATA ; DATA
.byte 5,'I'
.word LBB_INPUT ; INPUT
.byte 3,'D'
.word LBB_DIM ; DIM
.byte 4,'R'
.word LBB_READ ; READ
.byte 3,'L'
.word LBB_LET ; LET
.byte 3,'D'
.word LBB_DEC ; DEC
.byte 4,'G'
.word LBB_GOTO ; GOTO
.byte 3,'R'
.word LBB_RUN ; RUN
.byte 2,'I'
.word LBB_IF ; IF
.byte 7,'R'
.word LBB_RESTORE ; RESTORE
.byte 5,'G'
.word LBB_GOSUB ; GOSUB
.byte 6,'R'
.word LBB_RETIRQ ; RETIRQ
.byte 6,'R'
.word LBB_RETNMI ; RETNMI
.byte 6,'R'
.word LBB_RETURN ; RETURN
.byte 3,'R'
.word LBB_REM ; REM
.byte 4,'S'
.word LBB_STOP ; STOP
.byte 2,'O'
.word LBB_ON ; ON
.byte 4,'N'
.word LBB_NULL ; NULL
.byte 3,'I'
.word LBB_INC ; INC
.byte 4,'W'
.word LBB_WAIT ; WAIT
.byte 4,'L'
.word LBB_LOAD ; LOAD
.byte 4,'S'
.word LBB_SAVE ; SAVE
.byte 3,'D'
.word LBB_DEF ; DEF
.byte 4,'P'
.word LBB_POKE ; POKE
.byte 4,'D'
.word LBB_DOKE ; DOKE
.byte 4,'C'
.word LBB_CALL ; CALL
.byte 2,'D'
.word LBB_DO ; DO
.byte 4,'L'
.word LBB_LOOP ; LOOP
.byte 5,'P'
.word LBB_PRINT ; PRINT
.byte 4,'C'
.word LBB_CONT ; CONT
.byte 4,'L'
.word LBB_LIST ; LIST
.byte 5,'C'
.word LBB_CLEAR ; CLEAR
.byte 3,'N'
.word LBB_NEW ; NEW
.byte 5,'W'
.word LBB_WIDTH ; WIDTH
.byte 3,'G'
.word LBB_GET ; GET
.byte 4,'S'
.word LBB_SWAP ; SWAP
.byte 6,'B'
.word LBB_BITSET ; BITSET
.byte 6,'B'
.word LBB_BITCLR ; BITCLR
.byte 3,'I'
.word LBB_IRQ ; IRQ
.byte 3,'N'
.word LBB_NMI ; NMI
; secondary commands (can't start a statement)
.byte 4,'T'
.word LBB_TAB ; TAB
.byte 4,'E'
.word LBB_ELSE ; ELSE
.byte 2,'T'
.word LBB_TO ; TO
.byte 2,'F'
.word LBB_FN ; FN
.byte 4,'S'
.word LBB_SPC ; SPC
.byte 4,'T'
.word LBB_THEN ; THEN
.byte 3,'N'
.word LBB_NOT ; NOT
.byte 4,'S'
.word LBB_STEP ; STEP
.byte 5,'U'
.word LBB_UNTIL ; UNTIL
.byte 5,'W'
.word LBB_WHILE ; WHILE
.byte 3,'O'
.word LBB_OFF ; OFF
; opperators
.byte 1,'+'
.word $0000 ; +
.byte 1,'-'
.word $0000 ; -
.byte 1,'*'
.word $0000 ; *
.byte 1,'/'
.word $0000 ; /
.byte 1,'^'
.word $0000 ; ^
.byte 3,'A'
.word LBB_AND ; AND
.byte 3,'E'
.word LBB_EOR ; EOR
.byte 2,'O'
.word LBB_OR ; OR
.byte 2,'>'
.word LBB_RSHIFT ; >>
.byte 2,'<'
.word LBB_LSHIFT ; <<
.byte 1,'>'
.word $0000 ; >
.byte 1,'='
.word $0000 ; =
.byte 1,'<'
.word $0000 ; <
; functions
.byte 4,'S' ;
.word LBB_SGN ; SGN
.byte 4,'I' ;
.word LBB_INT ; INT
.byte 4,'A' ;
.word LBB_ABS ; ABS
.byte 4,'U' ;
.word LBB_USR ; USR
.byte 4,'F' ;
.word LBB_FRE ; FRE
.byte 4,'P' ;
.word LBB_POS ; POS
.byte 4,'S' ;
.word LBB_SQR ; SQR
.byte 4,'R' ;
.word LBB_RND ; RND
.byte 4,'L' ;
.word LBB_LOG ; LOG
.byte 4,'E' ;
.word LBB_EXP ; EXP
.byte 4,'C' ;
.word LBB_COS ; COS
.byte 4,'S' ;
.word LBB_SIN ; SIN
.byte 4,'T' ;
.word LBB_TAN ; TAN
.byte 4,'A' ;
.word LBB_ATN ; ATN
.byte 5,'P' ;
.word LBB_PEEK ; PEEK
.byte 5,'D' ;
.word LBB_DEEK ; DEEK
.byte 5,'S' ;
.word LBB_SADD ; SADD
.byte 4,'L' ;
.word LBB_LEN ; LEN
.byte 5,'S' ;
.word LBB_STRS ; STR$
.byte 4,'V' ;
.word LBB_VAL ; VAL
.byte 4,'A' ;
.word LBB_ASC ; ASC
.byte 7,'U' ;
.word LBB_UCASES ; UCASE$
.byte 7,'L' ;
.word LBB_LCASES ; LCASE$
.byte 5,'C' ;
.word LBB_CHRS ; CHR$
.byte 5,'H' ;
.word LBB_HEXS ; HEX$
.byte 5,'B' ;
.word LBB_BINS ; BIN$
.byte 7,'B' ;
.word LBB_BITTST ; BITTST
.byte 4,'M' ;
.word LBB_MAX ; MAX
.byte 4,'M' ;
.word LBB_MIN ; MIN
.byte 2,'P' ;
.word LBB_PI ; PI
.byte 5,'T' ;
.word LBB_TWOPI ; TWOPI
.byte 7,'V' ;
.word LBB_VPTR ; VARPTR
.byte 6,'L' ;
.word LBB_LEFTS ; LEFT$
.byte 7,'R' ;
.word LBB_RIGHTS ; RIGHT$
.byte 5,'M' ;
.word LBB_MIDS ; MID$
; BASIC messages, mostly error messages
LAB_BAER
.word ERR_NF ;$00 NEXT without FOR
.word ERR_SN ;$02 syntax
.word ERR_RG ;$04 RETURN without GOSUB
.word ERR_OD ;$06 out of data
.word ERR_FC ;$08 function call
.word ERR_OV ;$0A overflow
.word ERR_OM ;$0C out of memory
.word ERR_US ;$0E undefined statement
.word ERR_BS ;$10 array bounds
.word ERR_DD ;$12 double dimension array
.word ERR_D0 ;$14 divide by 0
.word ERR_ID ;$16 illegal direct
.word ERR_TM ;$18 type mismatch
.word ERR_LS ;$1A long string
.word ERR_ST ;$1C string too complex
.word ERR_CN ;$1E continue error
.word ERR_UF ;$20 undefined function
.word ERR_LD ;$22 LOOP without DO
; I may implement these two errors to force definition of variables and
; dimensioning of arrays before use.
; .word ERR_UV ;$24 undefined variable
; the above error has been tested and works (see code and comments below LAB_1D8B)
; .word ERR_UA ;$26 undimensioned array
ERR_NF .byte "NEXT without FOR",$00
ERR_SN .byte "Syntax",$00
ERR_RG .byte "RETURN without GOSUB",$00
ERR_OD .byte "Out of DATA",$00
ERR_FC .byte "Function call",$00
ERR_OV .byte "Overflow",$00
ERR_OM .byte "Out of memory",$00
ERR_US .byte "Undefined statement",$00
ERR_BS .byte "Array bounds",$00
ERR_DD .byte "Double dimension",$00
ERR_D0 .byte "Divide by zero",$00
ERR_ID .byte "Illegal direct",$00
ERR_TM .byte "Type mismatch",$00
ERR_LS .byte "String too long",$00
ERR_ST .byte "String too complex",$00
ERR_CN .byte "Can't continue",$00
ERR_UF .byte "Undefined function",$00
ERR_LD .byte "LOOP without DO",$00
;ERR_UV .byte "Undefined variable",$00
; the above error has been tested and works (see code and comments below LAB_1D8B)
;ERR_UA .byte "Undimensioned array",$00
LAB_BMSG .byte $0D,$0A,"Break",$00
LAB_EMSG .byte " Error",$00
LAB_LMSG .byte " in line ",$00
LAB_RMSG .byte $0D,$0A,"Ready",$0D,$0A,$00
LAB_IMSG .byte " Extra ignored",$0D,$0A,$00
LAB_REDO .byte " Redo from start",$0D,$0A,$00
AA_end_basic
Reference in New Issue View Git Blame Copy Permalink