.segment "CODE" TEMP1X = TEMP1+(5-BYTES_FP) ; ---------------------------------------------------------------------------- ; ADD 0.5 TO FAC ; ---------------------------------------------------------------------------- FADDH: lda #CON_HALF jmp FADD ; ---------------------------------------------------------------------------- ; FAC = (Y,A) - FAC ; ---------------------------------------------------------------------------- FSUB: jsr LOAD_ARG_FROM_YA ; ---------------------------------------------------------------------------- ; FAC = ARG - FAC ; ---------------------------------------------------------------------------- FSUBT: lda FACSIGN eor #$FF sta FACSIGN eor ARGSIGN sta SGNCPR lda FAC jmp FADDT ; ---------------------------------------------------------------------------- ; Commodore BASIC V2 Easter Egg ; ---------------------------------------------------------------------------- .ifdef CONFIG_EASTER_EGG EASTER_EGG: lda LINNUM cmp #<6502 bne L3628 lda LINNUM+1 sbc #>6502 bne L3628 sta LINNUM tay lda #$80 sta LINNUM+1 LD758: ldx #$0A LD75A: lda MICROSOFT-1,x and #$3F sta (LINNUM),y iny bne LD766 inc LINNUM+1 LD766: dex bne LD75A dec FORPNT bne LD758 rts .endif ; ---------------------------------------------------------------------------- ; SHIFT SMALLER ARGUMENT MORE THAN 7 BITS ; ---------------------------------------------------------------------------- FADD1: jsr SHIFT_RIGHT bcc FADD3 ; ---------------------------------------------------------------------------- ; FAC = (Y,A) + FAC ; ---------------------------------------------------------------------------- FADD: jsr LOAD_ARG_FROM_YA ; ---------------------------------------------------------------------------- ; FAC = ARG + FAC ; ---------------------------------------------------------------------------- FADDT: bne L365B jmp COPY_ARG_TO_FAC L365B: ldx FACEXTENSION stx ARGEXTENSION ldx #ARG lda ARG FADD2: tay .ifdef KBD beq RTS4 .else beq RTS3 .endif sec sbc FAC beq FADD3 bcc L367F sty FAC ldy ARGSIGN sty FACSIGN eor #$FF adc #$00 ldy #$00 sty ARGEXTENSION ldx #FAC bne L3683 L367F: ldy #$00 sty FACEXTENSION L3683: cmp #$F9 bmi FADD1 tay lda FACEXTENSION lsr 1,x jsr SHIFT_RIGHT4 FADD3: bit SGNCPR bpl FADD4 ldy #FAC cpx #ARG beq L369B ldy #ARG L369B: sec eor #$FF adc ARGEXTENSION sta FACEXTENSION .ifndef CONFIG_SMALL lda 4,y sbc 4,x sta FAC+4 .endif lda 3,y sbc 3,x sta FAC+3 lda 2,y sbc 2,x sta FAC+2 lda 1,y sbc 1,x sta FAC+1 ; ---------------------------------------------------------------------------- ; NORMALIZE VALUE IN FAC ; ---------------------------------------------------------------------------- NORMALIZE_FAC1: bcs NORMALIZE_FAC2 jsr COMPLEMENT_FAC NORMALIZE_FAC2: ldy #$00 tya clc L36C7: ldx FAC+1 bne NORMALIZE_FAC4 ldx FAC+2 stx FAC+1 ldx FAC+3 stx FAC+2 .ifdef CONFIG_SMALL ldx FACEXTENSION stx FAC+3 .else ldx FAC+4 stx FAC+3 ldx FACEXTENSION stx FAC+4 .endif sty FACEXTENSION adc #$08 .ifdef CONFIG_2B ; bugfix? ; fix does not exist on AppleSoft 2 cmp #(MANTISSA_BYTES+1)*8 .else cmp #MANTISSA_BYTES*8 .endif bne L36C7 ; ---------------------------------------------------------------------------- ; SET FAC = 0 ; (ONLY NECESSARY TO ZERO EXPONENT AND SIGN CELLS) ; ---------------------------------------------------------------------------- ZERO_FAC: lda #$00 STA_IN_FAC_SIGN_AND_EXP: sta FAC STA_IN_FAC_SIGN: sta FACSIGN rts ; ---------------------------------------------------------------------------- ; ADD MANTISSAS OF FAC AND ARG INTO FAC ; ---------------------------------------------------------------------------- FADD4: adc ARGEXTENSION sta FACEXTENSION .ifndef CONFIG_SMALL lda FAC+4 adc ARG+4 sta FAC+4 .endif lda FAC+3 adc ARG+3 sta FAC+3 lda FAC+2 adc ARG+2 sta FAC+2 lda FAC+1 adc ARG+1 sta FAC+1 jmp NORMALIZE_FAC5 ; ---------------------------------------------------------------------------- ; FINISH NORMALIZING FAC ; ---------------------------------------------------------------------------- NORMALIZE_FAC3: adc #$01 asl FACEXTENSION .ifndef CONFIG_SMALL rol FAC+4 .endif rol FAC+3 rol FAC+2 rol FAC+1 NORMALIZE_FAC4: bpl NORMALIZE_FAC3 sec sbc FAC bcs ZERO_FAC eor #$FF adc #$01 sta FAC NORMALIZE_FAC5: bcc L3764 NORMALIZE_FAC6: inc FAC beq OVERFLOW .ifndef CONFIG_ROR_WORKAROUND ror FAC+1 ror FAC+2 ror FAC+3 .ifndef CONFIG_SMALL ror FAC+4 .endif ror FACEXTENSION .else lda #$00 bcc L372E lda #$80 L372E: lsr FAC+1 ora FAC+1 sta FAC+1 lda #$00 bcc L373A lda #$80 L373A: lsr FAC+2 ora FAC+2 sta FAC+2 lda #$00 bcc L3746 lda #$80 L3746: lsr FAC+3 ora FAC+3 sta FAC+3 lda #$00 bcc L3752 lda #$80 L3752: lsr FAC+4 ora FAC+4 sta FAC+4 lda #$00 bcc L375E lda #$80 L375E: lsr FACEXTENSION ora FACEXTENSION sta FACEXTENSION .endif L3764: rts ; ---------------------------------------------------------------------------- ; 2'S COMPLEMENT OF FAC ; ---------------------------------------------------------------------------- COMPLEMENT_FAC: lda FACSIGN eor #$FF sta FACSIGN ; ---------------------------------------------------------------------------- ; 2'S COMPLEMENT OF FAC MANTISSA ONLY ; ---------------------------------------------------------------------------- COMPLEMENT_FAC_MANTISSA: lda FAC+1 eor #$FF sta FAC+1 lda FAC+2 eor #$FF sta FAC+2 lda FAC+3 eor #$FF sta FAC+3 .ifndef CONFIG_SMALL lda FAC+4 eor #$FF sta FAC+4 .endif lda FACEXTENSION eor #$FF sta FACEXTENSION inc FACEXTENSION bne RTS12 ; ---------------------------------------------------------------------------- ; INCREMENT FAC MANTISSA ; ---------------------------------------------------------------------------- INCREMENT_FAC_MANTISSA: .ifndef CONFIG_SMALL inc FAC+4 bne RTS12 .endif inc FAC+3 bne RTS12 inc FAC+2 bne RTS12 inc FAC+1 RTS12: rts OVERFLOW: ldx #ERR_OVERFLOW jmp ERROR ; ---------------------------------------------------------------------------- ; SHIFT 1,X THRU 5,X RIGHT ; (A) = NEGATIVE OF SHIFT COUNT ; (X) = POINTER TO BYTES TO BE SHIFTED ; ; RETURN WITH (Y)=0, CARRY=0, EXTENSION BITS IN A-REG ; ---------------------------------------------------------------------------- SHIFT_RIGHT1: ldx #RESULT-1 SHIFT_RIGHT2: .ifdef CONFIG_SMALL ldy 3,x .else ldy 4,x .endif sty FACEXTENSION .ifndef CONFIG_SMALL ldy 3,x sty 4,x .endif ldy 2,x sty 3,x ldy 1,x sty 2,x ldy SHIFTSIGNEXT sty 1,x ; ---------------------------------------------------------------------------- ; MAIN ENTRY TO RIGHT SHIFT SUBROUTINE ; ---------------------------------------------------------------------------- SHIFT_RIGHT: adc #$08 bmi SHIFT_RIGHT2 beq SHIFT_RIGHT2 sbc #$08 tay lda FACEXTENSION bcs SHIFT_RIGHT5 .ifndef CONFIG_ROR_WORKAROUND LB588: asl 1,x bcc LB58E inc 1,x LB58E: ror 1,x ror 1,x ; ---------------------------------------------------------------------------- ; ENTER HERE FOR SHORT SHIFTS WITH NO SIGN EXTENSION ; ---------------------------------------------------------------------------- SHIFT_RIGHT4: ror 2,x ror 3,x .ifndef CONFIG_SMALL ror 4,x .endif ror a iny bne LB588 .else L37C4: pha lda 1,x and #$80 lsr 1,x ora 1,x sta 1,x .byte $24 SHIFT_RIGHT4: pha lda #$00 bcc L37D7 lda #$80 L37D7: lsr 2,x ora 2,x sta 2,x lda #$00 bcc L37E3 lda #$80 L37E3: lsr 3,x ora 3,x sta 3,x lda #$00 bcc L37EF lda #$80 L37EF: lsr 4,x ora 4,x sta 4,x pla php lsr a plp bcc L37FD ora #$80 L37FD: iny bne L37C4 .endif SHIFT_RIGHT5: clc rts ; ---------------------------------------------------------------------------- .ifdef CONFIG_SMALL CON_ONE: .byte $81,$00,$00,$00 POLY_LOG: .byte $02 .byte $80,$19,$56,$62 .byte $80,$76,$22,$F3 .byte $82,$38,$AA,$40 CON_SQR_HALF: .byte $80,$35,$04,$F3 CON_SQR_TWO: .byte $81,$35,$04,$F3 CON_NEG_HALF: .byte $80,$80,$00,$00 CON_LOG_TWO: .byte $80,$31,$72,$18 .else CON_ONE: .byte $81,$00,$00,$00,$00 POLY_LOG: .byte $03 .byte $7F,$5E,$56,$CB,$79 .byte $80,$13,$9B,$0B,$64 .byte $80,$76,$38,$93,$16 .byte $82,$38,$AA,$3B,$20 CON_SQR_HALF: .byte $80,$35,$04,$F3,$34 CON_SQR_TWO: .byte $81,$35,$04,$F3,$34 CON_NEG_HALF: .byte $80,$80,$00,$00,$00 CON_LOG_TWO: .byte $80,$31,$72,$17,$F8 .endif ; ---------------------------------------------------------------------------- ; "LOG" FUNCTION ; ---------------------------------------------------------------------------- LOG: jsr SIGN beq GIQ bpl LOG2 GIQ: jmp IQERR LOG2: lda FAC sbc #$7F pha lda #$80 sta FAC lda #CON_SQR_HALF jsr FADD lda #CON_SQR_TWO jsr FDIV lda #CON_ONE jsr FSUB lda #POLY_LOG jsr POLYNOMIAL_ODD lda #CON_NEG_HALF jsr FADD pla jsr ADDACC lda #CON_LOG_TWO ; ---------------------------------------------------------------------------- ; FAC = (Y,A) * FAC ; ---------------------------------------------------------------------------- FMULT: jsr LOAD_ARG_FROM_YA ; ---------------------------------------------------------------------------- ; FAC = ARG * FAC ; ---------------------------------------------------------------------------- FMULTT: .ifndef CONFIG_11 beq L3903 .else jeq L3903 .endif jsr ADD_EXPONENTS lda #$00 sta RESULT sta RESULT+1 sta RESULT+2 .ifndef CONFIG_SMALL sta RESULT+3 .endif lda FACEXTENSION jsr MULTIPLY1 .ifndef CONFIG_SMALL lda FAC+4 jsr MULTIPLY1 .endif lda FAC+3 jsr MULTIPLY1 lda FAC+2 jsr MULTIPLY1 lda FAC+1 jsr MULTIPLY2 jmp COPY_RESULT_INTO_FAC ; ---------------------------------------------------------------------------- ; MULTIPLY ARG BY (A) INTO RESULT ; ---------------------------------------------------------------------------- MULTIPLY1: bne MULTIPLY2 jmp SHIFT_RIGHT1 MULTIPLY2: lsr a ora #$80 L38A7: tay bcc L38C3 clc .ifndef CONFIG_SMALL lda RESULT+3 adc ARG+4 sta RESULT+3 .endif lda RESULT+2 adc ARG+3 sta RESULT+2 lda RESULT+1 adc ARG+2 sta RESULT+1 lda RESULT adc ARG+1 sta RESULT L38C3: .ifndef CONFIG_ROR_WORKAROUND ror RESULT ror RESULT+1 .ifdef APPLE_BAD_BYTE ; this seems to be a bad byte in the dump .byte RESULT+2,RESULT+2 ; XXX BUG! .else ror RESULT+2 .endif .ifndef CONFIG_SMALL ror RESULT+3 .endif ror FACEXTENSION .else lda #$00 bcc L38C9 lda #$80 L38C9: lsr RESULT ora RESULT sta RESULT lda #$00 bcc L38D5 lda #$80 L38D5: lsr RESULT+1 ora RESULT+1 sta RESULT+1 lda #$00 bcc L38E1 lda #$80 L38E1: lsr RESULT+2 ora RESULT+2 sta RESULT+2 lda #$00 bcc L38ED lda #$80 L38ED: lsr RESULT+3 ora RESULT+3 sta RESULT+3 lda #$00 bcc L38F9 lda #$80 L38F9: lsr FACEXTENSION ora FACEXTENSION sta FACEXTENSION .endif tya lsr a bne L38A7 L3903: rts ; ---------------------------------------------------------------------------- ; UNPACK NUMBER AT (Y,A) INTO ARG ; ---------------------------------------------------------------------------- LOAD_ARG_FROM_YA: sta INDEX sty INDEX+1 ldy #BYTES_FP-1 .ifndef CONFIG_SMALL lda (INDEX),y sta ARG+4 dey .endif lda (INDEX),y sta ARG+3 dey lda (INDEX),y sta ARG+2 dey lda (INDEX),y sta ARGSIGN eor FACSIGN sta SGNCPR lda ARGSIGN ora #$80 sta ARG+1 dey lda (INDEX),y sta ARG lda FAC rts ; ---------------------------------------------------------------------------- ; ADD EXPONENTS OF ARG AND FAC ; (CALLED BY FMULT AND FDIV) ; ; ALSO CHECK FOR OVERFLOW, AND SET RESULT SIGN ; ---------------------------------------------------------------------------- ADD_EXPONENTS: lda ARG ADD_EXPONENTS1: beq ZERO clc adc FAC bcc L393C bmi JOV clc .byte $2C L393C: bpl ZERO adc #$80 sta FAC bne L3947 jmp STA_IN_FAC_SIGN L3947: lda SGNCPR sta FACSIGN rts ; ---------------------------------------------------------------------------- ; IF (FAC) IS POSITIVE, GIVE "OVERFLOW" ERROR ; IF (FAC) IS NEGATIVE, SET FAC=0, POP ONE RETURN, AND RTS ; CALLED FROM "EXP" FUNCTION ; ---------------------------------------------------------------------------- OUTOFRNG: lda FACSIGN eor #$FF bmi JOV ; ---------------------------------------------------------------------------- ; POP RETURN ADDRESS AND SET FAC=0 ; ---------------------------------------------------------------------------- ZERO: pla pla jmp ZERO_FAC JOV: jmp OVERFLOW ; ---------------------------------------------------------------------------- ; MULTIPLY FAC BY 10 ; ---------------------------------------------------------------------------- MUL10: jsr COPY_FAC_TO_ARG_ROUNDED tax beq L3970 clc adc #$02 bcs JOV LD9BF: ldx #$00 stx SGNCPR jsr FADD2 inc FAC beq JOV L3970: rts ; ---------------------------------------------------------------------------- CONTEN: .ifdef CONFIG_SMALL .byte $84,$20,$00,$00 .else .byte $84,$20,$00,$00,$00 .endif ; ---------------------------------------------------------------------------- ; DIVIDE FAC BY 10 ; ---------------------------------------------------------------------------- DIV10: jsr COPY_FAC_TO_ARG_ROUNDED lda #CONTEN ldx #$00 ; ---------------------------------------------------------------------------- ; FAC = ARG / (Y,A) ; ---------------------------------------------------------------------------- DIV: stx SGNCPR jsr LOAD_FAC_FROM_YA jmp FDIVT ; ---------------------------------------------------------------------------- ; FAC = (Y,A) / FAC ; ---------------------------------------------------------------------------- FDIV: jsr LOAD_ARG_FROM_YA ; ---------------------------------------------------------------------------- ; FAC = ARG / FAC ; ---------------------------------------------------------------------------- FDIVT: beq L3A02 jsr ROUND_FAC lda #$00 sec sbc FAC sta FAC jsr ADD_EXPONENTS inc FAC beq JOV ldx #-MANTISSA_BYTES lda #$01 L39A1: ldy ARG+1 cpy FAC+1 bne L39B7 ldy ARG+2 cpy FAC+2 bne L39B7 ldy ARG+3 cpy FAC+3 .ifndef CONFIG_SMALL bne L39B7 ldy ARG+4 cpy FAC+4 .endif L39B7: php rol a bcc L39C4 inx sta RESULT_LAST-1,x beq L39F2 bpl L39F6 lda #$01 L39C4: plp bcs L39D5 L39C7: asl ARG_LAST .ifndef CONFIG_SMALL rol ARG+3 .endif rol ARG+2 rol ARG+1 bcs L39B7 bmi L39A1 bpl L39B7 L39D5: tay .ifndef CONFIG_SMALL lda ARG+4 sbc FAC+4 sta ARG+4 .endif lda ARG+3 sbc FAC+3 sta ARG+3 lda ARG+2 sbc FAC+2 sta ARG+2 lda ARG+1 sbc FAC+1 sta ARG+1 tya jmp L39C7 L39F2: lda #$40 bne L39C4 L39F6: asl a asl a asl a asl a asl a asl a sta FACEXTENSION plp jmp COPY_RESULT_INTO_FAC L3A02: ldx #ERR_ZERODIV jmp ERROR ; ---------------------------------------------------------------------------- ; COPY RESULT INTO FAC MANTISSA, AND NORMALIZE ; ---------------------------------------------------------------------------- COPY_RESULT_INTO_FAC: lda RESULT sta FAC+1 lda RESULT+1 sta FAC+2 lda RESULT+2 sta FAC+3 .ifndef CONFIG_SMALL lda RESULT+3 sta FAC+4 .endif jmp NORMALIZE_FAC2 ; ---------------------------------------------------------------------------- ; UNPACK (Y,A) INTO FAC ; ---------------------------------------------------------------------------- LOAD_FAC_FROM_YA: sta INDEX sty INDEX+1 ldy #MANTISSA_BYTES .ifndef CONFIG_SMALL lda (INDEX),y sta FAC+4 dey .endif lda (INDEX),y sta FAC+3 dey lda (INDEX),y sta FAC+2 dey lda (INDEX),y sta FACSIGN ora #$80 sta FAC+1 dey lda (INDEX),y sta FAC sty FACEXTENSION rts ; ---------------------------------------------------------------------------- ; ROUND FAC, STORE IN TEMP2 ; ---------------------------------------------------------------------------- STORE_FAC_IN_TEMP2_ROUNDED: ldx #TEMP2 .byte $2C ; ---------------------------------------------------------------------------- ; ROUND FAC, STORE IN TEMP1 ; ---------------------------------------------------------------------------- STORE_FAC_IN_TEMP1_ROUNDED: ldx #TEMP1X ldy #$00 beq STORE_FAC_AT_YX_ROUNDED ; ---------------------------------------------------------------------------- ; ROUND FAC, AND STORE WHERE FORPNT POINTS ; ---------------------------------------------------------------------------- SETFOR: ldx FORPNT ldy FORPNT+1 ; ---------------------------------------------------------------------------- ; ROUND FAC, AND STORE AT (Y,X) ; ---------------------------------------------------------------------------- STORE_FAC_AT_YX_ROUNDED: jsr ROUND_FAC stx INDEX sty INDEX+1 ldy #MANTISSA_BYTES .ifndef CONFIG_SMALL lda FAC+4 sta (INDEX),y dey .endif lda FAC+3 sta (INDEX),y dey lda FAC+2 sta (INDEX),y dey lda FACSIGN ora #$7F and FAC+1 sta (INDEX),y dey lda FAC sta (INDEX),y sty FACEXTENSION rts ; ---------------------------------------------------------------------------- ; COPY ARG INTO FAC ; ---------------------------------------------------------------------------- COPY_ARG_TO_FAC: lda ARGSIGN MFA: sta FACSIGN ldx #BYTES_FP L3A7A: lda SHIFTSIGNEXT,x sta EXPSGN,x dex bne L3A7A stx FACEXTENSION rts ; ---------------------------------------------------------------------------- ; ROUND FAC AND COPY TO ARG ; ---------------------------------------------------------------------------- COPY_FAC_TO_ARG_ROUNDED: jsr ROUND_FAC MAF: ldx #BYTES_FP+1 L3A89: lda EXPSGN,x sta SHIFTSIGNEXT,x dex bne L3A89 stx FACEXTENSION RTS14: rts ; ---------------------------------------------------------------------------- ; ROUND FAC USING EXTENSION BYTE ; ---------------------------------------------------------------------------- ROUND_FAC: lda FAC beq RTS14 asl FACEXTENSION bcc RTS14 ; ---------------------------------------------------------------------------- ; INCREMENT MANTISSA AND RE-NORMALIZE IF CARRY ; ---------------------------------------------------------------------------- INCREMENT_MANTISSA: jsr INCREMENT_FAC_MANTISSA bne RTS14 jmp NORMALIZE_FAC6 ; ---------------------------------------------------------------------------- ; TEST FAC FOR ZERO AND SIGN ; ; FAC > 0, RETURN +1 ; FAC = 0, RETURN 0 ; FAC < 0, RETURN -1 ; ---------------------------------------------------------------------------- SIGN: lda FAC beq RTS15 L3AA7: lda FACSIGN SIGN2: rol a lda #$FF bcs RTS15 lda #$01 RTS15: rts ; ---------------------------------------------------------------------------- ; "SGN" FUNCTION ; ---------------------------------------------------------------------------- SGN: jsr SIGN ; ---------------------------------------------------------------------------- ; CONVERT (A) INTO FAC, AS SIGNED VALUE -128 TO +127 ; ---------------------------------------------------------------------------- FLOAT: sta FAC+1 lda #$00 sta FAC+2 ldx #$88 ; ---------------------------------------------------------------------------- ; FLOAT UNSIGNED VALUE IN FAC+1,2 ; (X) = EXPONENT ; ---------------------------------------------------------------------------- FLOAT1: lda FAC+1 eor #$FF rol a ; ---------------------------------------------------------------------------- ; FLOAT UNSIGNED VALUE IN FAC+1,2 ; (X) = EXPONENT ; C=0 TO MAKE VALUE NEGATIVE ; C=1 TO MAKE VALUE POSITIVE ; ---------------------------------------------------------------------------- FLOAT2: lda #$00 .ifndef CONFIG_SMALL sta FAC+4 .endif sta FAC+3 LDB21: stx FAC sta FACEXTENSION sta FACSIGN jmp NORMALIZE_FAC1 ; ---------------------------------------------------------------------------- ; "ABS" FUNCTION ; ---------------------------------------------------------------------------- ABS: lsr FACSIGN rts ; ---------------------------------------------------------------------------- ; COMPARE FAC WITH PACKED # AT (Y,A) ; RETURN A=1,0,-1 AS (Y,A) IS <,=,> FAC ; ---------------------------------------------------------------------------- FCOMP: sta DEST ; ---------------------------------------------------------------------------- ; SPECIAL ENTRY FROM "NEXT" PROCESSOR ; "DEST" ALREADY SET UP ; ---------------------------------------------------------------------------- FCOMP2: sty DEST+1 ldy #$00 lda (DEST),y iny tax beq SIGN lda (DEST),y eor FACSIGN bmi L3AA7 cpx FAC bne L3B0A lda (DEST),y ora #$80 cmp FAC+1 bne L3B0A iny lda (DEST),y cmp FAC+2 bne L3B0A iny .ifndef CONFIG_SMALL lda (DEST),y cmp FAC+3 bne L3B0A iny .endif lda #$7F cmp FACEXTENSION lda (DEST),y sbc FAC_LAST beq L3B32 L3B0A: lda FACSIGN bcc L3B10 eor #$FF L3B10: jmp SIGN2 ; ---------------------------------------------------------------------------- ; QUICK INTEGER FUNCTION ; ; CONVERTS FP VALUE IN FAC TO INTEGER VALUE ; IN FAC+1...FAC+4, BY SHIFTING RIGHT WITH SIGN ; EXTENSION UNTIL FRACTIONAL BITS ARE OUT. ; ; THIS SUBROUTINE ASSUMES THE EXPONENT < 32. ; ---------------------------------------------------------------------------- QINT: lda FAC beq QINT3 sec sbc #120+8*BYTES_FP bit FACSIGN bpl L3B27 tax lda #$FF sta SHIFTSIGNEXT jsr COMPLEMENT_FAC_MANTISSA txa L3B27: ldx #FAC cmp #$F9 bpl QINT2 jsr SHIFT_RIGHT sty SHIFTSIGNEXT L3B32: rts QINT2: tay lda FACSIGN and #$80 lsr FAC+1 ora FAC+1 sta FAC+1 jsr SHIFT_RIGHT4 sty SHIFTSIGNEXT rts ; ---------------------------------------------------------------------------- ; "INT" FUNCTION ; ; USES QINT TO CONVERT (FAC) TO INTEGER FORM, ; AND THEN REFLOATS THE INTEGER. ; ---------------------------------------------------------------------------- INT: lda FAC cmp #120+8*BYTES_FP bcs RTS17 jsr QINT sty FACEXTENSION lda FACSIGN sty FACSIGN eor #$80 rol a lda #120+8*BYTES_FP sta FAC lda FAC_LAST sta CHARAC jmp NORMALIZE_FAC1 QINT3: sta FAC+1 sta FAC+2 sta FAC+3 .ifndef CONFIG_SMALL sta FAC+4 .endif tay RTS17: rts ; ---------------------------------------------------------------------------- ; CONVERT STRING TO FP VALUE IN FAC ; ; STRING POINTED TO BY TXTPTR ; FIRST CHAR ALREADY SCANNED BY CHRGET ; (A) = FIRST CHAR, C=0 IF DIGIT. ; ---------------------------------------------------------------------------- FIN: ldy #$00 ldx #SERLEN-TMPEXP L3B6F: sty TMPEXP,x dex bpl L3B6F bcc FIN2 .ifdef SYM1 cmp #$26 bne LDABB jmp LCDFE LDABB: .endif cmp #$2D bne L3B7E stx SERLEN beq FIN1 L3B7E: cmp #$2B bne FIN3 FIN1: jsr CHRGET FIN2: bcc FIN9 FIN3: cmp #$2E beq FIN10 cmp #$45 bne FIN7 jsr CHRGET bcc FIN5 cmp #TOKEN_MINUS beq L3BA6 cmp #$2D beq L3BA6 cmp #TOKEN_PLUS beq FIN4 cmp #$2B beq FIN4 bne FIN6 L3BA6: .ifndef CONFIG_ROR_WORKAROUND ror EXPSGN .else lda #$00 bcc L3BAC lda #$80 L3BAC: lsr EXPSGN ora EXPSGN sta EXPSGN .endif FIN4: jsr CHRGET FIN5: bcc GETEXP FIN6: bit EXPSGN bpl FIN7 lda #$00 sec sbc EXPON jmp FIN8 ; ---------------------------------------------------------------------------- ; FOUND A DECIMAL POINT ; ---------------------------------------------------------------------------- FIN10: .ifndef CONFIG_ROR_WORKAROUND ror LOWTR .else lda #$00 bcc L3BC9 lda #$80 L3BC9: lsr LOWTR ora LOWTR sta LOWTR .endif bit LOWTR bvc FIN1 ; ---------------------------------------------------------------------------- ; NUMBER TERMINATED, ADJUST EXPONENT NOW ; ---------------------------------------------------------------------------- FIN7: lda EXPON FIN8: sec sbc INDX sta EXPON beq L3BEE bpl L3BE7 L3BDE: jsr DIV10 inc EXPON bne L3BDE beq L3BEE L3BE7: jsr MUL10 dec EXPON bne L3BE7 L3BEE: lda SERLEN bmi L3BF3 rts L3BF3: jmp NEGOP ; ---------------------------------------------------------------------------- ; ACCUMULATE A DIGIT INTO FAC ; ---------------------------------------------------------------------------- FIN9: pha bit LOWTR bpl L3BFD inc INDX L3BFD: jsr MUL10 pla sec sbc #$30 jsr ADDACC jmp FIN1 ; ---------------------------------------------------------------------------- ; ADD (A) TO FAC ; ---------------------------------------------------------------------------- ADDACC: pha jsr COPY_FAC_TO_ARG_ROUNDED pla jsr FLOAT lda ARGSIGN eor FACSIGN sta SGNCPR ldx FAC jmp FADDT ; ---------------------------------------------------------------------------- ; ACCUMULATE DIGIT OF EXPONENT ; ---------------------------------------------------------------------------- GETEXP: lda EXPON cmp #MAX_EXPON bcc L3C2C .ifdef CONFIG_10A lda #$64 .endif bit EXPSGN .ifdef CONFIG_10A bmi L3C3A .else bmi LDC70 .endif jmp OVERFLOW LDC70: .ifndef CONFIG_10A lda #$0B .endif L3C2C: asl a asl a clc adc EXPON asl a clc ldy #$00 adc (TXTPTR),y sec sbc #$30 L3C3A: sta EXPON jmp FIN4 ; ---------------------------------------------------------------------------- .ifdef CONFIG_SMALL ; these values are /1000 of what the labels say CON_99999999_9: .byte $91,$43,$4F,$F8 CON_999999999: .byte $94,$74,$23,$F7 CON_BILLION: .byte $94,$74,$24,$00 .else CON_99999999_9: .byte $9B,$3E,$BC,$1F,$FD CON_999999999: .ifndef CONFIG_10A .byte $9E,$6E,$6B,$27,$FE .else .byte $9E,$6E,$6B,$27,$FD .endif CON_BILLION: .byte $9E,$6E,$6B,$28,$00 .endif ; ---------------------------------------------------------------------------- ; PRINT "IN " ; ---------------------------------------------------------------------------- INPRT: .ifdef KBD jsr LFE0B .byte " in" .byte 0 .else lda #QT_IN jsr GOSTROUT2 .endif lda CURLIN+1 ldx CURLIN ; ---------------------------------------------------------------------------- ; PRINT A,X AS DECIMAL INTEGER ; ---------------------------------------------------------------------------- LINPRT: sta FAC+1 stx FAC+2 ldx #$90 sec jsr FLOAT2 jsr FOUT GOSTROUT2: jmp STROUT ; ---------------------------------------------------------------------------- ; CONVERT (FAC) TO STRING STARTING AT STACK ; RETURN WITH (Y,A) POINTING AT STRING ; ---------------------------------------------------------------------------- FOUT: ldy #$01 ; ---------------------------------------------------------------------------- ; "STR$" FUNCTION ENTERS HERE, WITH (Y)=0 ; SO THAT RESULT STRING STARTS AT STACK-1 ; (THIS IS USED AS A FLAG) ; ---------------------------------------------------------------------------- FOUT1: lda #$20 bit FACSIGN bpl L3C73 lda #$2D L3C73: sta STACK2-1,y sta FACSIGN sty STRNG2 iny lda #$30 ldx FAC bne L3C84 jmp FOUT4 L3C84: lda #$00 cpx #$80 beq L3C8C bcs L3C95 L3C8C: lda #CON_BILLION jsr FMULT .ifdef CONFIG_SMALL lda #-6 ; exponent adjustment .else lda #-9 .endif L3C95: sta INDX ; ---------------------------------------------------------------------------- ; ADJUST UNTIL 1E8 <= (FAC) <1E9 ; ---------------------------------------------------------------------------- L3C97: lda #CON_999999999 jsr FCOMP beq L3CBE bpl L3CB4 L3CA2: lda #CON_99999999_9 jsr FCOMP beq L3CAD bpl L3CBB L3CAD: jsr MUL10 dec INDX bne L3CA2 L3CB4: jsr DIV10 inc INDX bne L3C97 L3CBB: jsr FADDH L3CBE: jsr QINT ; ---------------------------------------------------------------------------- ; FAC+1...FAC+4 IS NOW IN INTEGER FORM ; WITH POWER OF TEN ADJUSTMENT IN TMPEXP ; ; IF -10 < TMPEXP > 1, PRINT IN DECIMAL FORM ; OTHERWISE, PRINT IN EXPONENTIAL FORM ; ---------------------------------------------------------------------------- ldx #$01 lda INDX clc adc #3*BYTES_FP-5 bmi L3CD3 cmp #3*BYTES_FP-4 bcs L3CD4 adc #$FF tax lda #$02 L3CD3: sec L3CD4: sbc #$02 sta EXPON stx INDX txa beq L3CDF bpl L3CF2 L3CDF: ldy STRNG2 lda #$2E iny sta STACK2-1,y txa beq L3CF0 lda #$30 iny sta STACK2-1,y L3CF0: sty STRNG2 ; ---------------------------------------------------------------------------- ; NOW DIVIDE BY POWERS OF TEN TO GET SUCCESSIVE DIGITS ; ---------------------------------------------------------------------------- L3CF2: ldy #$00 LDD3A: ldx #$80 L3CF6: lda FAC_LAST clc .ifndef CONFIG_SMALL adc DECTBL+3,y sta FAC+4 lda FAC+3 .endif adc DECTBL+2,y sta FAC+3 lda FAC+2 adc DECTBL+1,y sta FAC+2 lda FAC+1 adc DECTBL,y sta FAC+1 inx bcs L3D1A bpl L3CF6 bmi L3D1C L3D1A: bmi L3CF6 L3D1C: txa bcc L3D23 eor #$FF adc #$0A L3D23: adc #$2F iny iny iny .ifndef CONFIG_SMALL iny .endif sty VARPNT ldy STRNG2 iny tax and #$7F sta STACK2-1,y dec INDX bne L3D3E lda #$2E iny sta STACK2-1,y L3D3E: sty STRNG2 ldy VARPNT txa eor #$FF and #$80 tax cpy #DECTBL_END-DECTBL .ifdef CONFIG_CBM_ALL beq LDD96 cpy #$3C ; XXX .endif bne L3CF6 ; ---------------------------------------------------------------------------- ; NINE DIGITS HAVE BEEN STORED IN STRING. NOW LOOK ; BACK AND LOP OFF TRAILING ZEROES AND A TRAILING ; DECIMAL POINT. ; ---------------------------------------------------------------------------- LDD96: ldy STRNG2 L3D4E: lda STACK2-1,y dey cmp #$30 beq L3D4E cmp #$2E beq L3D5B iny L3D5B: lda #$2B ldx EXPON beq L3D8F bpl L3D6B lda #$00 sec sbc EXPON tax lda #$2D L3D6B: sta STACK2+1,y lda #$45 sta STACK2,y txa ldx #$2F sec L3D77: inx sbc #$0A bcs L3D77 adc #$3A sta STACK2+3,y txa sta STACK2+2,y lda #$00 sta STACK2+4,y beq L3D94 FOUT4: sta STACK2-1,y L3D8F: lda #$00 sta STACK2,y L3D94: lda #STACK2 rts ; ---------------------------------------------------------------------------- CON_HALF: .ifdef CONFIG_SMALL .byte $80,$00,$00,$00 .else .byte $80,$00,$00,$00,$00 .endif ; ---------------------------------------------------------------------------- ; POWERS OF 10 FROM 1E8 DOWN TO 1, ; AS 32-BIT INTEGERS, WITH ALTERNATING SIGNS ; ---------------------------------------------------------------------------- DECTBL: .ifdef CONFIG_SMALL .byte $FE,$79,$60 ; -100000 .byte $00,$27,$10 ; 10000 .byte $FF,$FC,$18 ; -1000 .byte $00,$00,$64 ; 100 .byte $FF,$FF,$F6 ; -10 .byte $00,$00,$01 ; 1 .else .byte $FA,$0A,$1F,$00 ; -100000000 .byte $00,$98,$96,$80 ; 10000000 .byte $FF,$F0,$BD,$C0 ; -1000000 .byte $00,$01,$86,$A0 ; 100000 .byte $FF,$FF,$D8,$F0 ; -10000 .byte $00,$00,$03,$E8 ; 1000 .byte $FF,$FF,$FF,$9C ; -100 .byte $00,$00,$00,$0A ; 10 .byte $FF,$FF,$FF,$FF ; -1 .endif DECTBL_END: .ifdef CONFIG_CBM_ALL .byte $FF,$DF,$0A,$80 ; TI$ .byte $00,$03,$4B,$C0 .byte $FF,$FF,$73,$60 .byte $00,$00,$0E,$10 .byte $FF,$FF,$FD,$A8 .byte $00,$00,$00,$3C .endif .ifdef CONFIG_2 C_ZERO = CON_HALF + 2 .endif ; ---------------------------------------------------------------------------- ; "SQR" FUNCTION ; ---------------------------------------------------------------------------- SQR: jsr COPY_FAC_TO_ARG_ROUNDED lda #CON_HALF jsr LOAD_FAC_FROM_YA ; ---------------------------------------------------------------------------- ; EXPONENTIATION OPERATION ; ; ARG ^ FAC = EXP( LOG(ARG) * FAC ) ; ---------------------------------------------------------------------------- FPWRT: beq EXP lda ARG bne L3DD5 jmp STA_IN_FAC_SIGN_AND_EXP L3DD5: ldx #TEMP3 ldy #$00 jsr STORE_FAC_AT_YX_ROUNDED lda ARGSIGN bpl L3DEF jsr INT lda #TEMP3 ldy #$00 jsr FCOMP bne L3DEF tya ldy CHARAC L3DEF: jsr MFA tya pha jsr LOG lda #TEMP3 ldy #$00 jsr FMULT jsr EXP pla lsr a bcc L3E0F ; ---------------------------------------------------------------------------- ; NEGATE VALUE IN FAC ; ---------------------------------------------------------------------------- NEGOP: lda FAC beq L3E0F lda FACSIGN eor #$FF sta FACSIGN L3E0F: rts ; ---------------------------------------------------------------------------- .ifdef CONFIG_SMALL CON_LOG_E: .byte $81,$38,$AA,$3B POLY_EXP: .byte $06 .byte $74,$63,$90,$8C .byte $77,$23,$0C,$AB .byte $7A,$1E,$94,$00 .byte $7C,$63,$42,$80 .byte $7E,$75,$FE,$D0 .byte $80,$31,$72,$15 .byte $81,$00,$00,$00 .else CON_LOG_E: .byte $81,$38,$AA,$3B,$29 POLY_EXP: .byte $07 .byte $71,$34,$58,$3E,$56 .byte $74,$16,$7E,$B3,$1B .byte $77,$2F,$EE,$E3,$85 .byte $7A,$1D,$84,$1C,$2A .byte $7C,$63,$59,$58,$0A .byte $7E,$75,$FD,$E7,$C6 .byte $80,$31,$72,$18,$10 .byte $81,$00,$00,$00,$00 .endif ; ---------------------------------------------------------------------------- ; "EXP" FUNCTION ; ; FAC = E ^ FAC ; ---------------------------------------------------------------------------- EXP: lda #CON_LOG_E jsr FMULT lda FACEXTENSION adc #$50 bcc L3E4E jsr INCREMENT_MANTISSA L3E4E: sta ARGEXTENSION jsr MAF lda FAC cmp #$88 bcc L3E5C L3E59: jsr OUTOFRNG L3E5C: jsr INT lda CHARAC clc adc #$81 beq L3E59 sec sbc #$01 pha ldx #BYTES_FP L3E6C: lda ARG,x ldy FAC,x sta FAC,x sty ARG,x dex bpl L3E6C lda ARGEXTENSION sta FACEXTENSION jsr FSUBT jsr NEGOP lda #POLY_EXP jsr POLYNOMIAL lda #$00 sta SGNCPR pla jsr ADD_EXPONENTS1 rts ; ---------------------------------------------------------------------------- ; ODD POLYNOMIAL SUBROUTINE ; ; F(X) = X * P(X^2) ; ; WHERE: X IS VALUE IN FAC ; Y,A POINTS AT COEFFICIENT TABLE ; FIRST BYTE OF COEFF. TABLE IS N ; COEFFICIENTS FOLLOW, HIGHEST POWER FIRST ; ; P(X^2) COMPUTED USING NORMAL POLYNOMIAL SUBROUTINE ; ---------------------------------------------------------------------------- POLYNOMIAL_ODD: sta STRNG2 sty STRNG2+1 jsr STORE_FAC_IN_TEMP1_ROUNDED lda #TEMP1X jsr FMULT jsr SERMAIN lda #TEMP1X ldy #$00 jmp FMULT ; ---------------------------------------------------------------------------- ; NORMAL POLYNOMIAL SUBROUTINE ; ; P(X) = C(0)*X^N + C(1)*X^(N-1) + ... + C(N) ; ; WHERE: X IS VALUE IN FAC ; Y,A POINTS AT COEFFICIENT TABLE ; FIRST BYTE OF COEFF. TABLE IS N ; COEFFICIENTS FOLLOW, HIGHEST POWER FIRST ; ---------------------------------------------------------------------------- POLYNOMIAL: sta STRNG2 sty STRNG2+1 SERMAIN: jsr STORE_FAC_IN_TEMP2_ROUNDED lda (STRNG2),y sta SERLEN ldy STRNG2 iny tya bne L3EBA inc STRNG2+1 L3EBA: sta STRNG2 ldy STRNG2+1 L3EBE: jsr FMULT lda STRNG2 ldy STRNG2+1 clc adc #BYTES_FP bcc L3ECB iny L3ECB: sta STRNG2 sty STRNG2+1 jsr FADD lda #TEMP2 ldy #$00 dec SERLEN bne L3EBE RTS19: rts