Mercurial > hg > index.cgi

comparison src/lwbasic.s @ 76:eb2681108660

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 (4) 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 four of the split.
author William Astle <lost@l-w.ca>
date Sun, 06 Aug 2023 00:51:22 -0600
parents 5f8f0b0781e8
children bb50ac9fdf37
comparison
equal deleted inserted replaced
75:5f8f0b0781e8 76:eb2681108660
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 include error.s 48 include error.s
49 include expr.s 49 include expr.s
50 50 include number.s
51 include token.s
51 include miscdata.s 52 include miscdata.s
53 include keywords.s
52 *pragmapop list 54 *pragmapop list
53 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 ; Set carry if upper/lower case alpha
55 setcifalpha cmpa #'z+1 ; is it above lower case Z?
56 bhs setcifalpha0 ; brif so, C clear
57 suba #'a ; set C if >= lower case A
58 suba #-'a
59 bcs setcifalpha0 ; brif lower case alpha
60 setcifualpha cmpa #'Z+1 ; is it above upper case Z?
61 bhs setcifalpha0 ; brif so, C clear
62 suba #'A ; set C if >= upper case A
63 suba #-'A
64 setcifalpha0 rts
65 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
66 ; Set carry if digit
67 setcifdigit cmpa #'9+1 ; is it above digit 9?
68 bhs setcifdigit0 ; brif so, C clear
69 suba #'0 ; set C if >= digit 0
70 suba #-'0
71 setcifdigit0 rts
72 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
73 ; Operator handling routines
74 ;
75 ; binary plus: addition and concatenation
76 oper_plus ldb val.type,x ; get type of the left operand
77 cmpb valtype_string ; is it string?
78 bne oper_plus0 ; brif not
79 cmpb val.type,u ; is right operand also string?
80 lbeq SNERROR ; brif so - do string concatenation
81 oper_plus0 bsr val_matchtypes ; go match data types
82 jmp val_add ; go add the values
83 ; binary minus: subtraction
84 oper_minus bsr val_matchtypes ; go match data types
85 jmp val_sub ; do subtraction
86 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
87 ; Arithmetic package
88 ;
89 ; This section contains routines that handle floating point and integer arithmetic.
90 ;
91 ; Most routines take a pointer to a value accumulator in X. Some take two pointers with the second in U.
92 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
93 ; Match operands for a numeric calculation. This works as follows:
94 ;
95 ; * If both operands are the same, ensure the type is numeric and return
96 ; * If one operand is floating point, convert the other to floating point, as long as it is numeric
97 ; * If one or both oeprands are not numeric, raise a type mismatch
98 ; The operands are in (X) and (U)
99 val_matchtypes ldb val.type,x ; get the type of first argument
100 cmpb #valtype_int ; is it integer?
101 beq val_matchtypes0 ; brif so
102 cmpb #valtype_float ; is it floating point?
103 beq val_matchtypes1 ; brif so
104 TMERROR ldb #err_tm ; raise a type mismatch
105 jmp ERROR
106 val_matchtypes0 ldb val.type,u ; get type of second operand
107 cmpb #valtype_int ; is it integer?
108 bne val_matchtypes2 ; brif not
109 val_matchtypes3 rts
110 val_matchtypes2 cmpb #valtype_float ; is it floating point?
111 bne TMERROR ; brif not - raise error
112 pshs u ; save pointer to second operand
113 bsr val_int32tofp ; convert first argument to floating point
114 puls u,pc ; restore second operand pointer and return
115 val_matchtypes1 ldb val.type,u ; get second argument type
116 cmpb #valtype_float ; is it floating point?
117 beq val_matchtypes3 ; brif so - we're good
118 cmpb #valtype_int ; is it integer?
119 bne TMERROR ; brif not - invalid type combination
120 pshs x,u ; save value pointers
121 leax ,u ; convert (U) to floating point
122 bsr val_int32tofp
123 puls x,u,pc ; restore argument pointers and return
124 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
125 ; Negate the 32 bit integer (for fp mantissa) at (X)
126 val_negint32 ldd zero ; subtract integer value from zero
127 subd val.int+2,x
128 std val.int+2,x
129 ldd zero
130 sbcb val.int+1,x
131 sbca val.int,x
132 std val.int,x
133 rts
134 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
135 ; Convert integer value at (X) to floating point value at (X). Enter at val_uint32tofp to treat the 32 bit value as
136 ; unsigned. Otherwise enter at val_int32tofp to treat it as signed.
137 val_uint32tofp clr val.fpsign,x ; for positive sign
138 bra val_int32tofpp ; go process as positive
139 val_int32tofp ldb val.int,x ; get sign to A
140 sex
141 sta val.fpsign,x ; set sign of result
142 bpl val_int32tofpp ; brif positive - don't need to do a two's complement adjustment
143 bsr val_negint32 ; negate the integer value
144 val_int32tofpp ldb valtype_float ; set result to floating point
145 stb val.type,x
146 ldb #0xa0 ; exponent to have binary point to the right of the mantissa
147 stb val.fpexp,x ; set the exponent
148 clrb ; clear out extra precision bits
149 ; fall through to normalize the value at (X)
150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
151 ; Normalize floating point value at (X); this will shift the mantissa until there is a one in the leftmost
152 ; bit of the mantissa. The algorithm is as follows:
153 ;
154 ; 1. Shift the mantissa left until a 1 bit is found in the high bit of the mantissa.
155 ; 1a. If more than 40 bits of left shifts occur, determine that the value is zero and return
156 ; 2. Adjust exponent based on number of shifts
157 ; 2a. If new exponent went below -127, then underflow occurred and zero out value
158 ; 2b. If new exponent went above +127, raise an overflow
159 ; 3. If bit 7 of the extra precision byte is clear, return the resulting value
160 ; 4. Add one to the mantissa
161 ; 5. If a carry in (4) occurred, then set high bit of mantissa and bump exponent
162 ; 6. If new exponent carries, then raise overflow
163 ; 7. Return result.
164 ;
165 ; Note that if we carried in (4), the only possible result is that the mantissa
166 ; rolled over to all zeroes so there is no need to shift the entire mantissa right
167 ; nor is there any reason to check for additional rounding.
168 ;
169 ; The above algorithm has some optimizations in the code sequence below.
170 fp_normalize pshs b ; save extra bits
171 clrb ; set shift counter/exponent adjustment
172 fp_normalize0 lda val.fpmant,x ; set flags on high word of mantissa
173 bne fp_normalize2 ; brif we don't have a full byte to shift
174 addb #8 ; account for a while byte of shifts
175 ldu val.fpmant+1,x ; shift mantissa left 8 bits
176 stu val.fpmant,x
177 lda val.fpmant+3,x
178 sta val.fpmant+2,x
179 lda ,s ; and include extra bits
180 sta val.fpmant+3,x
181 clr ,s ; and blank extra bits
182 cmpb #40 ; have we shifted 40 bits?
183 blo fp_normalize0 ; brif not - keep shifting
184 bra fp_normalize7 ; go zero out the value
185 fp_normalize1 incb ; account for one bit of shifting
186 lsl ,s ; shift mantissa and extra bits left (will not be more than 7 shifts)
187 rol val.fpmant+3,x
188 rol val.fpmant+2,x
189 rol val.fpmant+1,x
190 rol val.fpmant,x
191 fp_normalize2 bpl fp_normalize1 ; brif we have to do a bit shift
192 pshs b ; apply exponent counter to exponent
193 lda val.fpexp,x
194 suba ,s+
195 bls fp_normalize6 ; brif we underflowed to zero
196 bcc fp_normalize3 ; brif we did not overflow
197 OVERROR2 jmp OVERROR ; raise overflow
198 fp_normalize3 lsl ,s+ ; set C if the high bit of extra precision is set
199 bcs fp_normalize5 ; brif bit set - we have to do rounding
200 fp_normalize4 rts ; return if no rounding
201 fp_normalize5 ldu val.fpmant+2,x ; add one to mantissa
202 leau 1,u
203 stu val.fpmant+2,x
204 bne fp_normalize4 ; brif low word doesn't carry
205 ldu val.fpmant,x
206 leau 1,u
207 stu val.fpmant,x
208 bne fp_normalize4 ; brif high word doesn't carry
209 ror val.fpmant,x ; shift right C in to high bit of mantissa (already set to get here)
210 inc val.fpexp,x ; bump exponent for a right shift
211 beq OVERROR2 ; brif it overflows (> +127)
212 rts ; return result (only possible result was mantissa wrapped to zero)
213 fp_normalize6 clr val.fpmant,x ; clear mantissa
214 clr val.fpmant+1,x
215 clr val.fpmant+2,x
216 clr val.fpmant+3,x
217 fp_normalize7 clr val.fpexp,x ; clear exponent and sign
218 clr val.fpsign,x
219 puls b,pc ; clean up stack and return
220 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
221 ; Addition and subtraction of values; must enter with values of matching types
222 ;
223 ; Calculates (X) + (U) -> (Y) (addition)
224 ; Calculates (X) - (U) -> (Y) (subtraction)
225 val_add ldb val.type,x ; get type of left operand
226 stb val.type,y ; set result type
227 cmpb #valtype_float ; is it float?
228 beq fp_add ; brif so
229 ldd val.int+2,x ; do the addition
230 addd val.int+2,u
231 std val.int+2,y
232 ldd val.int,x
233 adcb val.int+1,u
234 adca val.int,u
235 std val.int,y
236 lbvs OVERROR ; brif calculation overflowed
237 rts
238 val_sub ldb val.type,x ; get type of left operand
239 stb val.type,y ; set result type
240 cmpb #valtype_float ; floating point?
241 beq fp_sub ; brif so
242 ldd val.int+2,x ; do the subtraction
243 subd val.int+2,u
244 std val.int+2,y
245 ldd val.int,x
246 sbcb val.int+1,u
247 sbca val.int,u
248 std val.int,y
249 lbvs OVERROR ; brif overflow
250 rts
251 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
252 ; FP subtraction: just invert the sign of the second operand and add; operands must be writable and they should be
253 ; considered to be clobbered
254 fp_sub com val.fpsign,u ; negate right operand
255 ; fall through to addition
256 ; FP addition: this requires that *both operands* are writable and they may be clobbered
257 fp_add ldb val.fpexp,u ; is the second operand zero?
258 beq fp_add0 ; brif so - it's a no-op - copy the left operand to the output
259 lda val.fpexp,x ; is left operand zero?
260 bne fp_add1 ; brif not - we have to do the add
261 leau ,x ; copy the right operand to the output
262 fp_add0 ldd ,u ; copy the value across
263 std ,y
264 ldd 2,u
265 std 2,y
266 ldd 4,u
267 std 4,y
268 rts
269 fp_add1 subb val.fpexp,x ; get difference in exponents
270 beq fp_add6 ; brif they're the same - no denormalizing is needed
271 bhi fp_add2 ; brif second one is bigger, need to right-shift the mantissa of first
272 exg x,u ; swap the operands (we can do that for addition)l second is now biggest
273 negb ; invert the shift count
274 fp_add2 cmpb #32 ; are we shifting more than 32 bits?
275 blo fp_add0 ; brif so - we're effectively adding zero so bail out
276 fp_add3 cmpb #8 ; have 8 bits to move?
277 bhs fp_add5 ; brif not
278 lda val.fpmant+2,x ; shift 8 bits right
279 sta val.fpmant+3,x
280 lda val.fpmant+1,x
281 sta val.fpmant+2,x
282 lda val.fpmant,x
283 sta val.fpmant+1,x
284 clr val.fpmant,x
285 subb #8 ; account for 8 shifts
286 bra fp_add3 ; see if we have a whole byte to shift
287 fp_add4 lsr val.fpmant,x ; shift right one bit
288 ror val.fpmant+1,x
289 ror val.fpmant+2,x
290 ror val.fpmant+3,x
291 fp_add5 decb ; done all shifts?
292 bmi fp_add4 ; brif not - do a shift
293 fp_add6 ldb val.fpexp,u ; set exponent of result
294 stb val.fpexp,y
295 ldb val.fpsign,u ; fetch sign of larger value
296 stb val.fpsign,y ; set result sign
297 cmpb val.fpsign,x
298 bne fp_add8 ; brif not - need to subtract the operands
299 ldd val.fpmant+2,u ; add the mantissas
300 addd val.fpmant+2,x
301 std val.fpmant+2,y
302 ldd val.fpmant,u
303 adcb val.fpmant+1,x
304 adca val.fpmant,x
305 std val.fpmant,y
306 clrb ; clear extra precision bits
307 bcc fp_add7 ; brif no carry
308 ror val.fpmant,y ; shift carry into mantissa
309 ror val.fpmant+1,y
310 ror val.fpmant+2,y
311 ror val.fpmant+3,y
312 rorb ; keep bits for founding
313 inc val.fpexp,y ; bump exponent to account for shift
314 lbeq OVERROR ; brif it overflowed
315 fp_add7 leax ,y ; point to result
316 jmp fp_normalize ; go normalize the result
317 fp_add8 ldd val.fpmant+2,u ; subtract operands
318 subd val.fpmant+2,x
319 std val.fpmant+2,y
320 ldd val.fpmant,u
321 sbcb val.fpmant+1,x
322 sbca val.fpmant,x
323 std val.fpmant,y
324 bcc fp_add7 ; brif we didn't carry - no need to fix up
325 ldd zero ; negate the mantissa bits since we use sign+magnitude
326 subd val.fpmant+2,y
327 std val.fpmant+2,y
328 ldd zero
329 sbcb val.fpmant+1,y
330 sbca val.fpmant,y
331 std val.fpmant,y
332 neg val.fpsign,y ; invert sign of result since we went past zero
333 clrb ; clear extra precision bits
334 bra fp_add7 ; go normalize the result and return
335 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
336 ; Pack a floating point value at (X)
337 fp_packval ldb val.fpsign,x ; get sign
338 bmi fp_packval ; brif negative - the default 1 bit will do
339 ldb val.fpmant,x ; clear high bit of mantissa for positive
340 andb #0x7f
341 stb val.fpmant,x
342 fp_packval0 rts
343 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
344 ; Unpack a floating point value at (X)
345 fp_unpackval0 ldb val.fpmant,x ; get high byte of mantissa
346 sex ; now A is value for sign byte
347 sta val.fpsign,x ; set sign
348 orb #0x80 ; set high bit of mantissa
349 stb val.fpmant,x
350 rts
351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
352 ; The LIST command.
353 ;
354 ; Syntax:
355 ; LIST
356 ; LIST <line>
357 ; LIST <line>-
358 ; LIST -<line>
359 ; LIST <start>-<end>
360 cmd_list bne cmd_list1 ; brif we have arguments
361 ldx progtext ; point to start of program
362 cmd_list0 ldd #65535 ; set last line to list to max line number
363 std binval
364 bra cmd_list2 ; go do the listing
365 cmd_list1 jsr parse_lineno ; parse starting line number (will default to 0)
366 jsr prog_findline ; find the line or the one after where it would be
367 jsr curchar ; are we at the end of the command?
368 beq cmd_list2 ; brif so - we have a single line (binval will have the start line #)
369 ldb #tok_minus ; insist on a - for a range if more than one line number
370 jsr syncheckb
371 beq cmd_list0 ; brif open ended ending - set to max line number
372 jsr parse_lineno ; parse ending of range
373 cmd_list2 ldd ,x ; are we at the end of the program?
374 bne cmd_list4 ; brif not
375 cmd_list3 rts
376 cmd_list4 ldd 2,x ; get line number
377 cmpd binval ; have we reached the end of the range?
378 bhi cmd_list3 ; brif so - we're done
379 jsr print_uint16d ; print out line number
380 lda #0x20 ; and a space
381 jsr writechr
382 pshs x ; save start of this line (in case detokenizing exits early)
383 leax 4,x ; move past line header
384 bsr detokenize ; detokenize line to current output stream
385 ldx [,s++] ; point to next line using saved pointer and clear it from the stack
386 ; need to add a break check here
387 bra cmd_list2 ; go handle another line
388 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
389 ; Detokenize a line to the current output stream
390 detokenize lda ,x+ ; get character from tokenized line
391 bmi detokenize1 ; brif it's a keyword token
392 lbeq writecondnl ; do a newline if needed and return
393 cmpa #': ; is it a colon?
394 bne detokenize0 ; brif not
395 ldb ,x ; fetch subsequent character
396 cmpb #tok_apos ; apostrophe version of REM?
397 beq detokenize ; brif so - skip the colon
398 cmpb #tok_else ; ELSE?
399 beq detokenize ; brif so - skip the colon
400 detokenize0 jsr writechr ; output it unmolested
401 bra detokenize ; go handle another character
402 detokenize1 ldu #primarydict ; point to primary dictionary table
403 cmpa #0xff ; is it a secondary token?
404 bne detokenize3 ; brif not
405 ldu #secondarydict ; point to secondary dictionary table
406 lda ,x+ ; get secondary token value
407 bne detokenize3 ; brif not end of line
408 leax -1,x ; don't consume the NUL
409 detokenize2 lda #'! ; invalid token flag
410 bra detokenize0 ; output it and continue
411 detokenize3 anda #0x7f ; lose the high bit
412 beq detokenize6 ; brif already at the right place
413 detokenize4 ldb ,u ; end of dictionary table?
414 beq detokenize2 ; brif so - show invalid tokenf lag
415 detokenize5 ldb ,u+ ; fetch character in this keyboard
416 bpl detokenize5 ; brif not end of keyword (high bit set)
417 deca ; at the right token?
418 bne detokenize4 ; brif not - skip another
419 detokenize6 lda ,u+ ; get keyword character
420 bmi detokenize7 ; brif end of keyword
421 jsr writechr ; output it
422 bra detokenize6 ; go fetch another
423 detokenize7 anda #0x7f ; lose the high bit
424 bra detokenize0 ; write it and move on with the input
425 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
426 ; Canonicalize certain sequences; ALL the rewrite sequences must make the result shorter or keep it the same size
427 makecanontab fcb tok_less,2
428 fcb tok_greater,tok_notequal
429 fcb tok_equal,tok_lessequal
430 fcb tok_greater,2
431 fcb tok_less,tok_notequal
432 fcb tok_equal,tok_greaterequal
433 fcb tok_equal,2
434 fcb tok_greater,tok_greaterequal
435 fcb tok_less,tok_lessequal
436 fcb 0
437 makecanon leay ,x ; point output to start of the buffer
438 makecanon0 lda ,x+ ; get current byte
439 sta ,y+ ; save in output
440 bne makecanon1 ; brif not end of line
441 rts
442 makecanon1 bpl makecanon0 ; brif not a token
443 cmpa #0xff ; is it secondary?
444 bne makecanon2 ; brif not
445 leax 1,x ; move past second half
446 bra makecanon0 ; go handle next byte
447 makecanon2 ldu #makecanontab ; point to replacement table
448 makecanon3 cmpa ,u+ ; is it this entry?
449 beq makecanon4 ; brif so
450 ldb ,u+ ; get number of entries
451 lslb ; 2 bytes per
452 leau b,u ; move past entry
453 ldb ,u ; end of table?
454 bne makecanon3 ; brif not
455 bra makecanon0 ; no substitutions found
456 makecanon4 pshs x ; save original source pointer
457 makecanon5 lda ,x+ ; get next character
458 cmpa #0x20 ; is it space?
459 beq makecanon5 ; brif so - skip it
460 ldb ,u+ ; get number of replacement candidates
461 makecanon6 cmpa ,u++ ; does it match?
462 beq makecanon7 ; brif so
463 decb ; seen all of them?
464 bne makecanon6 ; brif not
465 puls x ; restore input pointer
466 bra makecanon0 ; go handle next input
467 makecanon7 leas 2,s ; clear saved input pointer
468 lda -1,u ; get replacement token
469 sta -1,y ; put it in the output
470 bra makecanon0 ; go handle more input
471 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
472 ; Tokenize line to tokebuff
473 ;
474 ; Enter with X pointing to the text to tokenize.
475 ; Exit with X pointing to the start of the tokenized line and D holding the length of the tokenized line.
476 tokenize clr tok_skipkw ; clear "not token" flag
477 clr tok_skipdt ; clear the "in data" flag
478 ldy #tokebuff ; point to destination buffer
479 pshs y ; set return value
480 tokenize0 lda ,x+ ; get input character
481 bne tokenize3 ; brif not end of input
482 tokenize1 sta ,y+ ; blank out final byte in result
483 tokenize2 ldx #tokebuff ; point to start of tokenized line
484 bsr makecanon ; canonicalize certain sequences
485 tfr y,d ; get end address to accumulator
486 subd #tokebuff ; subtract out start; gives length of result
487 puls x,pc ; set return pointer and return
488 tokenize3 tst tok_skipkw ; are we in the middle of a "not token"?
489 beq tokenize6 ; brif not
490 jsr setcifalpha ; is it alpha
491 bcs tokenize4 ; brif so - store it and continue
492 jsr setcifdigit ; is it numeric?
493 bcc tokenize5 ; brif not
494 tokenize4 sta ,y+ ; save output character
495 bra tokenize0 ; check for another
496 tokenize5 clr tok_skipkw ; clear the "not token" flag
497 tokenize6 cmpa #'" ; is it a string?
498 bne tokenize8 ; brif not
499 sta ,y+ ; save string delimiter
500 tokenize7 lda ,x+ ; get input character
501 beq tokenize1 ; brif end of input
502 sta ,y+ ; save it in output
503 cmpa #'" ; end of string?
504 bne tokenize7 ; brif not
505 bra tokenize0 ; brif
506 tokenize8 cmpa #': ; end of statement?
507 bne tokenize9 ; brif not
508 clr tok_skipdt ; reset "in data" flag
509 bra tokenize4 ; stash it and continue
510 tokenize9 cmpa #0x20 ; is it a space?
511 beq tokenize4 ; brif so - stash it unmodified
512 tst tok_skipdt ; are we "in data"?
513 bne tokenize4 ; brif so - don't tokenize it
514 cmpa #'? ; PRINT shortcut?
515 bne tokenize10 ; brif not
516 lda #tok_print ; load token for PRINT
517 bra tokenize4 ; move stash it and move on
518 tokenize10 cmpa #'' ; ' shortcut for remark?
519 bne tokenize12 ; brif not
520 ldd #':*256+tok_apos ; put token for ' and an implied colon
521 std ,y++ ; stash it
522 tokenize11 lda ,x+ ; fetch byte from input
523 sta ,y+ ; stash in output
524 bne tokenize11 ; brif not end of input
525 bra tokenize2 ; go finish up
526 tokenize12 jsr setcifdigit ; is it a digit?
527 bcs tokenize4 ; brif so - pass it through
528 tsta ; is the high bit set?
529 bmi tokenize0 ; ignore it if so
530 ldu #primarydict ; point to keyword table
531 leax -1,x ; back up input to start of potential token
532 clr tok_kwtype ; set secondary table flag to primary table
533 clr tok_kwmatch ; clear the matched token
534 clr tok_kwmatch+1
535 clr tok_kwmatchl ; set length matched
536 pshs x ; save start of input token
537 tokenize13 clr tok_kwnum ; clear keyword number
538 tokenize14 ldb ,u ; are we at the end of the table?
539 bne tokenize16 ; brif not
540 ldu #secondarydict ; point to secondary token dictionary
541 com tok_kwtype ; flip to secondary token flag
542 bne tokenize13 ; brif we haven't already done the secondaries
543 puls x ; get back input pointer
544 ldb tok_kwmatchl ; get length of best match
545 beq tokenize15 ; brif we don't have a match
546 abx ; move input pointer past matched token
547 ldd tok_kwmatch ; get matched token number
548 tsta ; is it a primary?
549 beq tokenize24 ; brif so
550 bra tokenize23 ; go stash two byte token
551 tokenize15 com tok_skipkw ; set "not token flag"
552 lda ,x+ ; get character
553 bra tokenize4 ; stash it and continue
554 tokenize16 ldx ,s ; get back start of input token
555 clra ; initalize match length counter
556 tokenize17 inca ; bump length counter
557 ldb ,x+ ; get input character
558 cmpb #'z ; is it above lower case Z?
559 bhi tokenize18 ; brif so
560 cmpb #'a ; is it below lower case A?
561 blo tokenize18 ; brif so
562 subb #0x20 ; convert to upper case
563 tokenize18 subb ,u+ ; does it match?
564 beq tokenize17 ; brif so - check another
565 cmpb #0x80 ; did it match with high bit set?
566 beq tokenize21 ; brif so - exact match
567 leau -1,u ; back up to current test character
568 tokenize19 ldb ,u+ ; end of token?
569 bpl tokenize19 ; brif not
570 tokenize20 inc tok_kwnum ; bump token counter
571 bra tokenize14 ; go check another one
572 tokenize21 cmpa tok_kwmatchl ; is it a longer match?
573 bls tokenize20 ; brif not, ignore it
574 sta tok_kwmatchl ; save new match length
575 ldd tok_kwtype ; get the matched token count
576 orb #0x80 ; set token flag
577 std tok_kwmatch ; save matched token
578 bra tokenize20 ; keep looking through the tables
579 tokenize22 lda #': ; for putting implied colons in
580 tokenize23 std ,y++ ; put output into buffer
581 jmp tokenize0 ; go handle more input
582 tokenize24 cmpb #tok_else ; is it ELSE?
583 beq tokenize22 ; brif so - stash it with colon
584 cmpb #tok_data ; is it DATA?
585 bne tokenize26 ; brif not
586 stb tok_skipdt ; set "in data" flag
587 tokenize25 stb ,y+ ; stash token
588 jmp tokenize0 ; go handle more
589 tokenize26 cmpb #tok_rem ; is it REM?
590 beq tokenize28 ; brif so
591 cmpb #tok_apos ; apostrophe REM?
592 bne tokenize25 ; brif not - stash token and continue
593 lda #': ; stash the implied colon
594 sta ,y+
595 bra tokenize28
596 tokenize27 ldb ,x+ ; fetch next input character
597 tokenize28 stb ,y+ ; stash the character
598 bne tokenize27 ; brif not end of input - do another
599 jmp tokenize2 ; stash end of buffer and handle cleanup
600 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601 ; Special tokenization handling
602 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
603 ; Keyword dictionaries and jump tables. These are defined by several macros which ensure that each command or function
604 ; entry has an associated jump table entry. These macros are:
605 ;
606 ; defcmd string,symbase
607 ; deffunc string,symbase,flags
608 ; cmdtab
609 ; functab
610 ; cmdjump
611 ; funcjump
612 ; defcmd and deffunc will add an entry into the relevant dictionary table as well as adding one to the relevant jump
613 ; tables. The cmdtab, functab, cmdjump, and funcjump will output the table definitions.
614 *pragmapush list
615 *pragma nolist
616 __cmdnum set 0x80
617 __funcnum set 0x80
618 defcmd macro noexpand
619 setstr __cmdtab="%(__cmdtab)\tfcs {1}\n"
620 ifstr ne,"{3}",""
621 setstr __cmdjump="%(__cmdjump)\tfdb {3}\n"
622 else
623 setstr __cmdjump="%(__cmdjump)\tfdb cmd_{2}\n"
624 endc
625 tok_{2} equ __cmdnum
626 __cmdnum set __cmdnum+1
627 endm
628 deffunc macro noexpand
629 setstr __functab="%(__functab)\tfcs {1}\n"
630 ifstr ne,"{4}",""
631 setstr __funcjump="%(__funcjump)\tfcb {3}\n\tfdb {4}\n"
632 else
633 setstr __funcjump="%(__funcjump)\tfcb {3}\n\tfdb func_{2}\n"
634 endc
635 tok_{2} equ __funcnum
636 __funcnum set __funcnum+1
637 endm
638 cmdtab macro
639 *pragmapush list
640 *pragma nolist
641 includestr "%(__cmdtab)"
642 *pragmapop list
643 fcb 0 ; flag end of table
644 endm
645 functab macro
646 *pragmapush list
647 *pragma nolist
648 includestr "%(__functab)"
649 *pragmapop list
650 fcb 0 ; flag end of table
651 endm
652 cmdjump macro
653 *pragmapush nolist
654 *pragma nolist
655 includestr "%(__cmdjump)"
656 *pragmapop list
657 endm
658 funcjump macro
659 *pragmapush nolist
660 *pragma nolist
661 includestr "%(__funcjump)"
662 *pragmapop list
663 endm
664 *pragmapop list
665 defcmd 'REM',rem
666 defcmd /'/,apos
667 defcmd 'DATA',data
668 defcmd 'ELSE',else
669 defcmd 'END',end
670 defcmd 'STOP',stop
671 defcmd 'LET',let
672 defcmd 'NEW',new
673 defcmd 'PRINT',print
674 defcmd 'LIST',list
675 defcmd 'RUN',run
676 defcmd 'GOTO',goto
677 defcmd 'GOSUB',gosub
678 defcmd 'RETURN',return
679 defcmd 'POP',pop
680 defcmd '+',plus,SNERROR ; IMPORTANT: the operators from + to OR MUST stay in this exact sequence
681 defcmd '-',minus,SNERROR ; with no gaps because a secondary lookup table is used for operator
682 defcmd '*',times,SNERROR ; handling during binary operator handling.
683 defcmd '/',divide,SNERROR
684 defcmd '^',power,SNERROR
685 defcmd '<',less,SNERROR
686 defcmd '>',greater,SNERROR
687 defcmd '=',equal,SNERROR
688 defcmd '<=',lessequal,SNERROR
689 defcmd '>=',greaterequal,SNERROR
690 defcmd '<>',notequal,SNERROR
691 defcmd 'AND',and,SNERROR
692 defcmd 'OR',or,SNERROR
693 defcmd 'NOT',not,SNERROR
694 primarydict cmdtab
695 secondarydict functab
696 primaryjump cmdjump
697 secondaryjump funcjump
698 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 55 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
699 ; Need to ensure the vectors are at 0xbff2 56 ; Need to ensure the vectors are at 0xbff2
700 zmb 0xbff2-* ; pad ROM up to the vector point 57 zmb 0xbff2-* ; pad ROM up to the vector point
701 fdb SW3VEC ; SWI3 vector 58 fdb SW3VEC ; SWI3 vector
702 fdb SW2VEC ; SWI2 vector 59 fdb SW2VEC ; SWI2 vector