Mercurial > hg > index.cgi
view src/lwbasic.s @ 75:5f8f0b0781e8
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 |
line wrap: on
line source
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; LWBasic Version 0.1 ; Copyright © 2022 Lost Wizard Enterprises Incorporated ; ; This is LWBasic, a replacement Basic ROM system for the TRS-80 Color Computer which ; is most definitely not binary compatible with the stock ROMs. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; *pragmapush list *pragma nolist *pragma noexpandcond *pragma cescapes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Utility macros ; ; skip next byte; flags preserved skip1 macro noexpand fcb 0x21 ; opcode for BRN endm ; skip next byte and load nonzero to A skip1lda macro noexpand fcb 0x86 ; opcode for LDA immediate endm ; skip next byte and load nonzero to B skip1ldb macro noexpand fcb 0xc6 ; opcoe for LDB immediate endm ; skip next 2 bytes; clobbers flags skip2 macro noexpand fcb 0x8c ; opcode for CMPX immediate endm ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Include the various sub source files include defs.s include vars.s *pragmapop list org 0x8000 ; the hardware puts the ROMs here; it's not negotiable ROMSTART equ * *pragmapush list *pragma nolist include init.s include keyb.s include irq.s include consscr.s include genio.s include interp.s include progctrl.s include print.s include error.s include expr.s include miscdata.s *pragmapop list ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Set carry if upper/lower case alpha setcifalpha cmpa #'z+1 ; is it above lower case Z? bhs setcifalpha0 ; brif so, C clear suba #'a ; set C if >= lower case A suba #-'a bcs setcifalpha0 ; brif lower case alpha setcifualpha cmpa #'Z+1 ; is it above upper case Z? bhs setcifalpha0 ; brif so, C clear suba #'A ; set C if >= upper case A suba #-'A setcifalpha0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Set carry if digit setcifdigit cmpa #'9+1 ; is it above digit 9? bhs setcifdigit0 ; brif so, C clear suba #'0 ; set C if >= digit 0 suba #-'0 setcifdigit0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Operator handling routines ; ; binary plus: addition and concatenation oper_plus ldb val.type,x ; get type of the left operand cmpb valtype_string ; is it string? bne oper_plus0 ; brif not cmpb val.type,u ; is right operand also string? lbeq SNERROR ; brif so - do string concatenation oper_plus0 bsr val_matchtypes ; go match data types jmp val_add ; go add the values ; binary minus: subtraction oper_minus bsr val_matchtypes ; go match data types jmp val_sub ; do subtraction ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Arithmetic package ; ; This section contains routines that handle floating point and integer arithmetic. ; ; Most routines take a pointer to a value accumulator in X. Some take two pointers with the second in U. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Match operands for a numeric calculation. This works as follows: ; ; * If both operands are the same, ensure the type is numeric and return ; * If one operand is floating point, convert the other to floating point, as long as it is numeric ; * If one or both oeprands are not numeric, raise a type mismatch ; The operands are in (X) and (U) val_matchtypes ldb val.type,x ; get the type of first argument cmpb #valtype_int ; is it integer? beq val_matchtypes0 ; brif so cmpb #valtype_float ; is it floating point? beq val_matchtypes1 ; brif so TMERROR ldb #err_tm ; raise a type mismatch jmp ERROR val_matchtypes0 ldb val.type,u ; get type of second operand cmpb #valtype_int ; is it integer? bne val_matchtypes2 ; brif not val_matchtypes3 rts val_matchtypes2 cmpb #valtype_float ; is it floating point? bne TMERROR ; brif not - raise error pshs u ; save pointer to second operand bsr val_int32tofp ; convert first argument to floating point puls u,pc ; restore second operand pointer and return val_matchtypes1 ldb val.type,u ; get second argument type cmpb #valtype_float ; is it floating point? beq val_matchtypes3 ; brif so - we're good cmpb #valtype_int ; is it integer? bne TMERROR ; brif not - invalid type combination pshs x,u ; save value pointers leax ,u ; convert (U) to floating point bsr val_int32tofp puls x,u,pc ; restore argument pointers and return ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Negate the 32 bit integer (for fp mantissa) at (X) val_negint32 ldd zero ; subtract integer value from zero subd val.int+2,x std val.int+2,x ldd zero sbcb val.int+1,x sbca val.int,x std val.int,x rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Convert integer value at (X) to floating point value at (X). Enter at val_uint32tofp to treat the 32 bit value as ; unsigned. Otherwise enter at val_int32tofp to treat it as signed. val_uint32tofp clr val.fpsign,x ; for positive sign bra val_int32tofpp ; go process as positive val_int32tofp ldb val.int,x ; get sign to A sex sta val.fpsign,x ; set sign of result bpl val_int32tofpp ; brif positive - don't need to do a two's complement adjustment bsr val_negint32 ; negate the integer value val_int32tofpp ldb valtype_float ; set result to floating point stb val.type,x ldb #0xa0 ; exponent to have binary point to the right of the mantissa stb val.fpexp,x ; set the exponent clrb ; clear out extra precision bits ; fall through to normalize the value at (X) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Normalize floating point value at (X); this will shift the mantissa until there is a one in the leftmost ; bit of the mantissa. The algorithm is as follows: ; ; 1. Shift the mantissa left until a 1 bit is found in the high bit of the mantissa. ; 1a. If more than 40 bits of left shifts occur, determine that the value is zero and return ; 2. Adjust exponent based on number of shifts ; 2a. If new exponent went below -127, then underflow occurred and zero out value ; 2b. If new exponent went above +127, raise an overflow ; 3. If bit 7 of the extra precision byte is clear, return the resulting value ; 4. Add one to the mantissa ; 5. If a carry in (4) occurred, then set high bit of mantissa and bump exponent ; 6. If new exponent carries, then raise overflow ; 7. Return result. ; ; Note that if we carried in (4), the only possible result is that the mantissa ; rolled over to all zeroes so there is no need to shift the entire mantissa right ; nor is there any reason to check for additional rounding. ; ; The above algorithm has some optimizations in the code sequence below. fp_normalize pshs b ; save extra bits clrb ; set shift counter/exponent adjustment fp_normalize0 lda val.fpmant,x ; set flags on high word of mantissa bne fp_normalize2 ; brif we don't have a full byte to shift addb #8 ; account for a while byte of shifts ldu val.fpmant+1,x ; shift mantissa left 8 bits stu val.fpmant,x lda val.fpmant+3,x sta val.fpmant+2,x lda ,s ; and include extra bits sta val.fpmant+3,x clr ,s ; and blank extra bits cmpb #40 ; have we shifted 40 bits? blo fp_normalize0 ; brif not - keep shifting bra fp_normalize7 ; go zero out the value fp_normalize1 incb ; account for one bit of shifting lsl ,s ; shift mantissa and extra bits left (will not be more than 7 shifts) rol val.fpmant+3,x rol val.fpmant+2,x rol val.fpmant+1,x rol val.fpmant,x fp_normalize2 bpl fp_normalize1 ; brif we have to do a bit shift pshs b ; apply exponent counter to exponent lda val.fpexp,x suba ,s+ bls fp_normalize6 ; brif we underflowed to zero bcc fp_normalize3 ; brif we did not overflow OVERROR2 jmp OVERROR ; raise overflow fp_normalize3 lsl ,s+ ; set C if the high bit of extra precision is set bcs fp_normalize5 ; brif bit set - we have to do rounding fp_normalize4 rts ; return if no rounding fp_normalize5 ldu val.fpmant+2,x ; add one to mantissa leau 1,u stu val.fpmant+2,x bne fp_normalize4 ; brif low word doesn't carry ldu val.fpmant,x leau 1,u stu val.fpmant,x bne fp_normalize4 ; brif high word doesn't carry ror val.fpmant,x ; shift right C in to high bit of mantissa (already set to get here) inc val.fpexp,x ; bump exponent for a right shift beq OVERROR2 ; brif it overflows (> +127) rts ; return result (only possible result was mantissa wrapped to zero) fp_normalize6 clr val.fpmant,x ; clear mantissa clr val.fpmant+1,x clr val.fpmant+2,x clr val.fpmant+3,x fp_normalize7 clr val.fpexp,x ; clear exponent and sign clr val.fpsign,x puls b,pc ; clean up stack and return ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Addition and subtraction of values; must enter with values of matching types ; ; Calculates (X) + (U) -> (Y) (addition) ; Calculates (X) - (U) -> (Y) (subtraction) val_add ldb val.type,x ; get type of left operand stb val.type,y ; set result type cmpb #valtype_float ; is it float? beq fp_add ; brif so ldd val.int+2,x ; do the addition addd val.int+2,u std val.int+2,y ldd val.int,x adcb val.int+1,u adca val.int,u std val.int,y lbvs OVERROR ; brif calculation overflowed rts val_sub ldb val.type,x ; get type of left operand stb val.type,y ; set result type cmpb #valtype_float ; floating point? beq fp_sub ; brif so ldd val.int+2,x ; do the subtraction subd val.int+2,u std val.int+2,y ldd val.int,x sbcb val.int+1,u sbca val.int,u std val.int,y lbvs OVERROR ; brif overflow rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; FP subtraction: just invert the sign of the second operand and add; operands must be writable and they should be ; considered to be clobbered fp_sub com val.fpsign,u ; negate right operand ; fall through to addition ; FP addition: this requires that *both operands* are writable and they may be clobbered fp_add ldb val.fpexp,u ; is the second operand zero? beq fp_add0 ; brif so - it's a no-op - copy the left operand to the output lda val.fpexp,x ; is left operand zero? bne fp_add1 ; brif not - we have to do the add leau ,x ; copy the right operand to the output fp_add0 ldd ,u ; copy the value across std ,y ldd 2,u std 2,y ldd 4,u std 4,y rts fp_add1 subb val.fpexp,x ; get difference in exponents beq fp_add6 ; brif they're the same - no denormalizing is needed bhi fp_add2 ; brif second one is bigger, need to right-shift the mantissa of first exg x,u ; swap the operands (we can do that for addition)l second is now biggest negb ; invert the shift count fp_add2 cmpb #32 ; are we shifting more than 32 bits? blo fp_add0 ; brif so - we're effectively adding zero so bail out fp_add3 cmpb #8 ; have 8 bits to move? bhs fp_add5 ; brif not lda val.fpmant+2,x ; shift 8 bits right sta val.fpmant+3,x lda val.fpmant+1,x sta val.fpmant+2,x lda val.fpmant,x sta val.fpmant+1,x clr val.fpmant,x subb #8 ; account for 8 shifts bra fp_add3 ; see if we have a whole byte to shift fp_add4 lsr val.fpmant,x ; shift right one bit ror val.fpmant+1,x ror val.fpmant+2,x ror val.fpmant+3,x fp_add5 decb ; done all shifts? bmi fp_add4 ; brif not - do a shift fp_add6 ldb val.fpexp,u ; set exponent of result stb val.fpexp,y ldb val.fpsign,u ; fetch sign of larger value stb val.fpsign,y ; set result sign cmpb val.fpsign,x bne fp_add8 ; brif not - need to subtract the operands ldd val.fpmant+2,u ; add the mantissas addd val.fpmant+2,x std val.fpmant+2,y ldd val.fpmant,u adcb val.fpmant+1,x adca val.fpmant,x std val.fpmant,y clrb ; clear extra precision bits bcc fp_add7 ; brif no carry ror val.fpmant,y ; shift carry into mantissa ror val.fpmant+1,y ror val.fpmant+2,y ror val.fpmant+3,y rorb ; keep bits for founding inc val.fpexp,y ; bump exponent to account for shift lbeq OVERROR ; brif it overflowed fp_add7 leax ,y ; point to result jmp fp_normalize ; go normalize the result fp_add8 ldd val.fpmant+2,u ; subtract operands subd val.fpmant+2,x std val.fpmant+2,y ldd val.fpmant,u sbcb val.fpmant+1,x sbca val.fpmant,x std val.fpmant,y bcc fp_add7 ; brif we didn't carry - no need to fix up ldd zero ; negate the mantissa bits since we use sign+magnitude subd val.fpmant+2,y std val.fpmant+2,y ldd zero sbcb val.fpmant+1,y sbca val.fpmant,y std val.fpmant,y neg val.fpsign,y ; invert sign of result since we went past zero clrb ; clear extra precision bits bra fp_add7 ; go normalize the result and return ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Pack a floating point value at (X) fp_packval ldb val.fpsign,x ; get sign bmi fp_packval ; brif negative - the default 1 bit will do ldb val.fpmant,x ; clear high bit of mantissa for positive andb #0x7f stb val.fpmant,x fp_packval0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Unpack a floating point value at (X) fp_unpackval0 ldb val.fpmant,x ; get high byte of mantissa sex ; now A is value for sign byte sta val.fpsign,x ; set sign orb #0x80 ; set high bit of mantissa stb val.fpmant,x rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The LIST command. ; ; Syntax: ; LIST ; LIST <line> ; LIST <line>- ; LIST -<line> ; LIST <start>-<end> cmd_list bne cmd_list1 ; brif we have arguments ldx progtext ; point to start of program cmd_list0 ldd #65535 ; set last line to list to max line number std binval bra cmd_list2 ; go do the listing cmd_list1 jsr parse_lineno ; parse starting line number (will default to 0) jsr prog_findline ; find the line or the one after where it would be jsr curchar ; are we at the end of the command? beq cmd_list2 ; brif so - we have a single line (binval will have the start line #) ldb #tok_minus ; insist on a - for a range if more than one line number jsr syncheckb beq cmd_list0 ; brif open ended ending - set to max line number jsr parse_lineno ; parse ending of range cmd_list2 ldd ,x ; are we at the end of the program? bne cmd_list4 ; brif not cmd_list3 rts cmd_list4 ldd 2,x ; get line number cmpd binval ; have we reached the end of the range? bhi cmd_list3 ; brif so - we're done jsr print_uint16d ; print out line number lda #0x20 ; and a space jsr writechr pshs x ; save start of this line (in case detokenizing exits early) leax 4,x ; move past line header bsr detokenize ; detokenize line to current output stream ldx [,s++] ; point to next line using saved pointer and clear it from the stack ; need to add a break check here bra cmd_list2 ; go handle another line ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Detokenize a line to the current output stream detokenize lda ,x+ ; get character from tokenized line bmi detokenize1 ; brif it's a keyword token lbeq writecondnl ; do a newline if needed and return cmpa #': ; is it a colon? bne detokenize0 ; brif not ldb ,x ; fetch subsequent character cmpb #tok_apos ; apostrophe version of REM? beq detokenize ; brif so - skip the colon cmpb #tok_else ; ELSE? beq detokenize ; brif so - skip the colon detokenize0 jsr writechr ; output it unmolested bra detokenize ; go handle another character detokenize1 ldu #primarydict ; point to primary dictionary table cmpa #0xff ; is it a secondary token? bne detokenize3 ; brif not ldu #secondarydict ; point to secondary dictionary table lda ,x+ ; get secondary token value bne detokenize3 ; brif not end of line leax -1,x ; don't consume the NUL detokenize2 lda #'! ; invalid token flag bra detokenize0 ; output it and continue detokenize3 anda #0x7f ; lose the high bit beq detokenize6 ; brif already at the right place detokenize4 ldb ,u ; end of dictionary table? beq detokenize2 ; brif so - show invalid tokenf lag detokenize5 ldb ,u+ ; fetch character in this keyboard bpl detokenize5 ; brif not end of keyword (high bit set) deca ; at the right token? bne detokenize4 ; brif not - skip another detokenize6 lda ,u+ ; get keyword character bmi detokenize7 ; brif end of keyword jsr writechr ; output it bra detokenize6 ; go fetch another detokenize7 anda #0x7f ; lose the high bit bra detokenize0 ; write it and move on with the input ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Canonicalize certain sequences; ALL the rewrite sequences must make the result shorter or keep it the same size makecanontab fcb tok_less,2 fcb tok_greater,tok_notequal fcb tok_equal,tok_lessequal fcb tok_greater,2 fcb tok_less,tok_notequal fcb tok_equal,tok_greaterequal fcb tok_equal,2 fcb tok_greater,tok_greaterequal fcb tok_less,tok_lessequal fcb 0 makecanon leay ,x ; point output to start of the buffer makecanon0 lda ,x+ ; get current byte sta ,y+ ; save in output bne makecanon1 ; brif not end of line rts makecanon1 bpl makecanon0 ; brif not a token cmpa #0xff ; is it secondary? bne makecanon2 ; brif not leax 1,x ; move past second half bra makecanon0 ; go handle next byte makecanon2 ldu #makecanontab ; point to replacement table makecanon3 cmpa ,u+ ; is it this entry? beq makecanon4 ; brif so ldb ,u+ ; get number of entries lslb ; 2 bytes per leau b,u ; move past entry ldb ,u ; end of table? bne makecanon3 ; brif not bra makecanon0 ; no substitutions found makecanon4 pshs x ; save original source pointer makecanon5 lda ,x+ ; get next character cmpa #0x20 ; is it space? beq makecanon5 ; brif so - skip it ldb ,u+ ; get number of replacement candidates makecanon6 cmpa ,u++ ; does it match? beq makecanon7 ; brif so decb ; seen all of them? bne makecanon6 ; brif not puls x ; restore input pointer bra makecanon0 ; go handle next input makecanon7 leas 2,s ; clear saved input pointer lda -1,u ; get replacement token sta -1,y ; put it in the output bra makecanon0 ; go handle more input ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Tokenize line to tokebuff ; ; Enter with X pointing to the text to tokenize. ; Exit with X pointing to the start of the tokenized line and D holding the length of the tokenized line. tokenize clr tok_skipkw ; clear "not token" flag clr tok_skipdt ; clear the "in data" flag ldy #tokebuff ; point to destination buffer pshs y ; set return value tokenize0 lda ,x+ ; get input character bne tokenize3 ; brif not end of input tokenize1 sta ,y+ ; blank out final byte in result tokenize2 ldx #tokebuff ; point to start of tokenized line bsr makecanon ; canonicalize certain sequences tfr y,d ; get end address to accumulator subd #tokebuff ; subtract out start; gives length of result puls x,pc ; set return pointer and return tokenize3 tst tok_skipkw ; are we in the middle of a "not token"? beq tokenize6 ; brif not jsr setcifalpha ; is it alpha bcs tokenize4 ; brif so - store it and continue jsr setcifdigit ; is it numeric? bcc tokenize5 ; brif not tokenize4 sta ,y+ ; save output character bra tokenize0 ; check for another tokenize5 clr tok_skipkw ; clear the "not token" flag tokenize6 cmpa #'" ; is it a string? bne tokenize8 ; brif not sta ,y+ ; save string delimiter tokenize7 lda ,x+ ; get input character beq tokenize1 ; brif end of input sta ,y+ ; save it in output cmpa #'" ; end of string? bne tokenize7 ; brif not bra tokenize0 ; brif tokenize8 cmpa #': ; end of statement? bne tokenize9 ; brif not clr tok_skipdt ; reset "in data" flag bra tokenize4 ; stash it and continue tokenize9 cmpa #0x20 ; is it a space? beq tokenize4 ; brif so - stash it unmodified tst tok_skipdt ; are we "in data"? bne tokenize4 ; brif so - don't tokenize it cmpa #'? ; PRINT shortcut? bne tokenize10 ; brif not lda #tok_print ; load token for PRINT bra tokenize4 ; move stash it and move on tokenize10 cmpa #'' ; ' shortcut for remark? bne tokenize12 ; brif not ldd #':*256+tok_apos ; put token for ' and an implied colon std ,y++ ; stash it tokenize11 lda ,x+ ; fetch byte from input sta ,y+ ; stash in output bne tokenize11 ; brif not end of input bra tokenize2 ; go finish up tokenize12 jsr setcifdigit ; is it a digit? bcs tokenize4 ; brif so - pass it through tsta ; is the high bit set? bmi tokenize0 ; ignore it if so ldu #primarydict ; point to keyword table leax -1,x ; back up input to start of potential token clr tok_kwtype ; set secondary table flag to primary table clr tok_kwmatch ; clear the matched token clr tok_kwmatch+1 clr tok_kwmatchl ; set length matched pshs x ; save start of input token tokenize13 clr tok_kwnum ; clear keyword number tokenize14 ldb ,u ; are we at the end of the table? bne tokenize16 ; brif not ldu #secondarydict ; point to secondary token dictionary com tok_kwtype ; flip to secondary token flag bne tokenize13 ; brif we haven't already done the secondaries puls x ; get back input pointer ldb tok_kwmatchl ; get length of best match beq tokenize15 ; brif we don't have a match abx ; move input pointer past matched token ldd tok_kwmatch ; get matched token number tsta ; is it a primary? beq tokenize24 ; brif so bra tokenize23 ; go stash two byte token tokenize15 com tok_skipkw ; set "not token flag" lda ,x+ ; get character bra tokenize4 ; stash it and continue tokenize16 ldx ,s ; get back start of input token clra ; initalize match length counter tokenize17 inca ; bump length counter ldb ,x+ ; get input character cmpb #'z ; is it above lower case Z? bhi tokenize18 ; brif so cmpb #'a ; is it below lower case A? blo tokenize18 ; brif so subb #0x20 ; convert to upper case tokenize18 subb ,u+ ; does it match? beq tokenize17 ; brif so - check another cmpb #0x80 ; did it match with high bit set? beq tokenize21 ; brif so - exact match leau -1,u ; back up to current test character tokenize19 ldb ,u+ ; end of token? bpl tokenize19 ; brif not tokenize20 inc tok_kwnum ; bump token counter bra tokenize14 ; go check another one tokenize21 cmpa tok_kwmatchl ; is it a longer match? bls tokenize20 ; brif not, ignore it sta tok_kwmatchl ; save new match length ldd tok_kwtype ; get the matched token count orb #0x80 ; set token flag std tok_kwmatch ; save matched token bra tokenize20 ; keep looking through the tables tokenize22 lda #': ; for putting implied colons in tokenize23 std ,y++ ; put output into buffer jmp tokenize0 ; go handle more input tokenize24 cmpb #tok_else ; is it ELSE? beq tokenize22 ; brif so - stash it with colon cmpb #tok_data ; is it DATA? bne tokenize26 ; brif not stb tok_skipdt ; set "in data" flag tokenize25 stb ,y+ ; stash token jmp tokenize0 ; go handle more tokenize26 cmpb #tok_rem ; is it REM? beq tokenize28 ; brif so cmpb #tok_apos ; apostrophe REM? bne tokenize25 ; brif not - stash token and continue lda #': ; stash the implied colon sta ,y+ bra tokenize28 tokenize27 ldb ,x+ ; fetch next input character tokenize28 stb ,y+ ; stash the character bne tokenize27 ; brif not end of input - do another jmp tokenize2 ; stash end of buffer and handle cleanup ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Special tokenization handling ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Keyword dictionaries and jump tables. These are defined by several macros which ensure that each command or function ; entry has an associated jump table entry. These macros are: ; ; defcmd string,symbase ; deffunc string,symbase,flags ; cmdtab ; functab ; cmdjump ; funcjump ; defcmd and deffunc will add an entry into the relevant dictionary table as well as adding one to the relevant jump ; tables. The cmdtab, functab, cmdjump, and funcjump will output the table definitions. *pragmapush list *pragma nolist __cmdnum set 0x80 __funcnum set 0x80 defcmd macro noexpand setstr __cmdtab="%(__cmdtab)\tfcs {1}\n" ifstr ne,"{3}","" setstr __cmdjump="%(__cmdjump)\tfdb {3}\n" else setstr __cmdjump="%(__cmdjump)\tfdb cmd_{2}\n" endc tok_{2} equ __cmdnum __cmdnum set __cmdnum+1 endm deffunc macro noexpand setstr __functab="%(__functab)\tfcs {1}\n" ifstr ne,"{4}","" setstr __funcjump="%(__funcjump)\tfcb {3}\n\tfdb {4}\n" else setstr __funcjump="%(__funcjump)\tfcb {3}\n\tfdb func_{2}\n" endc tok_{2} equ __funcnum __funcnum set __funcnum+1 endm cmdtab macro *pragmapush list *pragma nolist includestr "%(__cmdtab)" *pragmapop list fcb 0 ; flag end of table endm functab macro *pragmapush list *pragma nolist includestr "%(__functab)" *pragmapop list fcb 0 ; flag end of table endm cmdjump macro *pragmapush nolist *pragma nolist includestr "%(__cmdjump)" *pragmapop list endm funcjump macro *pragmapush nolist *pragma nolist includestr "%(__funcjump)" *pragmapop list endm *pragmapop list defcmd 'REM',rem defcmd /'/,apos defcmd 'DATA',data defcmd 'ELSE',else defcmd 'END',end defcmd 'STOP',stop defcmd 'LET',let defcmd 'NEW',new defcmd 'PRINT',print defcmd 'LIST',list defcmd 'RUN',run defcmd 'GOTO',goto defcmd 'GOSUB',gosub defcmd 'RETURN',return defcmd 'POP',pop defcmd '+',plus,SNERROR ; IMPORTANT: the operators from + to OR MUST stay in this exact sequence defcmd '-',minus,SNERROR ; with no gaps because a secondary lookup table is used for operator defcmd '*',times,SNERROR ; handling during binary operator handling. defcmd '/',divide,SNERROR defcmd '^',power,SNERROR defcmd '<',less,SNERROR defcmd '>',greater,SNERROR defcmd '=',equal,SNERROR defcmd '<=',lessequal,SNERROR defcmd '>=',greaterequal,SNERROR defcmd '<>',notequal,SNERROR defcmd 'AND',and,SNERROR defcmd 'OR',or,SNERROR defcmd 'NOT',not,SNERROR primarydict cmdtab secondarydict functab primaryjump cmdjump secondaryjump funcjump ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Need to ensure the vectors are at 0xbff2 zmb 0xbff2-* ; pad ROM up to the vector point fdb SW3VEC ; SWI3 vector fdb SW2VEC ; SWI2 vector fdb FRQVEC ; FIRQ vector fdb IRQVEC ; IRQ vector fdb SWIVEC ; SWI vector fdb NMIVEC ; NMI vector fdb START ; RESET vector (ROM entry point) endc ifdef COCO3 zmb 0xfff2-* ; pad ROM to bottom of vectors fdb INT.SWI3 ; SWI3 vector fdb INT.SWI2 ; SWI2 vector fdb INT.FIRQ ; FIRQ vector fdb INT.IRQ ; IRQ vector fdb INT.SWI ; SWI vector fdb INT.NMI ; NMI vector fdb START ; RESET vector (ROM entry point) else zmb 0x10000-* ; pad ROM to full size endc