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 
