Mercurial > hg > index.cgi

comparison src/lwbasic.s @ 75:5f8f0b0781e8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Split some code into separate files for easier management (3) Because the source for lwbasic is so large, split it into several different files to make it easier to navigate and modify. This is part three of the split. Includes a file missing from part one.
author William Astle <lost@l-w.ca>
date Sun, 06 Aug 2023 00:41:26 -0600
parents e74d00ac6b79
children eb2681108660
comparison
equal deleted inserted replaced
74:e74d00ac6b79 75:5f8f0b0781e8
43 include consscr.s 43 include consscr.s
44 include genio.s 44 include genio.s
45 include interp.s 45 include interp.s
46 include progctrl.s 46 include progctrl.s
47 include print.s 47 include print.s
48 48 include error.s
49 include expr.s
50
49 include miscdata.s 51 include miscdata.s
50 *pragmapop list 52 *pragmapop list
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 ; Error messages
53 ;
54 ; Each error begins with a deferr macro invocation which will define a symbol err_slug with the next error number
55 ;
56 ; deferr slug
57 ;
58 ; This is then followed by the error message defined with fcn.
59 ;
60 ; Real error numbers start at 1; 0 is used to indicate no error.
61 *pragmapush list
62 *pragma nolist
63 __errnum set 0
64 deferr macro noexpand
65 err_{1} equ __errnum
66 __errnum set __errnum+1
67 endm
68 *pragmapop list
69 errormsg deferr none
70 fcn 'No error'
71 deferr nf
72 fcn 'NEXT without FOR'
73 deferr sn
74 fcn 'Syntax error'
75 deferr ul
76 fcn 'Undefined line number'
77 deferr rg
78 fcn 'RETURN without GOSUB'
79 deferr ov
80 fcn 'Overflow'
81 deferr tm
82 fcn 'Type mismatch'
83 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
84 ; The LET command which is the default if no token begins a statement
85 cmd_let jmp SNERROR ; not yet implemented
86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
87 ; Expression Evaluation Package
88 ;
89 ; This is the expression evaluator. It handles everything from parsing numbers to dispatching function calls. The main
90 ; entry point is eval_expr which will evaluate an arbitrary expression. It returns as soon as it reaches something it
91 ; doesn't understand as part of an expression.
92 ;
93 ; The special handling for relational operators is required because Basic allows them in all
94 eval_expr clrb ; flag previous operator as minimum precdence (end of expression)
95 eval_expraux jsr eval_term ; evaluate the first term of the expression
96 eval_expr0 jsr curchar ; fetch current input
97 beq eval_expr1 ; brif end of expression - we're done
98 cmpa #tok_or ; is it above operators?
99 bhi eval_expr1 ; brif so
100 suba #tok_plus ; offset to zero for first operator token
101 bcc eval_expr2 ; brif it is an operator
102 eval_expr1 rts
103 eval_expr2 pshs b ; save previous operator precedence
104 ldx #oper_tab ; point to operator table
105 tfr a,b ; shift to B for "ABX"
106 abx ; add three times (3 bytes per entry)
107 abx ; OBS: TFR + ABX + ABX + ABX is faster than LDB + MUL + ABX
108 abx ; now X points to the operator entry in the table
109 ldb ,x ; get precedence of current operation
110 cmpb ,s ; is it higher than the current operation?
111 bhi eval_expr3 ; brif so - process this operator
112 puls b,pc ; return current value to complete previous operation
113 eval_expr3 jsr nextchar ; eat the operator token
114 ldx 1,x ; get handler address of this operator
115 leas -val.size,s ; make room for the result accumulator
116 pshs x ; save handler address for later
117 lda val0+val.type ; get current value type
118 ldx val0 ; get value accumlator contents (6 bytes)
119 ldy val0+2
120 ldu val0+4
121 pshs a,x,y,u ; save it on the stack
122 jsr eval_expraux ; evaluate the following term and higher precedence expressions
123 puls a,x,y,u ; get back saved value
124 stx val1 ; save it to the second value accumulator
125 sty val1+2
126 stu val1+4
127 sta val1+val.type ; save previous value type
128 ldx #val1 ; point to left operand
129 ldu #val0 ; point to right operand
130 leay 2,s ; point to return value location
131 jsr [,s++] ; go handle the operator
132 puls a,x,y,u ; get return value
133 sta val0
134 stx val0+1
135 sty val0+3
136 stu val0+5
137 puls b ; get back the previous operator precedence
138 bra eval_expr0 ; go process another operator or end of expression
139 eval_term jsr curchar ; get current input character
140 beq eval_term0 ; brif end of input - this is an error
141 bcs eval_number ; brif digit - we have a number
142 ; bmi eval_func ; brif we have a token - handle function call
143 cmpa #'. ; decimal point?
144 beq eval_number ; brif so - evaluate number
145 cmpa #'- ; negative sign?
146 beq eval_number ; brif so - evaluate number
147 cmpa #'+ ; positive sign?
148 beq eval_number ; brif so - evaluate number
149 eval_term0 jmp SNERROR ; we have something unrecognized - raise error
150 ; Evaluate a number constant. Currently this only handles 32 bit integers.
151 eval_number ldb #valtype_int ; start with integer value
152 stb val0+val.type ; set return value
153 ldx zero ; blank out the value
154 stx val0
155 stx val0+2
156 stx val0+4
157 bra eval_number1 ; go do the parsing
158 eval_number0 jsr nextchar ; fetch next input
159 beq eval_numberr ; brif end of expression - bail
160 eval_number1 cmpa #'- ; negative (ascii sign)?
161 beq eval_number3 ; brif so
162 cmpa #tok_minus ; negative (operator negative)?
163 bne eval_number2 ; brif not
164 eval_number3 com val0+val.fpsign ; invert sign
165 bra eval_number0 ; deal with next input
166 eval_number2 cmpa #'+ ; unary +?
167 beq eval_number0 ; brif so - skip it
168 eval_number5 cmpa #'. ; decimal point?
169 beq eval_float ; brif decimal - force float
170 cmpa #'0 ; is it a number?
171 blo eval_numberr ; brif below digit
172 cmpa #'9 ; is it still a number?
173 bhi eval_numberr ; brif above digit
174 suba #'0 ; offset to binary digit value
175 pshs a ; save digit value
176 ldx val0+val.int ; get current value for later (for quick multiply by 10)
177 ldd val0+val.int+2
178 pshs d,x ; stored with words swapped on stack for efficiency for later
179 lsl val0+val.int+3 ; times 2
180 rol val0+val.int+2
181 rol val0+val.int+1
182 rol val0+val.int
183 bcs OVERROR ; brif overflowed
184 lsl val0+val.int+3 ; times 4
185 rol val0+val.int+2
186 rol val0+val.int+1
187 rol val0+val.int
188 bcs OVERROR ; brif overflowed
189 ldd val0+val.int+2 ; times 5 (add original value)
190 addd ,s++
191 std val0+val.int+2
192 ldd val0+val.int
193 adcb 1,s
194 adca ,s++
195 std val0+val.int
196 bcs OVERROR
197 lsl val0+val.int+3 ; times 10
198 rol val0+val.int+2
199 rol val0+val.int+1
200 rol val0+val.int
201 bcs OVERROR ; brif overflowed
202 ldd val0+val.int+2 ; get low word
203 addb ,s+ ; add in current digit
204 adca #0
205 std val0+val.int+2
206 ldd val0+val.int
207 adcb #0
208 adca #0
209 std val0+val.int
210 bcs OVERROR ; brif overflowed
211 bpl eval_number4 ; brif we haven't wrapped negative
212 cmpd #0x8000 ; is it valid negative two's complement?
213 bhi OVERROR ; brif not
214 ldd val0+val.int+2 ; is it still valid two's complement (max negative)?
215 bne OVERROR ; brif so
216 eval_number4 jsr nextchar ; fetch next input character
217 bra eval_number5 ; go handle it
218 OVERROR ldb #err_ov ; flag overflow
219 jmp ERROR
220 eval_numberr ldb val0+val.fpsign ; is the number we want negative?
221 beq eval_numberr0 ; brif not
222 jsr val_negint32 ; negate the integer
223 eval_numberr0 rts
224 eval_float jmp SNERROR ; we don't handle floating point yet
225 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
226 ; Operator table
227 ;
228 ; Each entry starts with the precedence value followed by the handler routine. Each handler will receive its left
229 ; operand in val1 and its right operand in val0 and should return its result in val0.
230 oper_tab fcb 0x79 ; addition
231 fdb oper_plus
232 fcb 0x79 ; subtraction
233 fdb oper_minus
234 fcb 0x7b ; multiplication
235 fdb SNERROR
236 fcb 0x7b ; division
237 fdb SNERROR
238 fcb 0x7f ; exponentiation
239 fdb SNERROR
240 fcb 0x64 ; less than
241 fdb SNERROR
242 fcb 0x64 ; equal to
243 fdb SNERROR
244 fcb 0x64 ; greater than
245 fdb SNERROR
246 fcb 0x64 ; less than or equal to
247 fdb SNERROR
248 fcb 0x64 ; greater than or equal to
249 fdb SNERROR
250 fcb 0x64 ; not equal to
251 fdb SNERROR
252 fcb 0x50 ; boolean AND
253 fdb SNERROR
254 fcb 0x46 ; boolean OR
255 fdb SNERROR
256 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
257 ; Set carry if upper/lower case alpha 54 ; Set carry if upper/lower case alpha
258 setcifalpha cmpa #'z+1 ; is it above lower case Z? 55 setcifalpha cmpa #'z+1 ; is it above lower case Z?
259 bhs setcifalpha0 ; brif so, C clear 56 bhs setcifalpha0 ; brif so, C clear
260 suba #'a ; set C if >= lower case A 57 suba #'a ; set C if >= lower case A