Mercurial > hg > index.cgi
changeset 76:eb2681108660
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 | ba559f231929 |
| files | Makefile src/expr.s src/interp.s src/keywords.s src/lwbasic.s src/number.s src/token.s |
| diffstat | 7 files changed, 656 insertions(+), 647 deletions(-) [+] |
line wrap: on
line diff
--- a/Makefile Sun Aug 06 00:41:26 2023 -0600 +++ b/Makefile Sun Aug 06 00:51:22 2023 -0600 @@ -1,7 +1,7 @@ .PHONY: all all: bin/lwbasic.rom bin/lwbasic-coco2b.rom bin/lwbasic-coco3.rom bin/coco2.zip bin/coco2b.zip bin/coco3.zip -lwb_srcs := consscr.s defs.s error.s expr.s genio.s init.s interp.s irq.s keyb.s miscdata.s print.s progctrl.s vars.s +lwb_srcs := consscr.s defs.s error.s expr.s genio.s init.s interp.s irq.s keyb.s keywords.s miscdata.s number.s print.s progctrl.s token.s vars.s lwb_srcs := $(addprefix src/,$(lwb_srcs)) bin/lwbasic.rom: src/lwbasic.s $(lwb_srcs)
--- a/src/expr.s Sun Aug 06 00:41:26 2023 -0600 +++ b/src/expr.s Sun Aug 06 00:51:22 2023 -0600 @@ -173,4 +173,18 @@ fdb SNERROR fcb 0x46 ; boolean OR fdb SNERROR +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 jsr val_matchtypes ; go match data types + jmp val_add ; go add the values +; binary minus: subtraction +oper_minus jsr val_matchtypes ; go match data types + jmp val_sub ; do subtraction *pragmapop list
--- a/src/interp.s Sun Aug 06 00:41:26 2023 -0600 +++ b/src/interp.s Sun Aug 06 00:51:22 2023 -0600 @@ -43,6 +43,25 @@ suba #-'0 curcharraw0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Immediate mode handler immediate jsr writecondnl ; do newline if required ldx #prompt ; point to prompt string
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/keywords.s Sun Aug 06 00:51:22 2023 -0600 @@ -0,0 +1,99 @@ + *pragmapush list + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 + *pragmapop list
--- a/src/lwbasic.s Sun Aug 06 00:41:26 2023 -0600 +++ b/src/lwbasic.s Sun Aug 06 00:51:22 2023 -0600 @@ -47,655 +47,12 @@ include print.s include error.s include expr.s - + include number.s + include token.s include miscdata.s + include keywords.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
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/number.s Sun Aug 06 00:51:22 2023 -0600 @@ -0,0 +1,268 @@ + *pragmapush list + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 + *pragmapop list
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/token.s Sun Aug 06 00:51:22 2023 -0600 @@ -0,0 +1,252 @@ + *pragmapush list + *pragma list +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 + *pragmapop list