Mercurial > hg > index.cgi
changeset 70:eb7c96671f5b
Add some infrastructure for value handling
This adds some infrastructure for value handling including converting an
integer to floating point and the value accumulator structure. This also
converts some existing code to the new value accumulator structure.
| author | William Astle <lost@l-w.ca> |
|---|---|
| date | Sun, 02 Jul 2023 01:58:58 -0600 |
| parents | a3c4183f28e0 |
| children | f4b2406d7352 |
| files | src/lwbasic.s |
| diffstat | 1 files changed, 202 insertions(+), 66 deletions(-) [+] |
line wrap: on
line diff
--- a/src/lwbasic.s Sat Jun 10 12:27:50 2023 -0600 +++ b/src/lwbasic.s Sun Jul 02 01:58:58 2023 -0600 @@ -41,9 +41,49 @@ keyb_shift equ 0x01 ; shift pressed linebuffsize equ 0x100 ; the line input buffer (256 bytes) stringstacknum equ 20 ; number of entries on the anonymous string descriptor stack +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Data structure used for calculations. Calculations are handled via structurs called value accumulators. A value +; accumulator consists of a data type flag (at the end of the structure) and a data area whose layout varies based +; on the actual data type. The layouts for each value type are described below. +; +; A value type that is NULL (not set to anything) has type 0 (valtype_none) and the rest should be zero. +; +; A value accumulator has the following structure for floating point: +; Offset Length Contents +; 0 1 fp exponent +; 1 4 fp mantissa +; 5 1 fp sign +; 6 1 value type +; +; A value accumulator has the following structure for integers: +; Offset Length Contents +; 0 1 *unsued* +; 1 4 integer value (two's complement) +; 5 1 *unused* +; 6 1 value type +; +; A value accumulator has the following structure for a string: +; Offset Length Contents +; 0 2 string length +; 2 2 *reserved for string data pointer expansion, must be zero* +; 4 2 string data pointer +; 6 1 value type +; +; Value type constants valtype_none equ 0 ; unknown value type valtype_int equ 1 ; integer (32 bit) value (signed) valtype_float equ 2 ; float type (40 bit) value +valtype_string equ 3 ; string type (16 bit length, 16(32) bit data pointer +; Value accumulator structure definitions +val.type equ 6 ; value type offset +val.fpexp equ 0 ; fp exponent offset +val.fpmant equ 1 ; fp mantissa offset +val.fpsign equ 5 ; fp sign offset +val.int equ 1 ; integer offset +val.strlen equ 0 ; string length offset +val.strptr equ 4 ; string data pointer (low word) +val.size equ 7 ; size of a value accumulator +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ifdef COCO3 ; GIME INIT0 GIME_COCO equ 0x80 ; Set for coco2 compatible mode (video display) @@ -233,18 +273,8 @@ tok_kwnum rmb 1 ; the actual token number tok_kwmatchl rmb 1 ; the length of the best match during lookup tok_kwmatch rmb 2 ; the current best matched token number -val0.type rmb 1 ; type of value in val0 -val0 rmb 0 ; bucket of bytes for val0 -val0.int rmb 0 ; 32 bit signed integer value (val0) -val0.exp rmb 1 ; floating point exponent (val0) -val0.mant rmb 4 ; floating point mantissa (val0) -val0.sign rmb 1 ; floating point sign (val0) -val1.type rmb 1 ; type of value in val1 -val1 rmb 0 ; bucket of bytes for val1 -val1.int rmb 0 ; 32 bit signed integer value (val1) -val1.exp rmb 1 ; floating point exponent (val1) -val1.mant rmb 4 ; floating point mantissa (val1) -val1.sign rmb 1 ; floating point sign (val1) +val0 rmb val.size ; value accumulator 0 +val1 rmb val.size ; value accumulator 1 rmb 0x71-* ; align RSTFLG/RSTVEC for stock ROM compatibility RSTFLG rmb 1 ; 0x55 if RSTVEC is valid RSTVEC rmb 2 ; points to warm start routine (must start with NOP) @@ -1547,7 +1577,7 @@ bne cmd_print0 ; brif not end of the statement rts cmd_print1 jsr eval_expr ; evaluate the expression - ldb val0.type ; get value type + ldb val0+val.type ; get value type cmpb #valtype_int ; integer? beq cmd_printint ; brif so - print integer lda #'! ; flag unknown expression type @@ -1560,15 +1590,9 @@ cmd_printint leas -12,s ; make a buffer leay ,s ; point to buffer lda #0x20 ; default sign (positive) - ldb val0.int ; is it negative? + ldb val0+val.int ; is it negative? bpl cmd_printint0 ; brif not - ldd zero ; - subd val0.int+2 - std val0.int+2 - ldd zero - sbcb val0.int+1 - sbca val0.int - std val0.int + jsr val_negint32 ; negate the integer lda #'- ; negative sign cmd_printint0 sta ,y+ ; save sign ldu #cmd_printintpc ; point to positive constant table @@ -1577,21 +1601,21 @@ cmd_printint1 lda #'0-1 ; initialize digit sta ,y cmd_printint2 inc ,y ; bump digit - ldd val0.int+2 ; subtract constant + ldd val0+val.int+2 ; subtract constant subd 2,u - std val0.int+2 - ldd val0.int + std val0+val.int+2 + ldd val0+val.int sbcb 1,u sbca ,u - std val0.int + std val0+val.int bcc cmd_printint2 ; brif we didn't go negative - ldd val0.int+2 ; undo last subtract + ldd val0+val.int+2 ; undo last subtract addd 2,u - std val0.int+2 - ldd val0.int + std val0+val.int+2 + ldd val0+val.int adcb 1,u adca ,u - std val0.int + std val0+val.int leay 1,y ; move to next digit in buffer leau 4,u ; move to next constant leax -1,x ; done all constants? @@ -1619,8 +1643,6 @@ fqb 100 ; 10^2 fqb 10 ; 10^1 fqb 1 ; 10^0 - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; Error messages ; @@ -1651,6 +1673,8 @@ fcn 'RETURN without GOSUB' deferr ov fcn 'Overflow' + deferr tm + fcn 'Type mismatch' ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ; The LET command which is the default if no token begins a statement cmd_let jmp SNERROR ; not yet implemented @@ -1684,7 +1708,7 @@ eval_expr3 jsr nextchar ; eat the operator token ldx 1,x ; get handler address of this operator pshs x ; save handler address for later - lda val0.type ; get current value type + lda val0+val.type ; get current value type ldx val0 ; get value accumlator contents (6 bytes) ldy val0+2 ldu val0+4 @@ -1694,7 +1718,7 @@ stx val1 ; save it to the second value accumulator sty val1+2 stu val1+4 - sta val1.type ; save previous value type + sta val1+val.type ; save previous value type jsr [,s++] ; go handle the operator puls b ; get back the previous operator precedence bra eval_expr0 ; go process another operator or end of expression @@ -1711,7 +1735,7 @@ eval_term0 jmp SNERROR ; we have something unrecognized - raise error ; Evaluate a number constant. Currently this only handles 32 bit integers. eval_number ldb #valtype_int ; start with integer value - stb val0.type ; set return value + stb val0+val.type ; set return value ldx zero ; blank out the value stx val0 stx val0+2 @@ -1723,7 +1747,7 @@ beq eval_number3 ; brif so cmpa #tok_minus ; negative (operator negative)? bne eval_number2 ; brif not -eval_number3 com val0.sign ; invert sign +eval_number3 com val0+val.fpsign ; invert sign bra eval_number0 ; deal with next input eval_number2 cmpa #'+ ; unary +? beq eval_number0 ; brif so - skip it @@ -1735,59 +1759,53 @@ bhi eval_numberr ; brif above digit suba #'0 ; offset to binary digit value pshs a ; save digit value - ldx val0.int ; get current value for later (for quick multiply by 10) - ldd val0.int+2 + ldx val0+val.int ; get current value for later (for quick multiply by 10) + ldd val0+val.int+2 pshs d,x ; stored with words swapped on stack for efficiency for later - lsl val0.int+3 ; times 2 - rol val0.int+2 - rol val0.int+1 - rol val0.int + lsl val0+val.int+3 ; times 2 + rol val0+val.int+2 + rol val0+val.int+1 + rol val0+val.int bcs OVERROR ; brif overflowed - lsl val0.int+3 ; times 4 - rol val0.int+2 - rol val0.int+1 - rol val0.int + lsl val0+val.int+3 ; times 4 + rol val0+val.int+2 + rol val0+val.int+1 + rol val0+val.int bcs OVERROR ; brif overflowed - ldd val0.int+2 ; times 5 (add original value) + ldd val0+val.int+2 ; times 5 (add original value) addd ,s++ - std val0.int+2 - ldd val0.int + std val0+val.int+2 + ldd val0+val.int adcb 1,s adca ,s++ - std val0.int + std val0+val.int bcs OVERROR - lsl val0.int+3 ; times 10 - rol val0.int+2 - rol val0.int+1 - rol val0.int + lsl val0+val.int+3 ; times 10 + rol val0+val.int+2 + rol val0+val.int+1 + rol val0+val.int bcs OVERROR ; brif overflowed - ldd val0.int+2 ; get low word + ldd val0+val.int+2 ; get low word addb ,s+ ; add in current digit adca #0 - std val0.int+2 - ldd val0.int + std val0+val.int+2 + ldd val0+val.int adcb #0 adca #0 - std val0.int + std val0+val.int bcs OVERROR ; brif overflowed bpl eval_number4 ; brif we haven't wrapped negative cmpd #0x8000 ; is it valid negative two's complement? bhi OVERROR ; brif not - ldd val0.int+2 ; is it still valid two's complement (max negative)? + ldd val0+val.int+2 ; is it still valid two's complement (max negative)? bne OVERROR ; brif so eval_number4 jsr nextchar ; fetch next input character bra eval_number5 ; go handle it OVERROR ldb #err_ov ; flag overflow jmp ERROR -eval_numberr ldb val0.sign ; is the number we want negative? +eval_numberr ldb val0+val.fpsign ; is the number we want negative? beq eval_numberr0 ; brif not - ldd zero ; negate the value - subd val0.int+2 - std val0.int+2 - ldd zero - sbcb val0.int+1 - sbca val0.int - std val0.int + jsr val_negint32 ; negate the integer eval_numberr0 rts eval_float jmp SNERROR ; we don't handle floating point yet ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1841,6 +1859,124 @@ suba #-'0 setcifdigit0 rts ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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 +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; 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: