09       .OPT NO LIST›10 ;  SAVE #D1:FLOAT1.M65›20 ;›30 ;›40 ;  LOAD #D1:FLOAT2.M65›50 ;›51       .PAGE "Floating Point"›52        LIST  ›53       .LOCAL ›54 ; All inline labels commented›55 ; with B are accessed by BASIC›56 ; Others may be accessed by›57 ; cartridges. ALL labels not shown›58 ; as local (?) may be accessed›59 ; by other programs.›60 ;›61 FPREC =   6       FP precision›62 FMPREC =  5       Mantissa length›63 FR0M  =   FR0+1   fp reg 0 mantissa›64 FR1M  =   FR1+1   reg 1 mantissa›65 FRSIGN =  NSIGN›66 PLYCNT =  ESIGN›67 SGNFLG =  FCHRFLG›68 XFMFLG =  DIGRT›69 QTEMP =   FR0+5›70 FSCR  =   FPSCR›71 FSCR1 =   FPSCR1›0180 ;›0181 ; *= $D800›0182 ;›055296 AFP JSR SKBLANK ; B›055299   JSR ?TSTCHAR See if number›055302   BCS ?NONUM  No exit›055304   LDX #EEXP   zero 4 values›055306   LDY #4›055308   JSR ZXLY›055311   LDX #$FF›055313   STX DIGRT›055315   JSR ZFR0    clear Fr0›055318   BEQ ?IN2    go always›055320 ?IN1 LDA #$FF set 1st char›055322   STA FCHRFLG flag to non0›055324 ?IN2 JSR ?GETCHAR get input char›055327   BCS ?NON1   go if not number›055329   PHA         Save›055330   LDX FR0+1   Get 1st byte›055332   BNE ?INCE   incr exponent›055334   JSR NIBSH0  move Fr0 nybble left›055337   PLA         Get digit›055338   ORA FR0+5   or into last byte›055340   STA FR0+5›055342   LDX DIGRT   chars after point?›055344   BMI ?IN1    None›055346   INX         Add in this char›055347   STX DIGRT   and save›055349   BNE ?IN1    Go get next›055351 ?INCE PLA     Clear stack›055352   LDX DIGRT   Have DP?›055354   BPL ?INCE2  If so skip›055356   INC EEXP    increment exponent›055358 ?INCE2 JMP ?IN1 Get next char›055361 ?NONUM RTS    return fail›055362 ?NON1 CMP #'. Decimal?›055364   BEQ ?DP     Yes, process›055366   CMP #'E     Exponent?›055368   BEQ ?EXP    Yes›055370   LDX FCHRFLG Is this 1st char?›055372   BNE ?EXIT   if not, done›055374   CMP #'+     If +›055376   BEQ ?IN1    go for next›055378   CMP #'-›055380   BEQ ?MINUS›055382 ?MINUS STA NSIGN Save sign›055384   BEQ ?IN1    go for next›055386 ?DP LDX DIGRT is Digrt still $FF?›055388   BPL ?EXIT   If not have DP›055390   INX         Else make it 0›055391   STX DIGRT›055393   BEQ ?IN1    go for next›055395 ?EXP LDA CIX  Get index›055397   STA FRX     save›055399   JSR ?GETCHAR Get next char›055402   BCS ?NON2   Go if nonnumeric›055404 ?EXP2 TAX     Save 1st char›055405   LDA EEXP    Get # of char>9›055407   PHA         Save it›055408   STX EEXP    Save 1st exponent›055410   JSR ?GETCHAR Get next›055413   BCS ?EXP3   Go if not num›055415   PHA         Save second›055416   LDA EEXP    Get 1st digit›055418   ASL A       multiply by 10›055419   STA EEXP›055421   ASL A›055422   ASL A›055423   ADC EEXP›055425   STA EEXP›055427   PLA         Get 2nd digit›055428   CLC ›055429   ADC EEXP›055431   STA EEXP    Save›055433   LDY CIX     Inc to next char›055435   JSR ?GCHR1›055438 ?EXP3 LDA ESIGN Get sign›055440   BEQ ?EXP1   if none is +›055442   LDA EEXP    get exp entered›055444   EOR #$FF    complement›055446   CLC         to make›055447   ADC #1      minus›055449   STA EEXP    and save›055451 ?EXP1 PLA     Get #digits>9›055452   CLC         add in exponent›055453   ADC EEXP›055455   STA EEXP    save it›055457   BNE ?EXIT   go always›055459 ?NON2 CMP #'+ Go if +›055461   BEQ ?EPLUS›055463   CMP #'-     Go if not -›055465   BNE ?NOTE›055467   STA ESIGN   Save exponent sign›055469 ?EPLUS JSR ?GETCHAR›055472   BCC ?EXP2   If number process exp›055474 ?NOTE LDA FRX Point to one past E›055476   STA CIX     restore Cix›055478 ?EXIT DEC CIX Back up 1 char›055480   LDA EEXP    Get exponent›055482   LDX DIGRT   Get # digits past .›055484   BMI ?EXIT1  No DP›055486   BEQ ?EXIT1›055488   SEC         Get exponent-digits›055489   SBC DIGRT   right›055491 ?EXIT1 PHA    Save›055492   ROL A       Set carry with sign›055493   PLA         Get exponent again›055494   ROR A       Shift right›055495   STA EEXP    Save power of 100›055497   BCC ?EVEN   If number even›055499   JSR NIBSH0  Else shift nybble l›055502 ?EVEN LDA EEXP Add $40 for exvess›055504   CLC         ; 64 +4 for norm›055505   ADC #$44›055507   STA FR0     Save as exponent›055509   JSR NORM    Normalize number›055512   BCS ?IND2   Error if carry›055514   LDX NSIGN   Set mantissa sign›055516   BEQ ?INDON  go if +›055518   LDA FR0›055520   ORA #$80    Make minus›055522   STA FR0›055524 ?INDON CLC ›055525 ?IND2 RTS ›055526 FASC JSR INTLBF Point inbuff B›055529   LDA #'0     Stick '0 in front›055531   STA LBPR2   of lbuff›055534   LDA FR0     Get exponent›055536   BEQ ?EXP0   If 0, so is number›055538   AND #$7F    and out sign›055540   CMP #$3F    If less than $3f›055542   BCC ?EFORM  e format required›055544   CMP #$45    also if >$44›055546   BCS ?EFORM›055548   SEC         Not e format, get DP›055549   SBC #$3F    position›055551   JSR ?CVFR0  Convert Fr0 to ascii›055554   JSR ?FNZERO Find last non-0 char›055557   ORA #$80    Set high bit›055559   STA LBUFF,X Store in buffer›055562   LDA LBUFF   Get first char›055565   CMP #'.›055567   BEQ ?FN6    Go if DP›055569   JMP ?FN5›055572 ?FN6 JSR ?DECINB Decr inbuff›055575   JMP ?FN4    Do final adjustment›055578 ?EXP0 LDA #$80+'0 Return›055580   STA LBUFF   ascii 0 + hi bit›055583   RTS ›055584 ?EFORM LDA #1 Get decimal posit›055586   JSR ?CVFR0  Convert to ascii›055589   JSR ?FNZERO kill trailing 0's›055592   INX         bump index›055593   STX CIX     save index to last›055595   LDA FR0     Get exponent›055597   ASL A       times 2›055598   SEC         subtract›055599   SBC #$40*2  excess 64›055601   LDX LBUFF   Get 1st char›055604   CPX #'0     Go if '0›055606   BEQ ?EF1›055608   LDX LBUFF+1 Switch DP and 2nd›055611   LDY LBUFF+2 digit›055614   STX LBUFF+2›055617   STY LBUFF+1›055620   LDX CIX     If cix points to›055622   CPX #2      DP then inc›055624   BNE ?NOINC›055626   INC CIX›055628 ?NOINC CLC ›055629   ADC #1›055631 ?EF1 STA EEXP save exponent›055633   LDA #'E›055635   LDY CIX     get pointer›055637   JSR ?STCHAR›055640   STY CIX     save index›055642   LDA EEXP    Get exponent›055644   BPL ?EPL    Go if +›055646   LDA #0      Complement›055648   SEC         exponent›055649   SBC EEXP›055651   STA EEXP›055653   LDA #'-›055655   BNE ?EF2›055657 ?EPL LDA #'+›055659 ?EF2 JSR ?STCHAR Store char›055662   LDX #0      Set counter for 10's›055664   LDA EEXP    Get exponent›055666 ?EF3 SEC ›055667   SBC #10     sub 10›055669   BCC ?EF4    go if < 0›055671   INX         incr. 10's›055672   BNE ?EF3    go always›055674 ?EF4 CLC      Add back in 10›055675   ADC #10›055677   PHA         save›055678   TXA         get number of 10's›055679   JSR ?STNUM  in exp to buffer›055682   PLA         Get remainder›055683   ORA #$80    set high bit›055685   JSR ?STNUM  St in buffer›055688 ?FN5 LDA LBUFF Get 1st output›055691   CMP #'0     go if not '0›055693   BNE ?FN4›055695   CLC         Add one to inbuff›055696   LDA INBUFF  to point to non-0›055698   ADC #1›055700   STA INBUFF›055702   LDA INBUFF+1›055704   ADC #0›055706   STA INBUFF+1›055708 ?FN4 LDA FR0  Get exponent›055710   BPL ?FADONE Done if +ve›055712   JSR ?DECINB Decr inbuff›055715   LDY #0      Put - in buffer›055717   LDA #'-›055719   STA (INBUFF),Y›055721 ?FADONE RTS ›055722 IFP LDA FR0   Get lsb aka CVIFP B›055724   STA ZTEMP4+1 save as high›055726   LDA FR0+1   get msb›055728   STA ZTEMP4  save s low›055730   JSR ZFR0    clear Fr0›055733   SED         decimal mode›055734   LDY #16     bits in integer›055736 ?IFP1 ASL ZTEMP4+1 Shift lsb›055738   ROL ZTEMP4  shift msb›055739 ; carry set if there was a bit›055740   LDX #3      max is 3 bytes›055742 ?IFP2 LDA FR0,X Double number›055744   ADC FR0,X   and add 1 if›055746   STA FR0,X   carry set›055748   DEX         decr bytes to do›055749   BNE ?IFP2   until done›055751   DEY         decr bit count›055752   BNE ?IFP1›055754   CLD ›055755   LDA #$42    Indicate decimal›055757   STA FR0     after last digit›055759   JMP NORM    normalize›055762 FPI LDA #0    Clear result  B›055764   STA ZTEMP4›055766   STA ZTEMP4+1›055768   LDA FR0     Get exponent›055770   BMI ?ERVAL  error if -ve›055772   CMP #$43    If too big›055774   BCS ?ERVAL  also error›055776   SEC ›055777   SBC #$40    If less than 1›055779   BCC ?ROUND  go test for round›055781   ADC #0      add in carry›055783   ASL A       mult by 2 and›055784   STA ZTEMP1  save as counter›055786 ?FPI1 JSR ILSHFT Shift left once›055789   BCS ?ERVAL  If carry, too big›055791   LDA ZTEMP4  save integer*2›055793   STA ZTEMP3›055795   LDA ZTEMP4+1›055797   STA ZTEMP3+1›055799   JSR ILSHFT  mult by 2›055802   BCS ?ERVAL›055804   JSR ILSHFT  again so *8›055807   BCS ?ERVAL›055809   CLC ›055810   LDA ZTEMP4+1 add in *2›055812   ADC ZTEMP3+1 so we have *10›055814   STA ZTEMP4+1›055816   LDA ZTEMP4›055818   ADC ZTEMP3›055820   STA ZTEMP4›055822   BCS ?ERVAL›055824   JSR ?GETDIG get next digit›055827   CLC         add it in›055828   ADC ZTEMP4+1›055830   STA ZTEMP4+1›055832   LDA ZTEMP4›055834   ADC #0›055836   BCS ?ERVAL  overflow!›055838   STA ZTEMP4›055840   DEC ZTEMP1  digits to do›055842   BNE ?FPI1›055844 ?ROUND JSR ?GETDIG get next›055847   CMP #5      If less<5›055849   BCC ?NR     don't round›055851   CLC ›055852   LDA ZTEMP4+1 Else add 1›055854   ADC #1      to round up›055856   STA ZTEMP4+1›055858   LDA ZTEMP4›055860   ADC #0›055862   STA ZTEMP4›055864 ?NR LDA ZTEMP4+1 Move integer›055866   STA FR0     to Fr0›055868   LDA ZTEMP4›055870   STA FR0+1›055872   CLC         Flag success›055873   RTS ›055874 ?ERVAL SEC    Flag fail›055875   RTS ›055876 ZFR0 LDX #FR0 Pointer  B›055878 ZF1 LDY #6    y=bytes B›055880 ZXLY LDA #0   Called B›055882 ?ZF2 STA 0,X›055884   INX ›055885   DEY ›055886   BNE ?ZF2›055888   RTS ›055889 INTLBF LDA # >LBUFF Init Lbuff B›055891   STA INBUFF+1 intp Inbuff›055893   LDA # <LBUFF›055895   STA INBUFF›055897   RTS ›055898 ILSHFT CLC    Shift integer in›055899   ROL ZTEMP4+1 Ztemp4 left once›055901   ROL ZTEMP4›055903   RTS ›055904 FSUB LDA FR1  Get exponent Fr1 B›055906   EOR #$80    change mantissa sign›055908   STA FR1     and resave›055910 FADD LDA FR1  Get exponent  B›055912   AND #$7F    kill sign bit›055914   STA ZTEMP4  save temporarily›055916   LDA FR0     get exponent Fr0›055918   AND #$7F    kill sign›055920   SEC         subtract exponents›055921   SBC ZTEMP4  if exp(Fr0)>=exp(Fr1)›055923   BPL ?NSWAP  then no swap›055925   LDX #5›055927 ?SWAP LDA FR0,X Swap Fr0/Fr1›055929   LDY FR1,X›055931   STA FR1,X›055933   TYA ›055934   STA FR0,X›055936   DEX ›055937   BPL ?SWAP›055939   BMI FADD    go always›055941 ?NSWAP BEQ ?NALIGN If 0, aligned›055943   CMP #5      difference < #bytes?›055945   BCS ?ADDEND No, result in Fr0›055947   JSR RSHFT1  Shift to align›055950 ?NALIGN SED   Test for like sign›055951   LDA FR0     of mantissa›055953   EOR FR1     If different›055955   BMI ?SUB    subtract›055957   LDX #4      Pointer for last byte›055959   CLC ›055960 ?ADD1 LDA FR0+1,X Add mantissas›055962   ADC FR1+1,X›055964   STA FR0+1,X›055966   DEX ›055967   BPL ?ADD1›055969   CLD ›055970   BCS ?ADD2   If carry, do it›055972 ?ADDEND JMP NORM normalize›055975 ?ADD2 LDA #1  Shift once›055977   JSR RSHFT0  Go do it›055980   LDA #1      Get carry›055982   STA FR0+1   add in›055984   JMP NORM    normalize›055987 ?SUB LDX #4   point last byte›055989   SEC ›055990 ?SUB1 LDA FR0+1,X›055992   SBC FR1+1,X›055994   STA FR0+1,X›055996   DEX ›055997   BPL ?SUB1›055999   BCC ?SUB2   If borrow, do it›056001   CLD ›056002   JMP NORM›056005 ?SUB2 LDA FR0 Get exponent›056007   EOR #$80    flip sign›056009   STA FR0›056011   SEC         Complement mantissa›056012   LDX #4›056014 ?SUB3 LDA #0›056016   SBC FR0+1,X›056018   STA FR0+1,X›056020   DEX ›056021   BPL ?SUB3›056023   CLD ›056024   JMP NORM›056027 FMUL LDA FR0  Get exponent  B›056029   BEQ MEND3›056031   LDA FR1›056033   BEQ MEND2›056035   JSR MDESUP  Common set for exp›056038   SEC ›056039   SBC #$40    remove excess 64›056041   SEC         add 1+›056042   ADC FR1     Fr1 exp to Fr0 exp›056044   BMI ?EROV   if -ve overflow›056046   JSR MDSUP   Common div setup›056049 ?FRM LDA FRE+5 Get last byte Fre›056051   AND #$0F    lsb only›056053   STA ZTEMP2  for loop control›056055 ?FRM1 DEC ZTEMP2›056057   BMI ?FRM2›056059   JSR FRA10   Add Fr1 to Fr0›056062   JMP ?FRM1   repeat›056065 ?FRM2 LDA FRE+5 Get last byte›056067   LSR A       Take msb only›056068   LSR A›056069   LSR A›056070   LSR A›056071   STA ZTEMP2  or loop›056073 ?FRM3 DEC ZTEMP2›056075   BMI ?NXTB›056077   JSR FRA20   Add Fr2 to Fr0›056080   JMP ?FRM3›056083 ?NXTB JSR RSHF0E shift right›056086   DEC ZTEMP1  Test for shifts›056088   BNE ?FRM›056090 MDEND LDA EEXP Get exponent›056092   STA FR0     to Fr0›056094 MEND1 JMP NORM1›056097 MEND2 JSR ZFR0›056100 MEND3 CLC ›056101   RTS ›056102 ?EROV SEC ›056103   RTS ›056104 FDIV LDA FR1  If exponent=0  B›056106   BEQ ?EROV   overflow›056108   LDA FR0     if 0›056110   BEQ MEND3   then done›056112   JSR MDESUP  Common setup›056115   SEC ›056116   SBC FR1     subtract exponents›056118   CLC ›056119   ADC #$40    add in excess 64›056121   BMI ?EROV   overflow if -ve›056123   JSR MDSUP   common mult setup›056126   INC ZTEMP1  loop once more for /›056128   JMP ?FRD1   skip 1st shift›056131 ?NXTQ LDX #0  Shift fr0/fre left 1›056133 ?NXTQ1 LDA FR0+1,X get byte›056135   STA FR0,X   move left one›056137   INX ›056138   CPX #12›056140   BNE ?NXTQ1  til done›056142 ?FRD1 LDY #5›056144   SEC ›056145   SED ›056146 ?FRS2 LDA FRE,Y›056149   SBC FR2,Y›056152   STA FRE,Y›056155   DEY ›056156   BPL ?FRS2›056158   CLD ›056159   BCC ?FAIL   if Fre<Fr2 fail›056161   INC QTEMP   inc #times sub (quot)›056163   BNE ?FRD1›056165 ?FAIL JSR FRA2E Add Fr2 to Fr0›056168   ASL QTEMP   shift last byte›056170   ASL QTEMP   of quotient one›056172   ASL QTEMP   nybble left›056174   ASL QTEMP›056176 ?FRD2 LDY #5  subtract divisor›056178   SEC         from dividend›056179   SED ›056180 ?FRS1 LDA FRE,Y›056183   SBC FR1,Y›056186   STA FRE,Y›056189   DEY ›056190   BPL ?FRS1›056192   CLD ›056193   BCC ?FAIL2›056195   INC QTEMP›056197   BNE ?FRD2›056199 ?FAIL2 JSR FRA1E add Fr1 to Fr0›056202   DEC ZTEMP1  dec loop control›056204   BNE ?NXTQ   next quotient byte›056206   JSR RSHF0E  clear exponent›056209   JMP MDEND   to common exit›056212 ?GETCHAR JSR TSTNUM›056215   LDY CIX›056217   BCC ?GCHR1›056219   LDA (INBUFF),Y›056221 ?GCHR1 INY ›056222   STY CIX›056224   RTS ›056225 SKBLANK LDY CIX aka SKBLANKS B›056227   LDA #32›056229 ?SB1 CMP (INBUFF),Y›056231   BNE ?SBRTS›056233   INY ›056234   BNE ?SB1›056236 ?SBRTS STY CIX set nonblank index›056238   RTS ›056239 TSTNUM LDY CIX see if number B›056241   LDA (INBUFF),Y›056243   SEC ›056244   SBC #'0›056246   BCC ?TSNFAIL›056248   CMP #9+1›056250   RTS ›056251 ?TSTCHAR LDA CIX›056253   PHA ›056254   JSR ?GETCHAR›056257   BCC ?RTPASS›056259   CMP #'.›056261   BEQ ?TSTN›056263   CMP #'+›056265   BEQ ?TSTN1›056267   CMP #'-›056269   BEQ ?TSTN1›056271 ?RTFAIL PLA ›056272 ?TSNFAIL SEC ›056273   RTS ›056274 ?TSTN1 JSR ?GETCHAR›056277   BCC ?RTPASS›056279   CMP #'.›056281   BNE ?RTFAIL›056283 ?TSTN JSR ?GETCHAR›056286   BCC ?RTPASS›056288   BCS ?RTFAIL›056290 ?RTPASS PLA ›056291   STA CIX›056293   CLC ›056294   RTS ›056295 NIBSH2 LDX #FR2+1›056297   BNE ?NIB1›056299 NIBSH0 LDX #FR0+1›056301 ?NIB1 LDY #4›056303 ?NIBS CLC ›056304   ROL 4,X›056306   ROL 3,X›056308   ROL 2,X›056310   ROL 1,X›056312   ROL 0,X›056314   ROL FRX     save shifted nybble›056316   DEY ›056317   BNE ?NIBS›056319   RTS ›