Blame | Last modification | View Log | Download | RSS feed
Tue Jul 17 11:00:18 2018 Page 1
2500 A.D. 65816 Macro Assembler #26960 - Version 5.02g
-----------------------------------------------------
Input Filename : src\F8\fpu.asm
Output Filename : obj\F8\fpu.obj
Listing Has Been Relocated
2694 .LIST on
2695
2696 ;;.INCLUDE inc\p0.inc
2697 F8FFB1 .INCLUDE inc\dpfpu.inc
2698 ;;
2699 ;; Copyright (c) 2016 Marco Granati <mg@unet.bz>
2700 ;;
2701 ;; Permission to use, copy, modify, and distribute this software for any
2702 ;; purpose with or without fee is hereby granted, provided that the above
2703 ;; copyright notice and this permission notice appear in all copies.
2704 ;;
2705 ;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
2706 ;; WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
2707 ;; MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
2708 ;; ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
2709 ;; WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
2710 ;; ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
2711 ;; OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
2712 ;;
2713
2714 ;; name: dpfpu.inc
2715 ;; rev.: 2016/03/30
2716 ;; o.s. 65C816 version v1.0
2717
2718 .LIST on
2719
2720 ; direct page for flotaing point unit
2721 _DPFPU: .SECTION page0, common, ref_only, offset 0 ;FPU D.P.
2722
2723 000080 MNTBITS .EQU (16*8) ; significand bits + guard bits
2724 000010 MANTSIZ .EQU 16 ; significand size
2725 000014 FREGSIZ .EQU 20 ; floating point register size
2726
2727 000000 tm .DS 16 ; temp. mantissa
2728
2729 000010 00 fsubnf .DB ; subnormal flag used by fac2dec
2730 000010 atncode .EQU fsubnf ; fatanyx octant
2731
2732 000011 00 sgncmp .DB ; sign comparison: fac vs. arg
2733
2734 ; floating Point accumulator (fac)
2735 000012 facm .DS 16 ; guard bits (32 bits)+significand (80 bits)
2736 000022 0000 facexp .DW ; fac biased exponent
2737 000024 00 facsgn .DB ; fac mantissa sign
2738 000025 00 facst .DB ; fac status for floating point
2739 ; <7>: 1 if fac is invalid (nan or inf)
Tue Jul 17 11:00:18 2018 Page 2
2740 ; <6>: 1 if fac=inf (with <7>=1)
2741 ; 0 if fac=nan (with <7>=1)
2742 ; <6>: 1 if fac=0 (with <7>=0)
2743 ; <5>: always '0'
2744
2745 ; fac status for long integer
2746 ; <7>: 1 if facm will be regarded as 'signed'
2747 ; <6>: 1 if facm = 0
2748 ; <5>: always '1'
2749
2750 000026 0000 fexph .DW ; unbiased fac exponent sign extension
2751 000028 0000 facext .DW ; fac guard bits extension
2752 000028 wftmp2 .EQU facext
2753 000024 facsiz .EQU facsgn ; integer only: size in bytes
2754
2755 ; floating point operand (arg)
2756 00002A argm .DS 16 ; guard bits (32 bits)+significand (80 bits)
2757 00003A 0000 argexp .DW ; arg biased exponent
2758 00003C 00 argsgn .DB ; arg mantissa sign
2759 00003D 00 argst .DB ; arg status for floating point
2760 ; <7>: 1 if arg is invalid (nan or inf)
2761 ; <6>: 1 if arg=inf (with <7>=1)
2762 ; 0 if arg=nan (with <7>=1)
2763 ; <6>: 1 if arg=0 (with <7>=0)
2764
2765 ; arg status for long integer
2766 ; <7>: 1 if facm will be regarded as 'signed'
2767 ; <6>: 1 if facm = 0
2768 ; <5>: always '1'
2769 00003E
2770 00003E 0000 aexph .DW ; unbiased arg exponent sign extension
2771 000040 0000 argext .DW
2772
2773 00003E wftmp .EQU aexph ; temp. word (int2dec, fpadd, fpsub)
2774 00003C argsiz .EQU argsgn ; integer only: size in bytes
2775
2776 000042 fcp LP ; long pointer to flaot constants
2777 000045 00 scsgn .DB ; scaling sign
2778 000046 0000 scexp .DW ; scaling value
2779 000048 0000 dexp .DW ; decimal exponent
2780 00004A 00 dsgn .DB ; decimal float sign
2781 00004B 00 pdeg .DB ; polyn. degree
2782 00004B powfg .EQU pdeg ; flag used by fpowxy
2783
2784 00004C tlp LP ; string long pointer
2785 00004F 00 fpidx .DB ; string index
2786 000050
2787 000050 tfr0 .DS 20 ; temp. float reg. 0
2788 000064 tfr1 .DS 20 ; temp. float reg. 1
2789 000078 tfr2 .DS 20 ; temp. float reg. 2
2790 00008C tfr3 .DS 20 ; temp. float reg. 3
2791 0000A0 tfr4 .DS 20 ; temp. float reg. 4
2792 0000B4 tfr5 .DS 20 ; temp. float reg. 5
2793 0000C8 .DS 4 ; used by xcvt: doesn't change
2794
2795 0000CB XCVTEND .EQU ($ - 1) ; last byte of xcvt buffer
2796
Tue Jul 17 11:00:18 2018 Page 3
2797 ; buffer used by decimal conversion (overlap tfr0&tfr1: 40 bytes)
2798 000050 fpstr .EQU tfr0 ; 40 bytes buffer
2799 ; buffer used to format a decimal string
2800 000078 xcvt .EQU tfr2 ; 84 bytes buffer
2801
2802 0000B4 fcpc0 .EQU tfr5 ; constants pointer for exp. function
2803 0000B6 fcpc1 .EQU tfr5+2
2804 0000B8 fcpc2 .EQU tfr5+4
2805 0000BA fcpp .EQU tfr5+6
2806 0000BC fcpq .EQU tfr5+8
2807 0000BE fcpd .EQU tfr5+10
2808 0000BF fcqd .EQU tfr5+11
2809 0000C0 fcpolf .EQU tfr5+12 ; polynomial flag
2810
2811 0000B4 tmdot .EQU tfr5 ; digit count after decimal dot
2812 0000B6 tmpa .EQU tfr5+2 ; temp: save A&Y
2813 0000B7 tmpy .EQU tfr5+3
2814 0000B8 tmsgn .EQU tfr5+4 ; temp.: significand sign
2815 0000B9 tmcnt .EQU tfr5+5 ; temp.: significand digits count
2816 0000BA tesgn .EQU tfr5+6 ; temp.: exponent sign
2817 0000BB tecnt .EQU tfr5+7 ; temp.: exponent digits count
2818
2819 0000BC mcand1 .EQU tfr5+8 ; multiplicand's
2820 0000BE mcand2 .EQU tfr5+10
2821 0000C0 mcsgn .EQU tfr5+12
2822 0000C2 dvsor .EQU tfr5+14
2823 0000C4 quot .EQU tfr5+16
2824
2825 0000CC 0000 fpprec .DW ; precision
2826 0000CE 00 fpfmt .DB ; format
2827 0000CF 00 fpaltf .DB ; alternate format
2828 0000D0 00 fpcap .DB ; adding for lower case
2829 0000D1 00 fpstyle .DB ; flag 'F' style
2830 00004B fpdot .EQU pdeg ; decimal dot flag
2831 0000CE fpoct .EQU fpfmt ; octant (circular func's)
2832 0000CF fpcsgn .EQU fpaltf ; circular func's: argument sign
2833 0000D0 fpcot .EQU fpcap ; cotangent flag
2834 0000D0 fpasin .EQU fpcap ; asin flag
2835
2836 0000D2 00 dummy .DB
2837
2838 .ENDS
2847 .LIST on
2848
2849 003FFF EBIAS .EQU $3FFF ; exponent bias
2850 007FFF INFEXP .EQU $7FFF ; inf/nan biased exponent
2851 008000 INFSND .EQU $8000 ; infinity high word significand
2852 00C000 NANSND .EQU $C000 ; nan high word significand
2853 007FFE MAXEXP .EQU $7FFE ; max. biased exponent
2854 000071 SNBITS .EQU 113 ; significand bits
2855
2856 004006 BIAS8 .EQU (EBIAS + 7) ; bias exponent for 8 bit integer
2857 00400E BIAS16 .EQU (BIAS8 + 8) ; bias exponent for 16 bit integer
2858 00401E BIAS32 .EQU (BIAS16 + 16) ; bias exponent for 32 bit integer
2859 00403E BIAS64 .EQU (BIAS32 + 32) ; bias exponent for 64 bit integer
2860 00407E BIAS128 .EQU (BIAS64 + 64) ; bias exponent for 128 bit integer
2861 004037 BIAS56 .EQU $4037 ; biased exponent of 2^56
Tue Jul 17 11:00:18 2018 Page 4
2862 ;EM30 .EQU $3F9C ; biased exponent of 1.578e-30
2863 ;EM20 .EQU $3FBD ; biased exponent of about 1e-20
2864 ;EM62 .EQU $3F30 ; biased exponent of about 1e-62
2865 ;EP62 .EQU $40CF ; biased exponent of about 1e62
2866 004D10 LOG2H .EQU 19728 ; approximated log10(2) * $10000
2867 000024 MAXDIGITS .EQU 36 ; max. decimal digits
2868 000026 EXP10 .EQU 38 ; decimal exponent for 128 bits integer
2869 FFFFFC MINGEXP .EQU -4 ; min. decimal exponent 'G' format
2870
2871 FFFF81 MAXBSHIFT .EQU -MNTBITS + 1 ; max. shift mant.
2872
2873 000050 XCVTMAX .EQU 80 ; max. size of decimal string
2874
2875 ;---------------------------------------------------------------------------
2876 ; code segment -- bank $F8
2877 ;---------------------------------------------------------------------------
2878
2879 .CODEF8
2880 .PUBLIC fpmult, ldfac, ldarg, mvftoa, int2dec, frndm, mvatof, scale10, str2fp
2881 .PUBLIC uitrunc, imult, fp2dec, w2dec, fpack, funpack, str2fp2, mvf_t3, mvt3_a
2882 .PUBLIC mvf_t1, mvt1_a, fpadd, fpsub, fpmult, fpdiv, fsqrt, flog10, flog10p1
2883 .PUBLIC fcbrt, floge, flogep1, floor, fexp, fexp10, frexp, fscale, flog2, flog2p1
2884 .PUBLIC fexp2, fexpm1, fpown, mvt1_f, frootn, fldinf, fldz, fpowxy, str2int
2885 .PUBLIC uint2dec, fp2str, fsin, fcos, ftan, fcotan, fasin, facos, fatan
2886 .PUBLIC ftrunc, fround, fceil, ui2dec, fpfrac, fsinh, fcosh, ftanh, fasinh, facosh
2887 .PUBLIC fatanh, fpmod, fprem, fatanyx, int2str
2888
2889 .LONGA off
2890 .LONGI off
2891
2892 ;---------------------------------------------------------------------------
2893 ; addition & subtraction implementation
2894 ;---------------------------------------------------------------------------
2895
2896 ; fcsub - subtract the argument from one constant stored in program memory
2897 ;
2898 ; entry:
2899 ; fac = x
2900 ; A = low address of constant K
2901 ; Y = high address of constant K
2902 ;
2903 ; exit:
2904 ; fac = K - x
2905 ;
2906 ; This routine is used internally and not intended for end use.
2907 ; Constant are stored unpacked, and with full size 128 bits mantissa,
2908 ; in program memory segment(the code segment that hold this routine).
2909 ;
2910 ;-----
2911 F8455C fcsub:
2912 ;-----
2913 F8455C 20 CF 86 jsr ldarg ; move K to arg...
2914 ; ...and execute arg - fac
2915
2916 ; fpsub - subtract fac from arg and store result in fac
2917 ; main subtraction routine
2918 ;
Tue Jul 17 11:00:18 2018 Page 5
2919 ; entry:
2920 ; arg = x
2921 ; fac = y
2922 ; CF = 1 if invalid result(inf or nan)
2923 ;
2924 ; exit:
2925 ; fac = x - y
2926 ;
2927 ;-----
2928 F8455F fpsub:
2929 ;-----
2930 F8455F A5 24 lda facsgn ; change sign to fac...
2931 F84561 49 FF eor #$FF
2932 F84563 85 24 sta facsgn
2933 F84565 80 16 bra fpadd ; and execute arg + (-fac)
2934
2935 ; faddhalf - add 0.5 to the argument
2936 ;
2937 ; entry:
2938 ; fac = x
2939 ;
2940 ; exit:
2941 ; fac = x + 0.5
2942 ;
2943 ; This routine is used internally and not intended for end use.
2944 ;
2945 ;--------
2946 F84567 faddhalf:
2947 ;--------
2948 F84567 20 9F 4E jsr ldahalf ; move constant K=0.5 to arg...
2949 F8456A 80 11 bra fpadd ; ...and execute arg+fac
2950
2951 ; faddone - add 1.0 to the argument
2952 ;
2953 ; entry:
2954 ; fac = x
2955 ;
2956 ; exit:
2957 ; fac = x + 1.0
2958 ;
2959 ; This routine is used internally and not intended for end use.
2960 ;
2961 ;-------
2962 F8456C faddone:
2963 ;-------
2964 F8456C 20 A6 4E jsr ldaone ; move constant K=1.0 to arg...
2965 F8456F 80 0C bra fpadd ; ...and execute arg+fac
2966
2967 ; fsubone - subtract 1.0 from the argument
2968 ;
2969 ; entry:
2970 ; fac = x
2971 ;
2972 ; exit:
2973 ; fac = x - 1.0
2974 ;
2975 ; This routine is used internally and not intended for end use.
Tue Jul 17 11:00:18 2018 Page 6
2976 ;
2977 ;-------
2978 F84571 fsubone:
2979 ;-------
2980 F84571 20 A6 4E jsr ldaone ; move constant K=1.0 to arg...
2981 F84574 A9 FF lda #$FF
2982 F84576 85 3C sta argsgn ; ...change sign to arg...
2983 F84578 80 03 bra fpadd ; ...and execute arg+fac
2984 F8457A
2985 ; fcadd - add the argument to one constant stored in program memory
2986 ;
2987 ; entry:
2988 ; fac = x
2989 ; fcp = long pointer to the constant K
2990 ;
2991 ; exit:
2992 ; fac = K + x
2993 ;
2994 ; This routine is used internally and not intended for end use.
2995 ; Constant are stored unpacked, and with full size 128 bits mantissa,
2996 ; in program memory segment(the code segment that hold this routine).
2997 ;
2998 ;-----
2999 F8457A fcadd:
3000 ;-----
3001 F8457A 20 D7 86 jsr ldarg2 ; move K to arg...
3002 ; ...and execute arg + fac
3003
3004 ; fpadd: add fac to arg and store result in fac
3005 ; main addition routine
3006 ;
3007 ; entry:
3008 ; arg = x
3009 ; fac = y
3010 ;
3011 ; exit:
3012 ; fac = x + y
3013 ; CF = 1 if invalid result(inf or nan)
3014 ;
3015 ; The smallest operand will be aligned shifting to right the mantissa and
3016 ; incrementing the exponent until is equal to exponent of the greatest
3017 ; operand. After alignment, mantissa of fac is added to mantissa of arg if
3018 ; fac and arg have same sign, otherwise mantissa of the smallest operand will
3019 ; be subctracted from mantissa of the greatest one (except in the case that
3020 ; none of the operands has been shifted: in this case maybe need to change
3021 ; sign to result).
3022 ;
3023 ;-----
3024 F8457D fpadd:
3025 ;-----
3026 F8457D 20 41 48 jsr addtst ; operands test: check for inf,nan, 0
3027 F84580 A2 2A ldx #argm ; pointer to arg mantissa
3028 F84582 A0 00 ldy #0
3029 F84584 ACC16
3030 F84584 C2 20 rep #PMFLAG
3031 .LONGA on
3032 .MNLIST
Tue Jul 17 11:00:18 2018 Page 7
3033 F84586 38 sec
3034 F84587 A5 3A lda argexp ; now compute right shift count's to...
3035 F84589 E5 22 sbc facexp ; ...align mantissa's
3036 F8458B F0 2F beq ?go ; already aligned (same exponent)
3037 F8458D 90 0F bcc ?sh ; arg < fac so shift right arg mantissa...
3038 ; ...and result have same exp&sign of fac...
3039 F8458F
3040 ; fac > arg so shift right fac mantissa - here CF=1, Y=0
3041 F8458F 85 3E sta wftmp ; positive shift's count
3042 F84591 A5 3A lda argexp ; result have same exp of arg...
3043 F84593 85 22 sta facexp
3044 F84595 A6 3C ldx argsgn ; ...and same sign of arg
3045 F84597 86 24 stx facsgn
3046 F84599 98 tya ; remember here CF=1
3047 F8459A E5 3E sbc wftmp ; negative shift's count
3048 F8459C A2 12 ldx #facm ; pointer to fac mantissa
3049
3050 ?sh: ; right shift mantissa pointed by X - here C=negative shift's count
3051 F8459E C9 81 FF cmp #MAXBSHIFT ; shift out whole significand?
3052 F845A1 B0 12 bcs ?shm ; no
3053 F845A3 74 00 stz <0,x ; clear mantissa whole mantissa
3054 F845A5 74 02 stz <2,x
3055 F845A7 74 04 stz <4,x
3056 F845A9 74 06 stz <6,x
3057 F845AB 74 08 stz <8,x
3058 F845AD 74 0A stz <10,x
3059 F845AF 74 0C stz <12,x
3060 F845B1 74 0E stz <14,x
3061 F845B3 80 07 bra ?go ; go to add/sub
3062 F845B5
3063 F845B5 ?shm: ACC08 ; A=negative shift's count
3064 F845B5 E2 20 sep #PMFLAG
3065 .LONGA off
3066 .MNLIST
3067 F845B7 20 3A 47 jsr shrmx ; shift right mantissa pointed by X
3068 F845BA ACC16
3069 F845BA C2 20 rep #PMFLAG
3070 .LONGA on
3071 .MNLIST
3072
3073 ; add/sub aligned mantissa's
3074 F845BC A4 11 ?go: ldy sgncmp ; fac & arg have same sign?
3075 F845BE 10 4A bpl ?add ; yes, so add mantissa's
3076
3077 ; X=mantissa pointer (pssibly to the shifted operand)
3078 ; always subtract the smallest operand from the greatest one,
3079 ; except in the case that none of the operands has been shifted
3080
3081 F845C0 A0 12 ldy #facm
3082 F845C2 E0 2A cpx #argm
3083 F845C4 F0 02 beq ?sub ; mantissa_fac - mantissa_arg
3084 F845C6 A0 2A ldy #argm ; mantissa_arg - mantissa_fac
3085 F845C8 38 ?sub: sec
3086 F845C9 B9 00 3F lda P0FPU,y
3087 F845CC F5 00 sbc <0,x
3088 F845CE 85 12 sta facm
3089 F845D0 B9 02 3F lda P0FPU+2,y
Tue Jul 17 11:00:18 2018 Page 8
3090 F845D3 F5 02 sbc <2,x
3091 F845D5 85 14 sta facm+2
3092 F845D7 B9 04 3F lda P0FPU+4,y
3093 F845DA F5 04 sbc <4,x
3094 F845DC 85 16 sta facm+4
3095 F845DE B9 06 3F lda P0FPU+6,y
3096 F845E1 F5 06 sbc <6,x
3097 F845E3 85 18 sta facm+6
3098 F845E5 B9 08 3F lda P0FPU+8,y
3099 F845E8 F5 08 sbc <8,x
3100 F845EA 85 1A sta facm+8
3101 F845EC B9 0A 3F lda P0FPU+10,y
3102 F845EF F5 0A sbc <10,x
3103 F845F1 85 1C sta facm+10
3104 F845F3 B9 0C 3F lda P0FPU+12,y
3105 F845F6 F5 0C sbc <12,x
3106 F845F8 85 1E sta facm+12
3107 F845FA B9 0E 3F lda P0FPU+14,y
3108 F845FD F5 0E sbc <14,x
3109 F845FF 85 20 sta facm+14
3110 F84601 ACC08
3111 F84601 E2 20 sep #PMFLAG
3112 .LONGA off
3113 .MNLIST
3114 F84603 B0 5D bcs normfac ; no borrow -- normalize fac
3115 F84605
3116 ; a borrow mean that result change sign so we should negate mantissa
3117 ; this can happen just when operands have same exponent
3118
3119 F84605 20 04 47 jsr negfac ; negate fac because result change sign
3120 F84608 80 58 bra normfac ; normalize fac
3121 F8460A
3122 F8460A ?add: ACC16CLC ; add fac & arg mantissa's
3123 F8460A C2 21 rep #(PMFLAG.OR.PCFLAG)
3124 .LONGA on
3125 .MNLIST
3126 F8460C A5 12 lda facm
3127 F8460E 65 2A adc argm
3128 F84610 85 12 sta facm
3129 F84612 A5 14 lda facm+2
3130 F84614 65 2C adc argm+2
3131 F84616 85 14 sta facm+2
3132 F84618 A5 16 lda facm+4
3133 F8461A 65 2E adc argm+4
3134 F8461C 85 16 sta facm+4
3135 F8461E A5 18 lda facm+6
3136 F84620 65 30 adc argm+6
3137 F84622 85 18 sta facm+6
3138 F84624 A5 1A lda facm+8
3139 F84626 65 32 adc argm+8
3140 F84628 85 1A sta facm+8
3141 F8462A A5 1C lda facm+10
3142 F8462C 65 34 adc argm+10
3143 F8462E 85 1C sta facm+10
3144 F84630 A5 1E lda facm+12
3145 F84632 65 36 adc argm+12
3146 F84634 85 1E sta facm+12
Tue Jul 17 11:00:18 2018 Page 9
3147 F84636 A5 20 lda facm+14
3148 F84638 65 38 adc argm+14
3149 F8463A 85 20 sta facm+14
3150 F8463C 90 24 bcc normfac ; normalize fac after addition
3151 F8463E
3152 ; the sum generate a carry so we add carry to fac
3153
3154 ; addcf - add a carry to fac
3155 ;
3156 ; fac exponent will be incrementated and mantissa will be shifted
3157 ; one place to right, and '1' is routed to the mantissa msb.
3158 ; Note that this operation can cause overflow
3159 ;
3160 ; This routine is used internally and not intended for end use.
3161 ;
3162 ;-----
3163 F8463E addcf:
3164 ;-----
3165 F8463E ACC16
3166 F8463E C2 20 rep #PMFLAG
3167 .LONGA on
3168 .MNLIST
3169 F84640 A5 22 lda facexp
3170 F84642 1A inc a ; increment exponent
3171 F84643 C9 FF 7F cmp #INFEXP ; overflow?
3172 F84646 90 03 bcc ?10 ; no
3173 F84648 4C 7D 4E jmp fldinf ; yes, so set fac=inf
3174 F8464B 85 22 ?10: sta facexp
3175 F8464D 38 sec ; msb=1
3176 F8464E 66 20 ror facm+14 ; shift right mantissa one place
3177 F84650 66 1E ror facm+12
3178 F84652 66 1C ror facm+10
3179 F84654 66 1A ror facm+8
3180 F84656 66 18 ror facm+6
3181 F84658 66 16 ror facm+4
3182 F8465A 66 14 ror facm+2
3183 F8465C 66 12 ror facm
3184 F8465E ACC08
3185 F8465E E2 20 sep #PMFLAG
3186 .LONGA off
3187 .MNLIST
3188 F84660 18 clc ; return no error condition
3189 F84661 60 rts
3190
3191 ; normfac - try to normalize fac after addition/subtraction or
3192 ; while convert an integer to floting point
3193 ;
3194 ; The msb of mantissa will be '1', except in the case of subnormal.
3195 ; This normalitation is accomplished by shifting toward left
3196 ; the significand until msb=1 or biased exponent=1; at any shift
3197 ; biased exponent is decremented.
3198 ;
3199 ; This routine is used internally and not intended for end use.
3200 ;
3201 ;-------
3202 F84662 normfac:
3203 ;-------
Tue Jul 17 11:00:18 2018 Page 10
3204 F84662 ACC16
3205 F84662 C2 20 rep #PMFLAG
3206 .LONGA on
3207 .MNLIST
3208 F84664 A5 22 lda facexp
3209 F84666 3A dec a ; exp=exp-1
3210 F84667 F0 7D beq chkz ; fac have minimum biased exponent (1)
3211 F84669 38 sec
3212 F8466A A0 10 ldy #MANTSIZ
3213 F8466C A6 21 ?lp: ldx facm+15
3214 F8466E 30 69 bmi ?end ; already normalized: nothing to do
3215 F84670 D0 53 bne ?shb ; shift bit at bit
3216 F84672 E9 08 00 sbc #8 ; can shift a whole byte?
3217 F84675 90 47 bcc ?rst ; no, restore exponent
3218 F84677 A6 20 ldx facm+14 ; shift toward left byte at byte
3219 F84679 86 21 stx facm+15
3220 F8467B A6 1F ldx facm+13
3221 F8467D 86 20 stx facm+14
3222 F8467F A6 1E ldx facm+12
3223 F84681 86 1F stx facm+13
3224 F84683 A6 1D ldx facm+11
3225 F84685 86 1E stx facm+12
3226 F84687 A6 1C ldx facm+10
3227 F84689 86 1D stx facm+11
3228 F8468B A6 1B ldx facm+9
3229 F8468D 86 1C stx facm+10
3230 F8468F A6 1A ldx facm+8
3231 F84691 86 1B stx facm+9
3232 F84693 A6 19 ldx facm+7
3233 F84695 86 1A stx facm+8
3234 F84697 A6 18 ldx facm+6
3235 F84699 86 19 stx facm+7
3236 F8469B A6 17 ldx facm+5
3237 F8469D 86 18 stx facm+6
3238 F8469F A6 16 ldx facm+4
3239 F846A1 86 17 stx facm+5
3240 F846A3 A6 15 ldx facm+3
3241 F846A5 86 16 stx facm+4
3242 F846A7 A6 14 ldx facm+2
3243 F846A9 86 15 stx facm+3
3244 F846AB A6 13 ldx facm+1
3245 F846AD 86 14 stx facm+2
3246 F846AF A6 12 ldx facm
3247 F846B1 86 13 stx facm+1
3248 F846B3 A2 00 ldx #0 ; in last byte enter a zero...
3249 F846B5 86 12 stx facm
3250 F846B7 88 dey ; loop until all bytes was shifted
3251 F846B8 D0 B2 bne ?lp
3252 F846BA 64 22 stz facexp ; at this point fac=0...
3253 F846BC 80 3E bra chkz2 ; ...and set status byte
3254 F846BE 69 08 00 ?rst: adc #8 ; restore exponent...
3255 F846C1 1A inc a
3256 F846C2 3A ?cnt: dec a ; decrement exponent while bit shifting...
3257 F846C3 F0 14 beq ?end ; can't shift more (exponent=1)
3258 F846C5 06 12 ?shb: asl facm ; shift toward left one bit at time
3259 F846C7 26 14 rol facm+2
3260 F846C9 26 16 rol facm+4
Tue Jul 17 11:00:18 2018 Page 11
3261 F846CB 26 18 rol facm+6
3262 F846CD 26 1A rol facm+8
3263 F846CF 26 1C rol facm+10
3264 F846D1 26 1E rol facm+12
3265 F846D3 26 20 rol facm+14
3266 F846D5 10 EB bpl ?cnt ; shift until msb=0
3267 F846D7 30 01 bmi ?end2 ; finish
3268 F846D9 1A ?end: inc a ; restore exponent...
3269 F846DA 85 22 ?end2: sta facexp ; ...and set fac exponent
3270 F846DC C9 FF 7F cmp #INFEXP ; check overflow condition
3271 F846DF 90 05 bcc chkz ; no overflow: chexck if fac=0
3272 F846E1 ACC08
3273 F846E1 E2 20 sep #PMFLAG
3274 .LONGA off
3275 .MNLIST
3276 F846E3 4C 7D 4E jmp fldinf ; set fac=inf
3277
3278 ; chkz - check if fac=0; if fac=0 set the status byte
3279 ;
3280 ; This routine is used internally and not intended for end use.
3281 ;
3282 ;----
3283 F846E6 chkz:
3284 ;----
3285 F846E6 ACC16 ; if all significand bits are '0'...
3286 F846E6 C2 20 rep #PMFLAG
3287 .LONGA on
3288 .MNLIST
3289 F846E8 A5 12 lda facm ; ...then fac=0
3290 F846EA 05 14 ora facm+2
3291 F846EC 05 16 ora facm+4
3292 F846EE 05 18 ora facm+6
3293 F846F0 05 1A ora facm+8
3294 F846F2 05 1C ora facm+10
3295 F846F4 05 1E ora facm+12
3296 F846F6 05 20 ora facm+14
3297 F846F8 D0 06 bne chkz3
3298 F846FA 85 22 sta facexp ; set biased exponent = 0
3299 F846FC A2 40 chkz2: ldx #$40 ; set status byte for 'zero' condition
3300 F846FE 86 25 stx facst
3301 F84700 chkz3: ACC08
3302 F84700 E2 20 sep #PMFLAG
3303 .LONGA off
3304 .MNLIST
3305 F84702 18 clc
3306 F84703 60 rts
3307
3308 ; negfac - negate fac (2's complement)
3309 ;
3310 ; this routine will be called after a subtraction
3311 ; that change the sign of the result
3312 ;
3313 ; This routine is used internally and not intended for end use.
3314 ;
3315 ;------
3316 F84704 negfac:
3317 ;------
Tue Jul 17 11:00:18 2018 Page 12
3318 F84704 A5 24 lda facsgn ; change fac sign
3319 F84706 49 FF eor #$FF
3320 F84708 85 24 sta facsgn
3321 F8470A A2 00 ldx #0
3322 F8470C CPU16 ; two's complement
3323 F8470C C2 30 rep #(PMFLAG.OR.PXFLAG)
3324 .LONGA on
3325 .LONGI on
3326 .MNLIST
3327 F8470E 38 sec
3328 F8470F 8A txa
3329 F84710 E5 12 sbc facm
3330 F84712 85 12 sta facm
3331 F84714 8A txa
3332 F84715 E5 14 sbc facm+2
3333 F84717 85 14 sta facm+2
3334 F84719 8A txa
3335 F8471A E5 16 sbc facm+4
3336 F8471C 85 16 sta facm+4
3337 F8471E 8A txa
3338 F8471F E5 18 sbc facm+6
3339 F84721 85 18 sta facm+6
3340 F84723 8A txa
3341 F84724 E5 1A sbc facm+8
3342 F84726 85 1A sta facm+8
3343 F84728 8A txa
3344 F84729 E5 1C sbc facm+10
3345 F8472B 85 1C sta facm+10
3346 F8472D 8A txa
3347 F8472E E5 1E sbc facm+12
3348 F84730 85 1E sta facm+12
3349 F84732 8A txa
3350 F84733 E5 20 sbc facm+14
3351 F84735 85 20 sta facm+14
3352 F84737 CPU08
3353 F84737 E2 30 sep #(PMFLAG.OR.PXFLAG)
3354 .LONGA off
3355 .LONGI off
3356 .MNLIST
3357 F84739 60 rts
3358
3359 ; shrmx - shift mantissa pointed by X toward right
3360 ;
3361 ; entry: A=negative shift's count (max. 128 bit)
3362 ; X=mantissa pointer
3363 ;
3364 ; exit:
3365 ; mantissa is shifted toward right and 0 will be routed to msb
3366 ;
3367 ; This routine is used internally and not intended for end use.
3368 ;
3369 ;-----
3370 F8473A shrmx:
3371 ;-----
3372 F8473A C9 F9 cmp #$F9 ; NF=1,CF=0 if $79<=A<$F9 else NF=0,CF=1
3373 F8473C 10 76 bpl ?shb ; shift right less than 8 bit (CF=1)
3374 F8473E 80 6A bra ?tst2 ; CF=0, shift at least 8 bit or more
Tue Jul 17 11:00:18 2018 Page 13
3375 F84740 ?sh16: CPU16 ; shift right 16 bit at time
3376 F84740 C2 30 rep #(PMFLAG.OR.PXFLAG)
3377 .LONGA on
3378 .LONGI on
3379 .MNLIST
3380 F84742 B4 02 ldy <2,x
3381 F84744 94 00 sty <0,x
3382 F84746 B4 04 ldy <4,x
3383 F84748 94 02 sty <2,x
3384 F8474A B4 06 ldy <6,x
3385 F8474C 94 04 sty <4,x
3386 F8474E B4 08 ldy <8,x
3387 F84750 94 06 sty <6,x
3388 F84752 B4 0A ldy <10,x
3389 F84754 94 08 sty <8,x
3390 F84756 B4 0C ldy <12,x
3391 F84758 94 0A sty <10,x
3392 F8475A B4 0E ldy <14,x
3393 F8475C 94 0C sty <12,x
3394 F8475E 74 0E stz <14,x
3395 F84760 CPU08
3396 F84760 E2 30 sep #(PMFLAG.OR.PXFLAG)
3397 .LONGA off
3398 .LONGI off
3399 .MNLIST
3400 F84762 80 46 bra ?tst2 ; continue
3401 F84764 69 08 ?tst1: adc #8 ; check if can shift 16 bit at time
3402 F84766 30 D8 bmi ?sh16 ; yes (here CF=0)
3403 F84768 F0 D6 beq ?sh16 ; yes (here CF=1)
3404 F8476A E9 08 sbc #8 ; restore shift count and shift 8 bit at time
3405 ; also note here result is negative and CF=0
3406 F8476C B4 01 ?sh8: ldy <1,x ; shift right 8 bit at time
3407 F8476E 94 00 sty <0,x
3408 F84770 B4 02 ldy <2,x
3409 F84772 94 01 sty <1,x
3410 F84774 B4 03 ldy <3,x
3411 F84776 94 02 sty <2,x
3412 F84778 B4 04 ldy <4,x
3413 F8477A 94 03 sty <3,x
3414 F8477C B4 05 ldy <5,x
3415 F8477E 94 04 sty <4,x
3416 F84780 B4 06 ldy <6,x
3417 F84782 94 05 sty <5,x
3418 F84784 B4 07 ldy <7,x
3419 F84786 94 06 sty <6,x
3420 F84788 B4 08 ldy <8,x
3421 F8478A 94 07 sty <7,x
3422 F8478C B4 09 ldy <9,x
3423 F8478E 94 08 sty <8,x
3424 F84790 B4 0A ldy <10,x
3425 F84792 94 09 sty <9,x
3426 F84794 B4 0B ldy <11,x
3427 F84796 94 0A sty <10,x
3428 F84798 B4 0C ldy <12,x
3429 F8479A 94 0B sty <11,x
3430 F8479C B4 0D ldy <13,x
3431 F8479E 94 0C sty <12,x
Tue Jul 17 11:00:18 2018 Page 14
3432 F847A0 B4 0E ldy <14,x
3433 F847A2 94 0D sty <13,x
3434 F847A4 B4 0F ldy <15,x
3435 F847A6 94 0E sty <14,x
3436 F847A8 74 0F stz <15,x
3437 F847AA 69 08 ?tst2: adc #8 ; test if can shift 8/16 bit at time
3438 F847AC 30 B6 bmi ?tst1 ; test if can shift 16 bit at time (CF=0)
3439 F847AE F0 BC beq ?sh8 ; shift 8 bit (here CF=1)
3440 F847B0 E9 08 sbc #8 ; restore shift count
3441 F847B2 B0 1D bcs ?end ; finish if shift count >= 0
3442 F847B4 A8 ?shb: tay ; residual bit shift count
3443 F847B5 F0 1A beq ?end ; nothing to shift
3444 F847B7 ACC16
3445 F847B7 C2 20 rep #PMFLAG
3446 .LONGA on
3447 .MNLIST
3448 F847B9 B5 00 lda <0,x ; lsb+guard bits
3449 F847BB 56 0E ?sh: lsr <14,x ; msb=0
3450 F847BD 76 0C ror <12,x
3451 F847BF 76 0A ror <10,x
3452 F847C1 76 08 ror <8,x
3453 F847C3 76 06 ror <6,x
3454 F847C5 76 04 ror <4,x
3455 F847C7 76 02 ror <2,x
3456 F847C9 6A ror a ; rotate lsb
3457 F847CA C8 iny
3458 F847CB D0 EE bne ?sh
3459 F847CD 95 00 sta <0,x ; store lsb+guards bits
3460 F847CF ACC08
3461 F847CF E2 20 sep #PMFLAG
3462 .LONGA off
3463 .MNLIST
3464 F847D1 60 ?end: rts
3465
3466 ; shlmx - shift mantissa pointed by X to left until msb of mantissa equal 1
3467 ; and decrement unbiased exponent according with shift's count.
3468 ;
3469 ; this routine is called for 'normalize' a subnormal operand
3470 ;
3471 ; call with A/M in 16 bit mode
3472 ;
3473 ; This routine is used internally and not intended for end use.
3474 ;
3475 ;-----
3476 F847D2 shlmx:
3477 ;-----
3478 .LONGA on ; should be called with A/M=16 bit
3479 .LONGI off
3480
3481 F847D2 38 sec
3482 F847D3 B5 10 lda <16,x ; C=unbiased exponent
3483 F847D5 B4 0F ?lp1: ldy <15,x ; shift count < 8?
3484 F847D7 D0 5D bne ?sh ; yes
3485 F847D9 E9 08 00 sbc #8 ; 8 bits shift
3486 F847DC B4 0E ldy <14,x ; shift toward left byte at byte
3487 F847DE 94 0F sty <15,x
3488 F847E0 B4 0D ldy <13,x
Tue Jul 17 11:00:18 2018 Page 15
3489 F847E2 94 0E sty <14,x
3490 F847E4 B4 0C ldy <12,x
3491 F847E6 94 0D sty <13,x
3492 F847E8 B4 0B ldy <11,x
3493 F847EA 94 0C sty <12,x
3494 F847EC B4 0A ldy <10,x
3495 F847EE 94 0B sty <11,x
3496 F847F0 B4 09 ldy <9,x
3497 F847F2 94 0A sty <10,x
3498 F847F4 B4 08 ldy <8,x
3499 F847F6 94 09 sty <9,x
3500 F847F8 B4 07 ldy <7,x
3501 F847FA 94 08 sty <8,x
3502 F847FC B4 06 ldy <6,x
3503 F847FE 94 07 sty <7,x
3504 F84800 B4 05 ldy <5,x
3505 F84802 94 06 sty <6,x
3506 F84804 B4 04 ldy <4,x
3507 F84806 94 05 sty <5,x
3508 F84808 B4 03 ldy <3,x
3509 F8480A 94 04 sty <4,x
3510 F8480C B4 02 ldy <2,x
3511 F8480E 94 03 sty <3,x
3512 F84810 B4 01 ldy <1,x
3513 F84812 94 02 sty <2,x
3514 F84814 B4 00 ldy <0,x
3515 F84816 94 01 sty <1,x
3516 F84818 A0 00 ldy #0
3517 F8481A 94 00 sty <0,x
3518 F8481C C9 81 FF cmp #MAXBSHIFT ; shifted all whole mantissa?
3519 F8481F F0 17 beq ?done ; yes, store exponent
3520 F84821 B0 B2 bcs ?lp1 ; no, try again
3521 F84823 80 13 bra ?done ; store exponent
3522 F84825 3A ?lp2: dec a ; decrement exponent
3523 F84826 16 00 asl <0,x
3524 F84828 36 02 rol <2,x
3525 F8482A 36 04 rol <4,x
3526 F8482C 36 06 rol <6,x
3527 F8482E 36 08 rol <8,x
3528 F84830 36 0A rol <10,x
3529 F84832 36 0C rol <12,x
3530 F84834 36 0E rol <14,x
3531 F84836 10 ED ?sh: bpl ?lp2 ; if msb=0 shift to left one place
3532 F84838 95 10 ?done: sta <16,x ; store exponent
3533 F8483A 34 10 bit <16,x ; check exponent sign
3534 F8483C 10 02 bpl ?end
3535 F8483E D6 14 dec <20,x ; sign extension to 32 bit
3536 F84840 60 ?end: rts
3537
3538 .LONGA off
3539
3540 ; addtst - test operands before to execute addition/subtraction
3541 ;
3542 ; This routine test fac & arg for validity, and return to the caller
3543 ; for any abnormal condition:
3544 ;
3545 ; 1) return nan if fac=nan or arg=nan
Tue Jul 17 11:00:18 2018 Page 16
3546 ; 2) return nan if |fac|=|arg|=inf and arg&fac have opposites sign
3547 ; 3) return +inf or -inf if fac=arg=+/-inf
3548 ; 4) return +inf or -inf if fac=+/-inf and arg is valid
3549 ; 5) return +inf or -inf if arg=+/-inf and fac is valid
3550 ;
3551 ; This routine is used internally and not intended for end use.
3552 ;
3553 ;------
3554 F84841 addtst:
3555 ;------
3556 F84841 A5 24 lda facsgn ; compare sign
3557 F84843 45 3C eor argsgn
3558 F84845 85 11 sta sgncmp
3559 F84847 38 sec ; invalid result flag
3560 F84848 24 25 bit facst ; test fac
3561 F8484A 10 11 bpl ?arg ; fac is valid, go to check arg
3562 F8484C 50 1D bvc ?skp ; fac=nan so result=nan (fac sign)
3563 F8484E 24 3D bit argst ; fac=inf so check arg
3564 F84850 10 19 bpl ?skp ; fac=inf & arg=y so result=inf (fac sign)
3565 F84852 50 14 bvc ?mv ; fac=inf & arg=nan so result=nan (arg sign)
3566 F84854 24 11 bit sgncmp ; fac=inf & arg=inf so check sign comparison
3567 F84856 10 13 bpl ?skp ; same sign so result=inf (fac sign)
3568 F84858 20 74 4E jsr fldnan ; mismatch signs so result=nan (fac sign)
3569 F8485B 80 0E bra ?skp ; skip resturn & exit with CF=1
3570 F8485D 24 3D ?arg: bit argst ; fac is valid, so now check arg
3571 F8485F 30 07 bmi ?mv ; arg=inf/nan so result=inf/nan (arg sign)
3572 F84861 18 clc ; now result is valid
3573 F84862 70 07 bvs ?skp ; arg=0 so result=fac
3574 F84864 24 25 bit facst ; fac=0?
3575 F84866 50 05 bvc ?end ; no, return to add/sub operation
3576 F84868 20 0C 84 ?mv: jsr mvatof ; move arg to fac (preserve CF)
3577 F8486B 68 ?skp: pla ; skip return address
3578 F8486C 68 pla
3579 F8486D 60 ?end: rts
3580
3581 ;---------------------------------------------------------------------------
3582 ; multiplication & division implementation - scaling routines
3583 ;---------------------------------------------------------------------------
3584
3585 ; frexp - extracts the exponent from x. It returns an integer
3586 ; power of two to scexp and the significand between 0.5 and 1 to fac
3587 ;
3588 ; entry:
3589 ; fac = x (valid float)
3590 ;
3591 ; exit:
3592 ; fac = y (0.5 <= y < 1)
3593 ; scexp = N, exponent (signed integer)
3594 ; scsgn = sign of N
3595 ; dexp = |N| (absolute value of N)
3596 ;
3597 ; note that:
3598 ; N
3599 ; x = y * 2
3600 ;
3601 ;-----
3602 F8486E frexp:
Tue Jul 17 11:00:18 2018 Page 17
3603 ;-----
3604 F8486E 38 sec
3605 F8486F 24 25 bit facst
3606 F84871 30 43 bmi ?end ; invalid fac
3607 F84873 ACC16
3608 F84873 C2 20 rep #PMFLAG
3609 .LONGA on
3610 .MNLIST
3611 F84875 64 46 stz scexp
3612 F84877 64 48 stz dexp
3613 F84879 64 3E stz wftmp
3614 F8487B A2 00 ldx #0 ; assume positive sign
3615 F8487D A5 22 lda facexp
3616 F8487F F0 30 beq ?s ; fac=0 so return exponent=0
3617 F84881 3A dec a ; subnormal?
3618 F84882 D0 14 bne ?fn ; no
3619 F84884 A6 21 ldx facm+15
3620 F84886 30 10 bmi ?fn ; fac is norml
3621 F84888 85 22 sta facexp ; clear to get negative exponent of subnormal
3622 F8488A A2 12 ldx #facm
3623 F8488C 20 D2 47 jsr shlmx ; normalize subnormal fac
3624 F8488F A5 22 lda facexp
3625 F84891 85 3E sta wftmp ; negative exponent of subnormal
3626 F84893 A9 01 00 lda #1 ; restore biased exponent
3627 F84896 85 22 sta facexp
3628 F84898 38 ?fn: sec ; scale a normal f.p.
3629 F84899 A5 22 lda facexp
3630 F8489B E9 FE 3F sbc #EBIAS-1 ; new biased exponent
3631 F8489E 18 clc
3632 F8489F 65 3E adc wftmp ; any subnormal negative exponent
3633 F848A1 85 46 sta scexp
3634 F848A3 10 05 bpl ?p
3635 F848A5 CA dex
3636 F848A6 49 FF FF eor #$FFFF
3637 F848A9 1A inc a ; return absolute value too
3638 F848AA 85 48 ?p: sta dexp
3639 F848AC A9 FE 3F lda #EBIAS-1
3640 F848AF 85 22 sta facexp ; now 0.5 <= fac < 1
3641 F848B1 86 45 ?s: stx scsgn ; exponent sign
3642 F848B3 ACC08
3643 F848B3 E2 20 sep #PMFLAG
3644 .LONGA off
3645 .MNLIST
3646 F848B5 18 clc
3647 F848B6 60 ?end: rts
3648
3649 ; fscale - multiplies argument by a power of two
3650 ;
3651 ; entry:
3652 ; fac = x (valid float)
3653 ; scexp = N (signed integer)
3654 ;
3655 ; exit:
3656 ; N
3657 ; fac = x * 2
3658 ; CF = 1 if invalid result(inf or nan)
3659 ;
Tue Jul 17 11:00:18 2018 Page 18
3660 ;------
3661 F848B7 fscale:
3662 ;------
3663 F848B7 38 sec ; invalid fac flag
3664 F848B8 24 25 bit facst
3665 F848BA 30 48 bmi ?end2 ; fac is invalid
3666 F848BC 70 45 bvs ?end1 ; fac=0
3667 F848BE ACC16
3668 F848BE C2 20 rep #PMFLAG
3669 .LONGA on
3670 .MNLIST
3671 F848C0 A5 46 lda scexp
3672 F848C2 F0 3D beq ?end ; scale factor = 0
3673 F848C4 A5 22 lda facexp
3674 F848C6 3A dec a
3675 F848C7 D0 41 bne ?fn ; fac is normal
3676 F848C9 A6 21 ldx facm+15
3677 F848CB 30 3D bmi ?fn ; fac is normal
3678 F848CD A5 46 lda scexp
3679 F848CF 10 18 bpl ?ps ; positive scaling of subnormal
3680 F848D1 30 07 bmi ?ns ; negative scaling of subnormal
3681 F848D3 A5 22 ?sn: lda facexp
3682 F848D5 64 22 ?sn2: stz facexp ; set biased exponent=1
3683 F848D7 E6 22 inc facexp
3684 F848D9 3A dec a ; count of right shift
3685 F848DA C9 81 FF ?ns: cmp #MAXBSHIFT
3686 F848DD 90 26 bcc ?z ; return fac=0
3687 F848DF ACC08
3688 F848DF E2 20 sep #PMFLAG
3689 .LONGA off
3690 .MNLIST
3691 F848E1 A2 12 ldx #facm ; shift right
3692 F848E3 20 3A 47 jsr shrmx
3693 F848E6 4C E6 46 jmp chkz ; underflow test
3694 .LONGA on
3695 F848E9 A6 21 ?ps: ldx facm+15 ; shift subnormal toward left
3696 F848EB 30 1D bmi ?fn
3697 F848ED 06 12 asl facm
3698 F848EF 26 14 rol facm+2
3699 F848F1 26 16 rol facm+4
3700 F848F3 26 18 rol facm+6
3701 F848F5 26 1A rol facm+8
3702 F848F7 26 1C rol facm+10
3703 F848F9 26 1E rol facm+12
3704 F848FB 26 20 rol facm+14
3705 F848FD C6 46 dec scexp
3706 F848FF D0 E8 bne ?ps
3707 F84901 ?end: ACC08 ; return
3708 F84901 E2 20 sep #PMFLAG
3709 .LONGA off
3710 .MNLIST
3711 F84903 18 ?end1: clc
3712 F84904 60 ?end2: rts
3713 F84905 ?z: ACC08 ; return fac=0
3714 F84905 E2 20 sep #PMFLAG
3715 .LONGA off
3716 .MNLIST
Tue Jul 17 11:00:18 2018 Page 19
3717 F84907 4C 56 4E jmp fldz
3718 .LONGA on
3719 F8490A 64 3E ?fn: stz wftmp ; 32 bit exponent sign extension
3720 F8490C A5 46 lda scexp
3721 F8490E 10 02 bpl ?p
3722 F84910 C6 3E dec wftmp ; scexp is negative
3723 F84912 18 ?p: clc
3724 F84913 A5 22 lda facexp
3725 F84915 65 46 adc scexp
3726 F84917 85 22 sta facexp
3727 F84919 A9 00 00 lda #0
3728 F8491C 65 3E adc wftmp ; can be just negative or null
3729 F8491E 30 B3 bmi ?sn ; handle subnormal result
3730 F84920 A5 22 lda facexp
3731 F84922 F0 B1 beq ?sn2 ; handle subnormal result
3732 F84924 C9 FF 7F cmp #INFEXP ; overflow?
3733 F84927 90 D8 bcc ?end ; no
3734 F84929 ACC08
3735 F84929 E2 20 sep #PMFLAG
3736 .LONGA off
3737 .MNLIST
3738 F8492B 4C 7D 4E jmp fldinf
3739
3740 .LONGA off
3741 F8492E
3742 ; scale10 - multiplies argument by a power of ten
3743 ;
3744 ; entry:
3745 ; fac = x (valid float)
3746 ; C = N (signed integer)
3747 ;
3748 ; exit:
3749 ; N
3750 ; fac = x * 10
3751 ; CF = 1 if invalid result(inf or nan)
3752 ;
3753 ; A lookup table is used for values from 10 through 10^7,
3754 ; then this is augmented by multiplying with table entries
3755 ; for 10^8/16/32/64/128/256/512/1024/2048/4096 which allows
3756 ; any power up. Negative powers are provided by a final division.
3757 ;
3758 ;-------
3759 F8492E scale10:
3760 ;-------
3761 F8492E 38 sec
3762 F8492F 24 25 bit facst ; valid fac?
3763 F84931 30 48 bmi ?end2 ; no, exit
3764 F84933 70 45 bvs ?end1 ; fac=0, exit
3765 F84935 ACC16
3766 F84935 C2 20 rep #PMFLAG
3767 .LONGA on
3768 .MNLIST
3769 F84937 C9 00 00 cmp #0
3770 F8493A F0 3C beq ?end ; scaling exponent=0 so exit
3771 F8493C 85 46 sta scexp ; scaling exponent
3772 F8493E A2 00 ldx #0
3773 F84940 A4 47 ldy scexp+1 ; test sign
Tue Jul 17 11:00:18 2018 Page 20
3774 F84942 10 07 bpl ?pe ; positive exponent
3775 F84944 8A txa ; change sign
3776 F84945 CA dex
3777 F84946 38 sec
3778 F84947 E5 46 sbc scexp
3779 F84949 85 46 sta scexp
3780 F8494B 86 45 ?pe: stx scsgn ; store sign
3781 F8494D C9 00 10 ?lp1: cmp #4096 ; loop for big scaling
3782 F84950 ACC08
3783 F84950 E2 20 sep #PMFLAG
3784 .LONGA off
3785 .MNLIST
3786 F84952 90 28 bcc ?sc ; scaling<4096
3787 F84954 A9 31 lda #<fce4096
3788 F84956 A0 60 ldy #>fce4096
3789 F84958 24 45 bit scsgn ; if negative svaling...
3790 F8495A 30 07 bmi ?div ; ...divide...
3791 F8495C 20 D5 49 jsr fcmult ; ...else multiplies by 4096
3792 F8495F B0 1A bcs ?end2 ; overflow, so exit
3793 F84961 90 09 bcc ?cnt ; continue
3794 F84963 20 0A 4A ?div: jsr fcrdiv ; divide by 4096
3795 F84966 B0 13 bcs ?end2
3796 F84968 24 25 bit facst ; if fac=0 exit
3797 F8496A 70 0F bvs ?end2
3798 F8496C ?cnt: ACC16 ; update scaling factor...
3799 F8496C C2 20 rep #PMFLAG
3800 .LONGA on
3801 .MNLIST
3802 F8496E 38 sec
3803 F8496F A5 46 lda scexp
3804 F84971 E9 00 10 sbc #4096 ; ...subtracting 4096...
3805 F84974 85 46 sta scexp
3806 F84976 D0 D5 bne ?lp1 ;...and repeat
3807 F84978 ?end: ACC08
3808 F84978 E2 20 sep #PMFLAG
3809 .LONGA off
3810 .MNLIST
3811 F8497A 18 ?end1: clc
3812 F8497B 60 ?end2: rts
3813 F8497C 20 66 84 ?sc: jsr mvf_t0 ; save fac (tfr0=fac) in temp. reg.
3814 F8497F A5 46 lda scexp ; now decomposes scexp in factor...
3815 F84981 29 07 and #7 ; this for component from 1 to 1e7
3816 F84983 0A asl a
3817 F84984 AA tax
3818 F84985 BF 44 60 F8 lda >fcaddr+1,x
3819 F84989 A8 tay
3820 F8498A BF 43 60 F8 lda >fcaddr,x
3821 F8498E 20 82 86 jsr ldfac ; load fac with a constant from 1.0 to 1.0e7
3822 F84991 CPU16
3823 F84991 C2 30 rep #(PMFLAG.OR.PXFLAG)
3824 .LONGA on
3825 .LONGI on
3826 .MNLIST
3827 F84993 A9 8F 5F lda #!fce8 ; now find the high order factor...
3828 F84996 85 42 sta fcp ; ...from 1.0e8 to 1.0e2048
3829 F84998 A5 46 lda scexp
3830 F8499A 4A lsr a ; divide by 8
Tue Jul 17 11:00:18 2018 Page 21
3831 F8499B 4A lsr a
3832 F8499C 4A lsr a
3833 F8499D F0 22 beq ?done ; if = 0 we are done
3834 F8499F 4A ?lp2: lsr a ; divide by 2 high order bits
3835 F849A0 90 14 bcc ?nxt ; if even load next constant
3836 F849A2 85 46 sta scexp ; save scale
3837 F849A4 CPU08
3838 F849A4 E2 30 sep #(PMFLAG.OR.PXFLAG)
3839 .LONGA off
3840 .LONGI off
3841 .MNLIST
3842 F849A6 20 DA 49 jsr fcmult2 ; multiplies by constant
3843 F849A9 90 07 bcc ?ok
3844 F849AB 24 45 bit scsgn
3845 F849AD 10 CC bpl ?end2 ; overflow: fac=inf
3846 F849AF 4C 56 4E jmp fldz ; underflow: fac=0
3847 F849B2 ?ok: CPU16
3848 F849B2 C2 30 rep #(PMFLAG.OR.PXFLAG)
3849 .LONGA on
3850 .LONGI on
3851 .MNLIST
3852 F849B4 A5 46 lda scexp
3853 F849B6 AA ?nxt: tax ; update pointer to next constant
3854 F849B7 A5 42 lda fcp
3855 F849B9 69 12 00 adc #FCSIZ
3856 F849BC 85 42 sta fcp
3857 F849BE 8A txa
3858 F849BF D0 DE bne ?lp2 ; loop
3859 F849C1 ?done: CPU08
3860 F849C1 E2 30 sep #(PMFLAG.OR.PXFLAG)
3861 .LONGA off
3862 .LONGI off
3863 .MNLIST
3864 F849C3 20 CE 85 jsr mvt0_a ; move temp. reg. tfr0 to arg
3865 F849C6 24 45 bit scsgn
3866 F849C8 30 46 bmi fpdiv ; if negative scaling we divide arg by fac
3867 F849CA 80 11 bra fpmult ; if positive scaling we multiplies arg by fac
3868
3869 ; fsquare - return the square of the argument
3870 ;
3871 ; entry:
3872 ; fac = x
3873 ;
3874 ; exit: 2
3875 ; fac = x
3876 ; CF = 1 if invalid result(inf or nan)
3877 ;
3878 ;-------
3879 F849CC fsquare:
3880 ;-------
3881 F849CC 20 39 84 jsr mvftoa ; move fac to arg
3882 F849CF 80 0C bra fpmult ; fac*fac
3883
3884 ; mult10 - multiplies the argument with 10.0
3885 ;
3886 ; entry:
3887 ; fac = x
Tue Jul 17 11:00:18 2018 Page 22
3888 ;
3889 ; exit:
3890 ; fac = x * 10
3891 ;
3892 ; This routine is used internally and not intended for end use.
3893 ;
3894 ;------
3895 F849D1 mult10:
3896 ;------
3897 F849D1 A9 11 lda #<fce1 ; address of constant = 10.0
3898 F849D3 A0 5F ldy #>fce1
3899
3900 ; fcmult - multiplies the argument with one constant stored in program memory
3901 ;
3902 ; entry:
3903 ; fac = x
3904 ; A = low address of constant K
3905 ; Y = high address of constant K
3906 ;
3907 ; exit:
3908 ; fac = K * x
3909 ;
3910 ; This routine is used internally and not intended for end use.
3911 ; Constant are stored unpacked, and with full size 128 bits mantissa,
3912 ; in program memory segment(the code segment that hold this routine).
3913 ;
3914 ;------
3915 F849D5 fcmult:
3916 ;------
3917 F849D5 20 CF 86 jsr ldarg ; load arg with constant K
3918 F849D8 80 03 bra fpmult ; execute multiplication
3919
3920 ; fcmult2 - multiplies the argument with one constant stored in program memory
3921 ;
3922 ; entry:
3923 ; fac = x
3924 ; fcp = long pointer to constant K
3925 ;
3926 ; exit:
3927 ; fac = K * x
3928 ;
3929 ; This routine is used internally and not intended for end use.
3930 ; Constant are stored unpacked, and with full size 128 bits mantissa,
3931 ; in program memory segment(the code segment that hold this routine).
3932 ;
3933 ;-------
3934 F849DA fcmult2:
3935 ;-------
3936 F849DA 20 D7 86 jsr ldarg2 ; load arg with constant K
3937
3938 ; fpmult - multiplies operands stored in arg & fac
3939 ; main multiplication routine
3940 ;
3941 ; entry:
3942 ; arg = x
3943 ; fac = y
3944 ;
Tue Jul 17 11:00:18 2018 Page 23
3945 ; exit:
3946 ; fac = x * y
3947 ; CF = 1 if invalid result(inf or nan)
3948 ;
3949 ;------
3950 F849DD fpmult:
3951 ;------
3952 F849DD 20 AF 4C jsr multst ; operands test
3953 F849E0 18 clc ; multiplication flag for addexp
3954 F849E1 20 DA 4A jsr addexp ; add exponent's
3955 F849E4 CPU16 ; clear the partial result
3956 F849E4 C2 30 rep #(PMFLAG.OR.PXFLAG)
3957 .LONGA on
3958 .LONGI on
3959 .MNLIST
3960 F849E6 64 00 stz tm
3961 F849E8 64 02 stz tm+2
3962 F849EA 64 04 stz tm+4
3963 F849EC 64 06 stz tm+6
3964 F849EE 64 08 stz tm+8
3965 F849F0 64 0A stz tm+10
3966 F849F2 64 0C stz tm+12
3967 F849F4 64 0E stz tm+14
3968 F849F6 20 44 4B jsr multm ; execute binary multiplication
3969 F849F9 CPU08
3970 F849F9 E2 30 sep #(PMFLAG.OR.PXFLAG)
3971 .LONGA off
3972 .LONGI off
3973 .MNLIST
3974 F849FB 80 1D bra movres ; move result to fac & normalize
3975
3976 ; frecip - returns the reciprocal of the argument
3977 ;
3978 ; entry:
3979 ; fac = x
3980 ;
3981 ; exit:
3982 ; fac = 1/x
3983 ; CF = 1 if invalid result(inf or nan)
3984 ;
3985 ;------
3986 F849FD frecip:
3987 ;------
3988 F849FD A9 FF lda #<fce0 ; load arg with constant 1.0
3989 F849FF A0 5E ldy #>fce0
3990
3991 ; fcdiv - divide one constant stored in program memory by the argument
3992 ;
3993 ; entry:
3994 ; fac = x
3995 ; A = low address of constant K
3996 ; Y = high address of constant K
3997 ;
3998 ; exit:
3999 ; fac = K / x
4000 ;
4001 ; This routine is used internally and not intended for end use.
Tue Jul 17 11:00:18 2018 Page 24
4002 ; Constant are stored unpacked, and with full size 128 bits mantissa,
4003 ; in program memory segment(the code segment that hold this routine).
4004 ;
4005 ;-----
4006 F84A01 fcdiv:
4007 ;-----
4008 F84A01 20 CF 86 jsr ldarg ; move constant K to arg
4009 F84A04 80 0A bra fpdiv ; execute arg/fac
4010
4011 ; div10 - divide the argument by 10.0
4012 ;
4013 ; entry:
4014 ; fac = x
4015 ; exit:
4016 ; fac = x / 10
4017 ;
4018 ; This routine is used internally and not intended for end use.
4019 ;
4020 ;-----
4021 F84A06 div10:
4022 ;-----
4023 F84A06 A9 11 lda #<fce1 ; address of constant = 10.0
4024 F84A08 A0 5F ldy #>fce1
4025
4026 ; fcrdiv - divide the argument by one constant stored in program memory
4027 ;
4028 ; entry:
4029 ; fac = x
4030 ; A = low address of constant K
4031 ; Y = high address of constant K
4032 ;
4033 ; exit:
4034 ; fac = x / K
4035 ;
4036 ; This routine is used internally and not intended for end use.
4037 ; Constant are stored unpacked, and with full size 128 bits mantissa,
4038 ; in program memory segment(the code segment that hold this routine).
4039 ;
4040 ;------
4041 F84A0A fcrdiv:
4042 ;------
4043 F84A0A 20 39 84 jsr mvftoa ; nove fac to arg
4044 F84A0D 20 82 86 jsr ldfac ; move constant to fac
4045
4046 ; fpdiv - divide the argument stored in arg by the argument stored in fac
4047 ;
4048 ; entry:
4049 ; arg = x
4050 ; fac = y
4051 ;
4052 ; exit:
4053 ; fac = x / y
4054 ; CF = 1 if invalid result(inf or nan)
4055 ;
4056 ;-----
4057 F84A10 fpdiv:
4058 ;-----
Tue Jul 17 11:00:18 2018 Page 25
4059 F84A10 20 EB 4C jsr divtst ; operands test
4060 F84A13 38 sec ; flag division for addexp
4061 F84A14 20 DA 4A jsr addexp ; add operands exponent
4062 F84A17 20 DF 4B jsr divm ; binary division
4063 F84A1A
4064 ; movres - move the result of multiplication/division to fac & normalize
4065 ;
4066 ; This routine is used internally and not intended for end use.
4067 ;
4068 ;------
4069 F84A1A movres:
4070 ;------
4071 F84A1A ACC16
4072 F84A1A C2 20 rep #PMFLAG
4073 .LONGA on
4074 .MNLIST
4075 F84A1C A5 00 lda tm ; move the result (16 bytes) to fac
4076 F84A1E 85 12 sta facm
4077 F84A20 A5 02 lda tm+2
4078 F84A22 85 14 sta facm+2
4079 F84A24 A5 04 lda tm+4
4080 F84A26 85 16 sta facm+4
4081 F84A28 A5 06 lda tm+6
4082 F84A2A 85 18 sta facm+6
4083 F84A2C A5 08 lda tm+8
4084 F84A2E 85 1A sta facm+8
4085 F84A30 A5 0A lda tm+10
4086 F84A32 85 1C sta facm+10
4087 F84A34 A5 0C lda tm+12
4088 F84A36 85 1E sta facm+12
4089 F84A38 A5 0E lda tm+14
4090 F84A3A 85 20 sta facm+14
4091 F84A3C ACC08
4092 F84A3C E2 20 sep #PMFLAG
4093 .LONGA off
4094 .MNLIST
4095 F84A3E A5 26 lda fexph ; operation involved subnormal?
4096 F84A40 F0 08 beq ?fn ; no
4097 F84A42 A2 12 ldx #facm ; now should shift to right fac...
4098 F84A44 20 3A 47 jsr shrmx ; ...because fac is subnormal
4099 F84A47 4C E6 46 ?tz: jmp chkz ; underflow test; check if fac=0
4100 F84A4A ?fn: ACC16 ; normalize fac after mult/div
4101 F84A4A C2 20 rep #PMFLAG
4102 .LONGA on
4103 .MNLIST
4104 F84A4C A5 22 lda facexp
4105 F84A4E C9 01 00 cmp #1
4106 F84A51 F0 F4 beq ?tz ; can't normalize: underflow test
4107 F84A53 A6 21 ldx facm+15 ; check msb
4108 F84A55 30 1A bmi ?done ; already normalized
4109 F84A57 C9 01 00 ?sh: cmp #1
4110 F84A5A F0 15 beq ?done ; can't shift more
4111 F84A5C 3A dec a ; decrement exponent at any shift
4112 F84A5D 06 28 asl facext
4113 F84A5F 26 12 rol facm
4114 F84A61 26 14 rol facm+2
4115 F84A63 26 16 rol facm+4
Tue Jul 17 11:00:18 2018 Page 26
4116 F84A65 26 18 rol facm+6
4117 F84A67 26 1A rol facm+8
4118 F84A69 26 1C rol facm+10
4119 F84A6B 26 1E rol facm+12
4120 F84A6D 26 20 rol facm+14
4121 F84A6F 10 E6 bpl ?sh ; shift until msb=1
4122 F84A71 85 22 ?done: sta facexp ; store exponent
4123 F84A73 C9 FF 7F cmp #INFEXP ; check if overflow
4124 F84A76 B0 32 bcs ovfw ; overflow
4125 F84A78 A6 29 ldx facext+1 ; if msb=1 we round 128 bits mantissa
4126 F84A7A 10 2A bpl ifx ; no rounding bit: done
4127 F84A7C 20 AF 4A jsr chkovf ; we check exponent for a potential overflow
4128 F84A7F B0 25 bcs ifx ; no round is possible (we avoid overflow)
4129 F84A81 E6 12 inc facm ; inc. 15 guard bits and significand lsb
4130 F84A83 D0 21 bne ifx
4131
4132 ; incfac - increment the high order 96 bits of the fac significand
4133 ; Called when round fac mantissa
4134 ;
4135 ; This routine is used internally and not intended for end use.
4136 ;
4137 ;------
4138 F84A85 incfac:
4139 ;------
4140 F84A85 E6 14 inc facm+2
4141 F84A87 D0 1D bne ifx
4142 F84A89 E6 16 inc facm+4
4143 F84A8B D0 19 bne ifx
4144 F84A8D E6 18 inc facm+6
4145 F84A8F D0 15 bne ifx
4146 F84A91 E6 1A inc facm+8
4147 F84A93 D0 11 bne ifx
4148 F84A95 E6 1C inc facm+10
4149 F84A97 D0 0D bne ifx
4150 F84A99 E6 1E inc facm+12
4151 F84A9B D0 09 bne ifx
4152 F84A9D E6 20 inc facm+14
4153 F84A9F D0 05 bne ifx
4154 F84AA1 CPU08
4155 F84AA1 E2 30 sep #(PMFLAG.OR.PXFLAG)
4156 .LONGA off
4157 .LONGI off
4158 .MNLIST
4159 F84AA3 4C 3E 46 jmp addcf ; add carry to significand, no overflow
4160 F84AA6 ifx: CPU08
4161 F84AA6 E2 30 sep #(PMFLAG.OR.PXFLAG)
4162 .LONGA off
4163 .LONGI off
4164 .MNLIST
4165 F84AA8 18 clc
4166 F84AA9 60 rts
4167
4168 ; set fac=inf
4169 ;----
4170 F84AAA ovfw:
4171 ;----
4172 F84AAA CPU08 ; overflow
Tue Jul 17 11:00:18 2018 Page 27
4173 F84AAA E2 30 sep #(PMFLAG.OR.PXFLAG)
4174 .LONGA off
4175 .LONGI off
4176 .MNLIST
4177 F84AAC 4C 7D 4E jmp fldinf
4178
4179 ; chkovf - check potential fac overflow due to a roundoff
4180 ;
4181 ; return CF=1 if a rounding can cause overflow
4182 ;
4183 ; This routine should be called with A/M = 16 bit
4184 ;
4185 ; This routine is used internally and not intended for end use.
4186 ;
4187 ;------
4188 F84AAF chkovf:
4189 ;------
4190 .LONGA on
4191
4192 F84AAF C9 FE 7F cmp #MAXEXP ; we check exponent for possible overflow
4193 F84AB2 90 25 bcc ?end ; ok, no overflow after rounding
4194 F84AB4 A9 FF FF lda #$FFFF ; check if mantissa is all one's
4195 F84AB7 C5 12 cmp facm
4196 F84AB9 D0 1A bne ?ok
4197 F84ABB C5 14 cmp facm+2
4198 F84ABD D0 16 bne ?ok
4199 F84ABF C5 16 cmp facm+4
4200 F84AC1 D0 12 bne ?ok
4201 F84AC3 C5 18 cmp facm+6
4202 F84AC5 D0 0E bne ?ok
4203 F84AC7 C5 1A cmp facm+8
4204 F84AC9 D0 0A bne ?ok
4205 F84ACB C5 1C cmp facm+10
4206 F84ACD D0 06 bne ?ok
4207 F84ACF C5 1E cmp facm+12
4208 F84AD1 D0 02 bne ?ok
4209 F84AD3 C5 20 cmp facm+14
4210 F84AD5 18 ?ok: clc ; rounding is possible
4211 F84AD6 D0 01 bne ?end
4212 F84AD8 38 sec ; no rounding possible
4213 F84AD9 60 ?end: rts
4214 F84ADA
4215 .LONGA off
4216
4217 ; addexp - add exponent of fac & arg for multiplication/division
4218 ;
4219 ; entry:
4220 ; arg = x
4221 ; fac = y
4222 ; CF = 1 if multiplication, else division
4223 ;
4224 ; exit:
4225 ; facexp = exponent of the result (x*y or x/y)
4226 ; fexph = negative exponent if result is subnormal,
4227 ; otherwise =0 if result is normal
4228 ;
4229 ; This routine is used internally and not intended for end use.
Tue Jul 17 11:00:18 2018 Page 28
4230 ;
4231 ;------
4232 F84ADA addexp:
4233 ;------
4234 F84ADA 08 php ; save carry
4235 F84ADB ACC16
4236 F84ADB C2 20 rep #PMFLAG
4237 .LONGA on
4238 .MNLIST
4239 F84ADD 64 26 stz fexph ; clear exponent sign extension
4240 F84ADF 64 3E stz aexph
4241 F84AE1 64 28 stz facext ; extension used while mult/div
4242 F84AE3 A5 20 lda facm+14
4243 F84AE5 30 05 bmi ?a ; fac is norml
4244 F84AE7 A2 12 ldx #facm
4245 F84AE9 20 D2 47 jsr shlmx ; normalize subnormal fac
4246 F84AEC A5 38 ?a: lda argm+14
4247 F84AEE 30 05 bmi ?b ; arg is norml
4248 F84AF0 A2 2A ldx #argm
4249 F84AF2 20 D2 47 jsr shlmx ; normalize subnormal arg
4250 F84AF5 28 ?b: plp ; restore carry
4251 F84AF6 CPU16
4252 F84AF6 C2 30 rep #(PMFLAG.OR.PXFLAG)
4253 .LONGA on
4254 .LONGI on
4255 .MNLIST
4256 F84AF8 A5 3A lda argexp
4257 F84AFA B0 14 bcs ?div ; subtract exponent for division
4258 F84AFC 65 22 adc facexp ; add exponent with sign extension
4259 F84AFE AA tax
4260 F84AFF A5 3E lda aexph
4261 F84B01 65 26 adc fexph
4262 F84B03 A8 tay
4263 F84B04 38 sec
4264 F84B05 8A txa
4265 F84B06 E9 FE 3F sbc #EBIAS-1 ; adjust biased exponent for mult
4266 F84B09 AA tax
4267 F84B0A 98 tya
4268 F84B0B E9 00 00 sbc #0
4269 F84B0E 80 12 bra ?tst ; check exponent
4270 F84B10 E5 22 ?div: sbc facexp ; subtract exponent with sign extension
4271 F84B12 AA tax
4272 F84B13 A5 3E lda aexph
4273 F84B15 E5 26 sbc fexph
4274 F84B17 A8 tay
4275 F84B18 18 clc
4276 F84B19 8A txa
4277 F84B1A 69 FF 3F adc #EBIAS ; adjust biased exponent
4278 F84B1D AA tax
4279 F84B1E 98 tya
4280 F84B1F 69 00 00 adc #0
4281 F84B22 30 09 ?tst: bmi ?sn ; negative exponent so result is subnormal
4282 F84B24 8A txa
4283 F84B25 F0 06 beq ?sn ; null exponent so result is subnormal
4284 F84B27 85 22 sta facexp ; exp >= 1 so result is normal
4285 F84B29 64 26 stz fexph
4286 F84B2B 80 0D bra ?done
Tue Jul 17 11:00:18 2018 Page 29
4287 F84B2D CA ?sn: dex ; negative count of shift toward right
4288 F84B2E E0 80 FF cpx #MAXBSHIFT-1
4289 F84B31 90 0A bcc ?z ; underflow: set fac=0
4290 F84B33 86 26 stx fexph ; negative count of shift
4291 F84B35 A9 01 00 lda #1
4292 F84B38 85 22 sta facexp ; subnormasl have exponent=1
4293 F84B3A ?done: CPU08
4294 F84B3A E2 30 sep #(PMFLAG.OR.PXFLAG)
4295 .LONGA off
4296 .LONGI off
4297 .MNLIST
4298 F84B3C 60 rts
4299 F84B3D ?z: CPU08 ; underflow: load zero into fac...
4300 F84B3D E2 30 sep #(PMFLAG.OR.PXFLAG)
4301 .LONGA off
4302 .LONGI off
4303 .MNLIST
4304 F84B3F 68 pla ; ...and exit
4305 F84B40 68 pla
4306 F84B41 4C 56 4E jmp fldz
4307
4308 ; multm - binary multiplication of the arg mantissa with fac mantissa
4309 ;
4310 ; classic binary multiplication "shift and add" method
4311 ; only high order 144 bits of 256 are retained in result
4312 ; Due the fact that facm and argm are normalized, the result is
4313 ; always between 1.000000... and 2.ffffff....
4314 ;
4315 ; should be called with A/M=16 bits, X/Y=16 bits
4316 ;
4317 ; This routine is used internally and not intended for end use.
4318 ;
4319 ;-----
4320 F84B44 multm:
4321 ;-----
4322 .LONGA on
4323 .LONGI on
4324
4325 F84B44 A5 12 lda facm ; multiply any word of facm with whole argm
4326 F84B46 20 6B 4B jsr ?mlt
4327 F84B49 A5 14 lda facm+2
4328 F84B4B 20 6B 4B jsr ?mlt
4329 F84B4E A5 16 lda facm+4
4330 F84B50 20 6B 4B jsr ?mlt
4331 F84B53 A5 18 lda facm+6
4332 F84B55 20 6B 4B jsr ?mlt
4333 F84B58 A5 1A lda facm+8
4334 F84B5A 20 6B 4B jsr ?mlt
4335 F84B5D A5 1C lda facm+10
4336 F84B5F 20 6B 4B jsr ?mlt
4337 F84B62 A5 1E lda facm+12
4338 F84B64 20 6B 4B jsr ?mlt
4339 F84B67 A5 20 lda facm+14 ; multiply msb that never is null
4340 F84B69 80 02 bra ?mlt2
4341 F84B6B F0 4F ?mlt: beq ?shr ; if null shift right partial result (16 bit)
4342 F84B6D 4A ?mlt2: lsr a ; multiplicator bit
4343 F84B6E 09 00 80 ora #$8000 ; bit for stop iteration (16 cycles)
Tue Jul 17 11:00:18 2018 Page 30
4344 F84B71 A8 ?lp: tay
4345 F84B72 90 31 bcc ?sh ; multiplicator=0 so shift result to right
4346 F84B74 18 clc
4347 F84B75 A5 00 lda tm ; add multiplicand to partial result
4348 F84B77 65 2A adc argm
4349 F84B79 85 00 sta tm
4350 F84B7B A5 02 lda tm+2
4351 F84B7D 65 2C adc argm+2
4352 F84B7F 85 02 sta tm+2
4353 F84B81 A5 04 lda tm+4
4354 F84B83 65 2E adc argm+4
4355 F84B85 85 04 sta tm+4
4356 F84B87 A5 06 lda tm+6
4357 F84B89 65 30 adc argm+6
4358 F84B8B 85 06 sta tm+6
4359 F84B8D A5 08 lda tm+8
4360 F84B8F 65 32 adc argm+8
4361 F84B91 85 08 sta tm+8
4362 F84B93 A5 0A lda tm+10
4363 F84B95 65 34 adc argm+10
4364 F84B97 85 0A sta tm+10
4365 F84B99 A5 0C lda tm+12
4366 F84B9B 65 36 adc argm+12
4367 F84B9D 85 0C sta tm+12
4368 F84B9F A5 0E lda tm+14
4369 F84BA1 65 38 adc argm+14
4370 F84BA3 85 0E sta tm+14
4371 F84BA5 66 0E ?sh: ror tm+14 ; shift any carry into partial result...
4372 F84BA7 66 0C ror tm+12 ; ...and shift partial result toward right
4373 F84BA9 66 0A ror tm+10
4374 F84BAB 66 08 ror tm+8
4375 F84BAD 66 06 ror tm+6
4376 F84BAF 66 04 ror tm+4
4377 F84BB1 66 02 ror tm+2
4378 F84BB3 66 00 ror tm
4379 F84BB5 66 28 ror facext ; greater accuracy with this extension
4380 F84BB7 98 tya
4381 F84BB8 4A lsr a ; end of loop when null
4382 F84BB9 D0 B6 bne ?lp
4383 F84BBB 60 rts ; always return CF=1
4384 F84BBC
4385 F84BBC A5 00 ?shr: lda tm ; shift partial result toward right...
4386 F84BBE 85 28 sta facext ; ...16 bit at time
4387 F84BC0 A5 02 lda tm+2
4388 F84BC2 85 00 sta tm
4389 F84BC4 A5 04 lda tm+4
4390 F84BC6 85 02 sta tm+2
4391 F84BC8 A5 06 lda tm+6
4392 F84BCA 85 04 sta tm+4
4393 F84BCC A5 08 lda tm+8
4394 F84BCE 85 06 sta tm+6
4395 F84BD0 A5 0A lda tm+10
4396 F84BD2 85 08 sta tm+8
4397 F84BD4 A5 0C lda tm+12
4398 F84BD6 85 0A sta tm+10
4399 F84BD8 A5 0E lda tm+14
4400 F84BDA 85 0C sta tm+12
Tue Jul 17 11:00:18 2018 Page 31
4401 F84BDC 64 0E stz tm+14
4402 F84BDE 60 rts
4403 F84BDF
4404 .LONGA off
4405 .LONGI off
4406
4407 ; divm - computes the division of the arg mantissa by fac mantissa
4408 ;
4409 ; Classic fixed point division, that use the recurrence equation:
4410 ;
4411 ; R = 2*R - D*Q
4412 ; j+1 j n-(j+1)
4413 ;
4414 ; R = V , Q = 1 if V >= D
4415 ; 0 n-1
4416 ;
4417 ; where: V=dividend, D=divisor, R = partial remainder, Q is the k-th
4418 ; j k
4419 ;
4420 ; bit of the quotient, starting from the msb: k=n-(j+1),
4421 ; n=130 is the quotient size, j=1..n-1 is the loop index.
4422 ; Only 130 bits of quotient are retained.
4423 ;
4424 ; Due the fact that facm and argm are normalized, the result is
4425 ; always between 0.100000... and 1.ffffff....
4426 ;
4427 ; This routine is used internally and not intended for end use.
4428 ;
4429 ;----
4430 F84BDF divm:
4431 ;----
4432 F84BDF A2 10 ldx #MANTSIZ ; loop for all bytes of mantissa
4433 F84BE1 A9 01 lda #$01 ; 8 bits quotient -- quotient = 0
4434 F84BE3 20 50 4C ?lp1: jsr ?cmp ; compare argm vs. facm
4435 F84BE6 08 ?lp2: php ; save carry (CF=1 if argm>=facm)
4436 F84BE7 2A rol a ; shift in CF (quotient bit) into lsb
4437 F84BE8 90 09 bcc ?sub ; bits loop...stop when CF=1
4438 F84BEA CA dex ; index of quotient array
4439 F84BEB 30 59 bmi ?done ; end of division
4440 F84BED 95 00 sta tm,x ; store this byte of quotient (start with msb)
4441 F84BEF F0 51 beq ?lst ; last quotient is 2 bits only
4442 F84BF1 A9 01 lda #$01 ; 8 bits quotient -- quotient = 0
4443 F84BF3 28 ?sub: plp ; restore CF from comparing argm vs. facm
4444 F84BF4 ACC16
4445 F84BF4 C2 20 rep #PMFLAG
4446 .LONGA on
4447 .MNLIST
4448 F84BF6 90 32 bcc ?sh ; quotient bit = 0: no subtraction
4449 F84BF8 A8 tay ; save partial quotient: here CF=1
4450 F84BF9 A5 2A lda argm ; get the partial remainder...
4451 F84BFB E5 12 sbc facm ; ...subtracting the divisor facm
4452 F84BFD 85 2A sta argm
4453 F84BFF A5 2C lda argm+2
4454 F84C01 E5 14 sbc facm+2
4455 F84C03 85 2C sta argm+2
4456 F84C05 A5 2E lda argm+4
4457 F84C07 E5 16 sbc facm+4
Tue Jul 17 11:00:18 2018 Page 32
4458 F84C09 85 2E sta argm+4
4459 F84C0B A5 30 lda argm+6
4460 F84C0D E5 18 sbc facm+6
4461 F84C0F 85 30 sta argm+6
4462 F84C11 A5 32 lda argm+8
4463 F84C13 E5 1A sbc facm+8
4464 F84C15 85 32 sta argm+8
4465 F84C17 A5 34 lda argm+10
4466 F84C19 E5 1C sbc facm+10
4467 F84C1B 85 34 sta argm+10
4468 F84C1D A5 36 lda argm+12
4469 F84C1F E5 1E sbc facm+12
4470 F84C21 85 36 sta argm+12
4471 F84C23 A5 38 lda argm+14
4472 F84C25 E5 20 sbc facm+14
4473 F84C27 85 38 sta argm+14
4474 F84C29 98 tya ; restore partial quotient
4475 F84C2A 06 2A ?sh: asl argm ; now shift argm to left (one place)
4476 F84C2C 26 2C rol argm+2
4477 F84C2E 26 2E rol argm+4
4478 F84C30 26 30 rol argm+6
4479 F84C32 26 32 rol argm+8
4480 F84C34 26 34 rol argm+10
4481 F84C36 26 36 rol argm+12
4482 F84C38 26 38 rol argm+14
4483 F84C3A ACC08
4484 F84C3A E2 20 sep #PMFLAG
4485 .LONGA off
4486 .MNLIST
4487 F84C3C B0 A8 bcs ?lp2 ; CF=1: quotient bit = 1
4488 F84C3E 30 A3 bmi ?lp1 ; CF=0, MSB=1: compare again argm vs. facm
4489 F84C40 10 A4 bpl ?lp2 ; CF=0, MSB=0: quotient bit = 0
4490 F84C42 A9 40 ?lst: lda #$40 ; 2 last bits quotient for normalitation...
4491 F84C44 80 AD bra ?sub ; ...and rounding
4492 F84C46 28 ?done: plp ; end of division
4493 F84C47 0A asl a ; last truncated quotient (00..03)...
4494 F84C48 0A asl a ; ...shifted to bits 15&14 of facext...
4495 F84C49 0A asl a ; ...to have greater accuracy...
4496 F84C4A 0A asl a
4497 F84C4B 0A asl a
4498 F84C4C 0A asl a
4499 F84C4D 85 29 sta facext+1
4500 F84C4F 60 rts
4501
4502 F84C50 A4 39 ?cmp: ldy argm+15 ; comparation: arg mantissa vs. fac mantissa
4503 F84C52 C4 21 cpy facm+15
4504 F84C54 D0 58 bne ?end
4505 F84C56 A4 38 ldy argm+14
4506 F84C58 C4 20 cpy facm+14
4507 F84C5A D0 52 bne ?end
4508 F84C5C A4 37 ldy argm+13
4509 F84C5E C4 1F cpy facm+13
4510 F84C60 D0 4C bne ?end
4511 F84C62 A4 36 ldy argm+12
4512 F84C64 C4 1E cpy facm+12
4513 F84C66 D0 46 bne ?end
4514 F84C68 A4 35 ldy argm+11
Tue Jul 17 11:00:18 2018 Page 33
4515 F84C6A C4 1D cpy facm+11
4516 F84C6C D0 40 bne ?end
4517 F84C6E A4 34 ldy argm+10
4518 F84C70 C4 1C cpy facm+10
4519 F84C72 D0 3A bne ?end
4520 F84C74 A4 33 ldy argm+9
4521 F84C76 C4 1B cpy facm+9
4522 F84C78 D0 34 bne ?end
4523 F84C7A A4 32 ldy argm+8
4524 F84C7C C4 1A cpy facm+8
4525 F84C7E D0 2E bne ?end
4526 F84C80 A4 31 ldy argm+7
4527 F84C82 C4 19 cpy facm+7
4528 F84C84 D0 28 bne ?end
4529 F84C86 A4 30 ldy argm+6
4530 F84C88 C4 18 cpy facm+6
4531 F84C8A D0 22 bne ?end
4532 F84C8C A4 2F ldy argm+5
4533 F84C8E C4 17 cpy facm+5
4534 F84C90 D0 1C bne ?end
4535 F84C92 A4 2E ldy argm+4
4536 F84C94 C4 16 cpy facm+4
4537 F84C96 D0 16 bne ?end
4538 F84C98 A4 2D ldy argm+3
4539 F84C9A C4 15 cpy facm+3
4540 F84C9C D0 10 bne ?end
4541 F84C9E A4 2C ldy argm+2
4542 F84CA0 C4 14 cpy facm+2
4543 F84CA2 D0 0A bne ?end
4544 F84CA4 A4 2B ldy argm+1
4545 F84CA6 C4 13 cpy facm+1
4546 F84CA8 D0 04 bne ?end
4547 F84CAA A4 2A ldy argm
4548 F84CAC C4 12 cpy facm
4549 F84CAE 60 ?end: rts
4550
4551 ; multst - test operands before to execute multiplication
4552 ;
4553 ; This routine test fac & arg for validity, set the sign of the result,
4554 ; and return to the caller for any abnormal condition:
4555 ;
4556 ; 1) return nan if fac=nan or arg=nan
4557 ; 2) return +inf if fac=+inf and arg=+inf or arg>0
4558 ; 3) return +inf if fac=-inf and arg=-inf or arg<0
4559 ; 4) return -inf if fac=-inf and arg=+inf or arg>0
4560 ; 5) return -inf if fac=+inf and arg=-inf or arg<0
4561 ; 6) return +inf if arg=+inf and fac>0
4562 ; 7) return +inf if arg=-inf and fac<0
4563 ; 8) return -inf if arg=-inf and fac>0
4564 ; 9) return -inf if arg=+inf and fac<0
4565 ; 10) return nan if fac=+/-inf and arg=0
4566 ; 11) return nan if arg=+/-inf and fac=0
4567 ;
4568 ; This routine is used internally and not intended for end use.
4569 ;
4570 ;------
4571 F84CAF multst:
Tue Jul 17 11:00:18 2018 Page 34
4572 ;------
4573 F84CAF A5 24 lda facsgn ; compare sign
4574 F84CB1 45 3C eor argsgn
4575 F84CB3 85 24 sta facsgn ; set result sign
4576 F84CB5 85 3C sta argsgn
4577 F84CB7 38 sec ; invalid result flag
4578 F84CB8 24 25 bit facst ; test fac
4579 F84CBA 10 0E bpl ?fv ; fac is valid
4580 F84CBC 50 2A bvc ?skp ; fac=nan so result=nan
4581 F84CBE 24 3D bit argst ; fac=inf so check arg
4582 F84CC0 10 04 bpl ?az ; fac=inf & arg=y so check if arg=0
4583 F84CC2 50 21 bvc ?mv ; fac=inf & arg=nan so result=nan
4584 F84CC4 80 22 bra ?skp ; fac=inf & arg=inf so result=inf
4585 F84CC6 50 20 ?az: bvc ?skp ; fac=inf & arg not null so result=inf
4586 F84CC8 80 0A bra ?nan ; fac=inf & arg=0 so result=nan
4587 F84CCA 24 3D ?fv: bit argst ; fac is valid, so now check arg
4588 F84CCC 10 0B bpl ?vv ; arg too is valid
4589 F84CCE 50 15 bvc ?mv ; fac=x & arg=nan so result=nan
4590 F84CD0 24 25 bit facst ; fac=x & arg=inf so check if fac=0
4591 F84CD2 50 11 bvc ?mv ; fac not null & arg=inf so result=inf
4592 F84CD4 20 74 4E ?nan: jsr fldnan ; fac=0 & arg=inf so result=nan
4593 F84CD7 80 0F bra ?skp ; skip resturn & exit with CF=1
4594 F84CD9 18 ?vv: clc ; now result is valid
4595 F84CDA 70 09 bvs ?mv ; arg=0 so result=0
4596 F84CDC 24 25 bit facst ; fac=0?
4597 F84CDE 50 0A bvc ?end ; no, return to mult operation
4598 F84CE0 20 56 4E jsr fldz ; result=0 (with CF=0)
4599 F84CE3 80 03 bra ?skp
4600 F84CE5 20 0C 84 ?mv: jsr mvatof ; move arg to fac (preserve CF)
4601 F84CE8 68 ?skp: pla ; skip return address
4602 F84CE9 68 pla
4603 F84CEA 60 ?end: rts
4604
4605 ; divtst - test operands before to execute division
4606 ;
4607 ; This routine test fac & arg for validity, set the sign of the result,
4608 ; and return to the caller for any abnormal condition:
4609 ;
4610 ; 1) return nan if fac=nan or arg=nan
4611 ; 2) return nan if fac=0 and arg=0
4612 ; 3) return nan if fac=+/-inf and arg=+/-inf
4613 ; 4) return +inf if arg=+inf and fac>=0
4614 ; 5) return +inf if arg=-inf and fac<0
4615 ; 6) return -inf if arg=-inf and fac>=0
4616 ; 7) return -inf if arg=+inf and fac<0
4617 ; 8) return +inf if arg>0 and fac=0
4618 ; 9) return -inf if arg<0 and fac=0
4619 ; 10) return 0 if arg=0 and fac=+/-inf
4620 ;
4621 ; This routine is used internally and not intended for end use.
4622 ;
4623 ;------
4624 F84CEB divtst:
4625 ;------
4626 F84CEB A5 24 lda facsgn ; compare sign
4627 F84CED 45 3C eor argsgn
4628 F84CEF 85 24 sta facsgn ; set result sign
Tue Jul 17 11:00:18 2018 Page 35
4629 F84CF1 85 3C sta argsgn
4630 F84CF3 38 sec ; invalid result flag
4631 F84CF4 24 25 bit facst ; test fac
4632 F84CF6 10 08 bpl ?fv ; fac is valid
4633 F84CF8 50 29 bvc ?skp ; fac=nan so result=nan
4634 F84CFA 24 3D bit argst ; fac=inf so check arg
4635 F84CFC 30 18 bmi ?nan ; fac=inf & arg=inf/nan so result=nan
4636 F84CFE 80 11 bra ?z ; fac=inf & arg=y so result=0
4637 F84D00 A5 3D ?fv: lda argst ; fac is valid, so now check arg
4638 F84D02 30 1C bmi ?mv ; fac=x & arg=nan/inf so result=nan/inf
4639 F84D04 25 25 and facst
4640 F84D06 0A asl a ; both null?
4641 F84D07 30 0D bmi ?nan ; yes so result=nan
4642 F84D09 24 25 bit facst
4643 F84D0B 70 0E bvs ?inf
4644 F84D0D 24 3D bit argst
4645 F84D0F 50 14 bvc ?end
4646 F84D11 20 56 4E ?z: jsr fldz ; result=0 (with CF=0)
4647 F84D14 80 0D bra ?skp
4648 F84D16 20 74 4E ?nan: jsr fldnan ; fac=0 & arg=0 so result=nan
4649 F84D19 80 08 bra ?skp ; skip resturn & exit with CF=1
4650 F84D1B 20 7D 4E ?inf: jsr fldinf
4651 F84D1E 80 03 bra ?skp
4652 F84D20 20 0C 84 ?mv: jsr mvatof ; move arg to fac (preserve CF)
4653 F84D23 68 ?skp: pla ; skip return address
4654 F84D24 68 pla
4655 F84D25 60 ?end: rts
4656
4657 ;---------------------------------------------------------------------------
4658 ; pack/unpack to/from 128 bit quadruple-precision IEEE format
4659 ; these routines convert to/from internal format from/to std. IEEE format
4660 ;---------------------------------------------------------------------------
4661
4662 ; frndm - round 128-bit fac mantissa to 113-bit mantissa
4663 ;
4664 ; standard rounding method: round to nearest and tie to even
4665 ;
4666 ; let G = (guard bits)*2 and L = lsb significand:
4667 ;
4668 ; if G < $8000 then round down (truncate)
4669 ; if G > $8000 then round up
4670 ; if G = $8000 then 'tie even':
4671 ; if L = 0 then round down (truncate)
4672 ; else round up
4673 ;
4674 ; if exponent equal to $7FFE and mantissa is all 1's, no round up take place,
4675 ; to avoid ovorflow
4676 ;
4677 ; The main use of this routine is to round fac before to convert to IEEE
4678 ; format, but can be called after any operation (of course losing guard bits)
4679 ;
4680 ;-----
4681 F84D26 frndm:
4682 ;-----
4683 F84D26 CPU16
4684 F84D26 C2 30 rep #(PMFLAG.OR.PXFLAG)
4685 .LONGA on
Tue Jul 17 11:00:18 2018 Page 36
4686 .LONGI on
4687 .MNLIST
4688 F84D28 A5 12 lda facm ; check guard bits
4689 F84D2A AA tax ; retain guard bits (G)
4690 F84D2B 29 00 80 and #$8000 ; mask bit 15 (significand lsb)
4691 F84D2E 85 12 sta facm ; clear guard bits (G)
4692 F84D30 A8 tay ; Y=lsb significand (L)
4693 F84D31 F0 07 beq ?rnd ; if bit 15=0 always possible to round up
4694 F84D33 A5 22 lda facexp ; we check exponent for possible overflow
4695 F84D35 20 AF 4A jsr chkovf
4696 F84D38 B0 14 bcs ?done ; no round is possible (avoid overflow)
4697 F84D3A 8A ?rnd: txa ; check guard bits
4698 F84D3B 0A asl a
4699 F84D3C C9 00 80 cmp #$8000
4700 F84D3F 90 0D bcc ?done ; G < $8000 so round down (truncate)
4701 F84D41 D0 03 bne ?cf ; G > $8000 so round up (CF=1 here)
4702 F84D43 98 tya ; G = $8000 so check L (lsb significand)
4703 F84D44 10 08 bpl ?done ; if L=0 round down -- tie even (truncate)
4704 F84D46 98 ?cf: tya ; here CF=1 -- round up
4705 F84D47 69 FF 7F adc #$7FFF ; really add $8000
4706 F84D4A 85 12 sta facm ; lsb sigificand
4707 F84D4C B0 03 bcs ?inc ; mantissa increment, because carry from lsb
4708 F84D4E ?done: CPU08
4709 F84D4E E2 30 sep #(PMFLAG.OR.PXFLAG)
4710 .LONGA off
4711 .LONGI off
4712 .MNLIST
4713 F84D50 60 rts
4714 F84D51 4C 85 4A ?inc: jmp incfac ; now this increment never cause overflow
4715
4716
4717 ; pack - pack fac & store in memory in std. quadruple precision IEEE format
4718 ;
4719 ; Main routine to store in memory a floating point number
4720 ;
4721 ; entry:
4722 ; fac = float point
4723 ; A = low memory address
4724 ; X = high memory address
4725 ; Y = memory bank
4726 ;
4727 ; exit:
4728 ; quadruple precision stored in memory
4729 ;
4730 ; This routine round 128-bit fac mantissa to 113-bit mantissa, pack to
4731 ; quadruple precision IEEE standard format, and store it in memory
4732 ;
4733 ;-----
4734 F84D54 fpack:
4735 ;-----
4736 F84D54 85 42 sta fcp ; set long pointer to memory buffer
4737 F84D56 86 43 stx fcp+1
4738 F84D58 84 44 sty fcp+2
4739 F84D5A 20 26 4D jsr frndm ; round fac to 113 bit mantissa
4740 F84D5D ACC16
4741 F84D5D C2 20 rep #PMFLAG
4742 .LONGA on
Tue Jul 17 11:00:18 2018 Page 37
4743 .MNLIST
4744 F84D5F A5 12 lda facm
4745 F84D61 0A asl a ; rotate lsb of packed format
4746 F84D62 A5 14 lda facm+2 ; rotate all remaining 112 bits...
4747 F84D64 2A rol a
4748 F84D65 87 42 sta [fcp] ; ...and store
4749 F84D67 A5 16 lda facm+4
4750 F84D69 2A rol a
4751 F84D6A A0 02 ldy #2
4752 F84D6C 97 42 sta [fcp],y
4753 F84D6E A5 18 lda facm+6
4754 F84D70 2A rol a
4755 F84D71 A0 04 ldy #4
4756 F84D73 97 42 sta [fcp],y
4757 F84D75 A5 1A lda facm+8
4758 F84D77 2A rol a
4759 F84D78 A0 06 ldy #6
4760 F84D7A 97 42 sta [fcp],y
4761 F84D7C A5 1C lda facm+10
4762 F84D7E 2A rol a
4763 F84D7F A0 08 ldy #8
4764 F84D81 97 42 sta [fcp],y
4765 F84D83 A5 1E lda facm+12
4766 F84D85 2A rol a
4767 F84D86 A0 0A ldy #10
4768 F84D88 97 42 sta [fcp],y
4769 F84D8A A5 20 lda facm+14
4770 F84D8C 2A rol a ; CF = hidden bit (msb)
4771 F84D8D A0 0C ldy #12
4772 F84D8F 97 42 sta [fcp],y
4773 F84D91 A5 22 lda facexp
4774 F84D93 B0 03 bcs ?fn ; CF=1 mean normal float
4775 F84D95 A9 00 00 lda #0 ; subnormal float or zero
4776 F84D98 A6 24 ?fn: ldx facsgn
4777 F84D9A 10 03 bpl ?exp ; positive float
4778 F84D9C 09 00 80 ora #$8000 ; negative float
4779 F84D9F A0 0E ?exp: ldy #14
4780 F84DA1 97 42 sta [fcp],y
4781 F84DA3 ACC08
4782 F84DA3 E2 20 sep #PMFLAG
4783 .LONGA off
4784 .MNLIST
4785 F84DA5 60 rts
4786
4787 ; unpack - get a quadruple precision IEEE format from memory and store in fac
4788 ;
4789 ; Main routine to load fac with a floating point number stored in memory
4790 ;
4791 ; entry:
4792 ; A = low memory address
4793 ; X = high memory address
4794 ; Y = memory bank
4795 ;
4796 ; exit:
4797 ; fac = floating point number in internal fortmat
4798 ;
4799 ;
Tue Jul 17 11:00:18 2018 Page 38
4800 ;-------
4801 F84DA6 funpack:
4802 ;-------
4803 F84DA6 85 42 sta fcp ; set long pointer to memory buffer
4804 F84DA8 86 43 stx fcp+1
4805 F84DAA 84 44 sty fcp+2
4806 F84DAC ACC16CLC ; CF=0: assume hidden bit = 0
4807 F84DAC C2 21 rep #(PMFLAG.OR.PCFLAG)
4808 .LONGA on
4809 .MNLIST
4810 F84DAE A2 00 ldx #0 ; assume positive sign
4811 F84DB0 A0 0E ldy #14
4812 F84DB2 B7 42 lda [fcp],y ; exponent
4813 F84DB4 10 01 bpl ?fp ; positive float
4814 F84DB6 CA dex ; negative float
4815 F84DB7 86 24 ?fp: stx facsgn
4816 F84DB9 A2 00 ldx #$00 ; assume normal float
4817 F84DBB 29 FF 7F and #$7FFF ; mask off sign
4818 F84DBE 85 22 sta facexp
4819 F84DC0 F0 01 beq ?get ; zero or subnormal (msb=0)
4820 F84DC2 38 sec ; hidden bit: msb=1
4821 F84DC3 A0 0C ?get: ldy #12
4822 F84DC5 B7 42 lda [fcp],y ; significand
4823 F84DC7 6A ror a ; rotate in hidden bit...
4824 F84DC8 85 20 sta facm+14 ; ...then rotate all 112 bits...
4825 F84DCA A0 0A ldy #10 ; ...and store to fac mantissa
4826 F84DCC B7 42 lda [fcp],y
4827 F84DCE 6A ror a
4828 F84DCF 85 1E sta facm+12
4829 F84DD1 A0 08 ldy #8
4830 F84DD3 B7 42 lda [fcp],y
4831 F84DD5 6A ror a
4832 F84DD6 85 1C sta facm+10
4833 F84DD8 A0 06 ldy #6
4834 F84DDA B7 42 lda [fcp],y
4835 F84DDC 6A ror a
4836 F84DDD 85 1A sta facm+8
4837 F84DDF A0 04 ldy #4
4838 F84DE1 B7 42 lda [fcp],y
4839 F84DE3 6A ror a
4840 F84DE4 85 18 sta facm+6
4841 F84DE6 A0 02 ldy #2
4842 F84DE8 B7 42 lda [fcp],y
4843 F84DEA 6A ror a
4844 F84DEB 85 16 sta facm+4
4845 F84DED A7 42 lda [fcp]
4846 F84DEF 6A ror a
4847 F84DF0 85 14 sta facm+2
4848 F84DF2 8A txa ; shift in lsb
4849 F84DF3 6A ror a ; <14:0> are all zero (guard bits)
4850 F84DF4 85 12 sta facm
4851 F84DF6 A5 22 lda facexp ; check exponent
4852 F84DF8 F0 17 beq ?chkz ; if exp=0 check if fac=0
4853 F84DFA C9 FF 7F cmp #INFEXP
4854 F84DFD 90 2A bcc ?st ; valid float, set status
4855 F84DFF A9 FF 7F lda #INFEXP
4856 F84E02 85 22 sta facexp ; fac=inf or fac=nan
Tue Jul 17 11:00:18 2018 Page 39
4857 F84E04 A2 C0 ldx #$C0 ; assume inf
4858 F84E06 A5 20 lda facm+14 ; check type
4859 F84E08 C9 00 80 cmp #INFSND
4860 F84E0B F0 1C beq ?st ; set inf in fac stastus
4861 F84E0D A2 80 ldx #$80 ; set nan in fac status
4862 F84E0F 80 18 bra ?st
4863 F84E11 A5 12 ?chkz: lda facm ; exponent is zero: check if fac=0
4864 F84E13 05 14 ora facm+2
4865 F84E15 05 16 ora facm+4
4866 F84E17 05 18 ora facm+6
4867 F84E19 05 1A ora facm+8
4868 F84E1B 05 1C ora facm+10
4869 F84E1D 05 1E ora facm+12
4870 F84E1F 05 20 ora facm+14
4871 F84E21 D0 04 bne ?sn ; fac is subnormal
4872 F84E23 A2 40 ldx #$40 ; fac is zero
4873 F84E25 80 02 bra ?st
4874 F84E27 E6 22 ?sn: inc facexp ; subnormal exponent = 1
4875 F84E29 86 25 ?st: stx facst ; set fac status
4876 F84E2B ACC08
4877 F84E2B E2 20 sep #PMFLAG
4878 .LONGA off
4879 .MNLIST
4880 F84E2D 60 rts
4881
4882 ;---------------------------------------------------------------------------
4883 ; load fac & arg with special values
4884 ;---------------------------------------------------------------------------
4885
4886 ; fldp1 - load the constant +1.0 into fac
4887 ;
4888 ; exit:
4889 ; fac = +1.0
4890 ;
4891 ;-----
4892 F84E2E fldp1:
4893 ;-----
4894 F84E2E 64 24 stz facsgn
4895 F84E30 80 04 bra fld1
4896
4897 ; fldm1 - load the constant -1.0 into fac
4898 ;
4899 ; exit:
4900 ; fac = -1.0
4901 ;
4902 ;-----
4903 F84E32 fldm1:
4904 ;-----
4905 F84E32 A9 FF lda #$FF
4906 F84E34 85 24 sta facsgn
4907
4908 ;----
4909 F84E36 fld1:
4910 ;----
4911 F84E36 ACC16
4912 F84E36 C2 20 rep #PMFLAG
4913 .LONGA on
Tue Jul 17 11:00:18 2018 Page 40
4914 .MNLIST
4915 F84E38 A9 FF 3F lda #EBIAS
4916 F84E3B 85 22 sta facexp
4917 F84E3D A9 00 80 lda #$8000
4918 F84E40 85 20 sta facm+14
4919 F84E42 64 12 stz facm
4920 F84E44 64 14 stz facm+2
4921 F84E46 64 16 stz facm+4
4922 F84E48 64 18 stz facm+6
4923 F84E4A 64 1A stz facm+8
4924 F84E4C 64 1C stz facm+10
4925 F84E4E 64 1E stz facm+12
4926 F84E50 ACC08
4927 F84E50 E2 20 sep #PMFLAG
4928 .LONGA off
4929 .MNLIST
4930 F84E52 64 25 stz facst
4931 F84E54 18 clc
4932 F84E55 60 rts
4933
4934 ; fldz - load the constant 0.0 into fac
4935 ;
4936 ; exit:
4937 ; fac = 0.0
4938 ;
4939 ;----
4940 F84E56 fldz:
4941 ;----
4942 F84E56 ACC16
4943 F84E56 C2 20 rep #PMFLAG
4944 .LONGA on
4945 .MNLIST
4946 F84E58 64 20 stz facm+14
4947 F84E5A 64 22 stz facexp
4948 F84E5C 64 12 stz facm
4949 F84E5E 64 14 stz facm+2
4950 F84E60 64 16 stz facm+4
4951 F84E62 64 18 stz facm+6
4952 F84E64 64 1A stz facm+8
4953 F84E66 64 1C stz facm+10
4954 F84E68 64 1E stz facm+12
4955 F84E6A ACC08
4956 F84E6A E2 20 sep #PMFLAG
4957 .LONGA off
4958 .MNLIST
4959 F84E6C 64 24 stz facsgn
4960 F84E6E A9 40 lda #$40
4961 F84E70 85 25 sta facst
4962 F84E72 18 noer: clc
4963 F84E73 60 rts
4964
4965 ; fldnan - set fac=nan
4966 ;------
4967 F84E74 fldnan:
4968 ;------
4969 F84E74 ACC16
4970 F84E74 C2 20 rep #PMFLAG
Tue Jul 17 11:00:18 2018 Page 41
4971 .LONGA on
4972 .MNLIST
4973 F84E76 A9 00 C0 lda #NANSND
4974 F84E79 A2 80 ldx #$80 ; nan flag
4975 F84E7B 80 07 bra fldinv
4976
4977 ; fldinf - set fac=inf
4978 ;------
4979 F84E7D fldinf:
4980 ;------
4981 F84E7D ACC16
4982 F84E7D C2 20 rep #PMFLAG
4983 .LONGA on
4984 .MNLIST
4985 F84E7F A9 00 80 lda #INFSND
4986 F84E82 A2 C0 ldx #$C0 ; inf flag
4987
4988 F84E84 fldinv:
4989 F84E84 85 20 sta facm+14 ; set msb
4990 F84E86 A9 FF 7F lda #INFEXP ; set invalid exponent
4991 F84E89 85 22 sta facexp
4992 F84E8B 64 1E stz facm+12
4993 F84E8D 64 1C stz facm+10
4994 F84E8F 64 1A stz facm+8
4995 F84E91 64 18 stz facm+6
4996 F84E93 64 16 stz facm+4
4997 F84E95 64 14 stz facm+2
4998 F84E97 64 12 stz facm
4999 F84E99 ACC08
5000 F84E99 E2 20 sep #PMFLAG
5001 .LONGA off
5002 .MNLIST
5003 F84E9B 86 25 stx facst
5004 F84E9D 38 sec ; return error condition
5005 F84E9E 60 rts
5006
5007 ; ldahalf - load the constant 0.5 into arg
5008 ;
5009 ; exit:
5010 ; arg = 0.5
5011 ;
5012 ;-------
5013 F84E9F ldahalf:
5014 ;-------
5015 F84E9F ACC16
5016 F84E9F C2 20 rep #PMFLAG
5017 .LONGA on
5018 .MNLIST
5019 F84EA1 A9 FE 3F lda #EBIAS-1
5020 F84EA4 80 0C bra amsb
5021
5022 ; ldaone - load the constant +1.0 into arg
5023 ;
5024 ; exit:
5025 ; arg = +1.0
5026 ;
5027 ;------
Tue Jul 17 11:00:18 2018 Page 42
5028 F84EA6 ldaone:
5029 ;------
5030 F84EA6 ACC16
5031 F84EA6 C2 20 rep #PMFLAG
5032 .LONGA on
5033 .MNLIST
5034 F84EA8 A9 FF 3F lda #EBIAS
5035 F84EAB 80 05 bra amsb
5036
5037 ; ldatwo - load the constant +2.0 into arg
5038 ;
5039 ; exit:
5040 ; arg = +2.0
5041 ;
5042 ;------
5043 F84EAD ldatwo:
5044 ;------
5045 F84EAD ACC16
5046 F84EAD C2 20 rep #PMFLAG
5047 .LONGA on
5048 .MNLIST
5049 F84EAF A9 00 40 lda #EBIAS+1
5050
5051 F84EB2 amsb:
5052 F84EB2 85 3A sta argexp ; store exponent
5053 F84EB4 A9 00 80 lda #$8000
5054 F84EB7 85 38 sta argm+14 ; high word = $8000
5055 F84EB9 64 2A stz argm ; reset all remaining bits
5056 F84EBB 64 2C stz argm+2
5057 F84EBD 64 2E stz argm+4
5058 F84EBF 64 30 stz argm+6
5059 F84EC1 64 32 stz argm+8
5060 F84EC3 64 34 stz argm+10
5061 F84EC5 64 36 stz argm+12
5062 F84EC7 64 3C stz argsgn ; positive sign
5063 F84EC9 ACC08
5064 F84EC9 E2 20 sep #PMFLAG
5065 .LONGA off
5066 .MNLIST
5067 F84ECB 18 clc
5068 F84ECC 60 rts
5069
5070 ;---------------------------------------------------------------------------
5071 ; conversion from integer to float & from float to integer
5072 ;---------------------------------------------------------------------------
5073
5074 ; fldu128 - load fac with an unsigned 128 bit integer (n)
5075 ;
5076 ; entry:
5077 ; tm..tm+15 = n, unsigned 128 bit integer
5078 ;
5079 ; exit:
5080 ; fac = n
5081 ;
5082 ;-------
5083 F84ECD fldu128:
5084 ;-------
Tue Jul 17 11:00:18 2018 Page 43
5085 F84ECD 20 56 4E jsr fldz ; set fac=0
5086 F84ED0 64 24 stz facsgn
5087 F84ED2 ACC16
5088 F84ED2 C2 20 rep #PMFLAG
5089 .LONGA on
5090 .MNLIST
5091 F84ED4 A5 0E lda tm+14 ; load 128 bit value
5092 F84ED6 85 20 sta facm+14
5093 F84ED8 A5 0C lda tm+12
5094 F84EDA 85 1E sta facm+12
5095 F84EDC A5 0A lda tm+10
5096 F84EDE 85 1C sta facm+10
5097 F84EE0 A5 08 lda tm+8
5098 F84EE2 85 1A sta facm+8
5099 F84EE4 A5 06 lda tm+6
5100 F84EE6 85 18 sta facm+6
5101 F84EE8 A5 04 lda tm+4
5102 F84EEA 85 16 sta facm+4
5103 F84EEC A5 02 lda tm+2
5104 F84EEE 85 14 sta facm+2
5105 F84EF0 A5 00 lda tm
5106 F84EF2 85 12 sta facm
5107 F84EF4 05 14 ora facm+2 ; test if n=0
5108 F84EF6 05 16 ora facm+4
5109 F84EF8 05 18 ora facm+6
5110 F84EFA 05 1A ora facm+8
5111 F84EFC 05 1C ora facm+10
5112 F84EFE 05 1E ora facm+12
5113 F84F00 05 20 ora facm+14
5114 F84F02 F0 29 beq okz ; n=0
5115 F84F04 A9 7E 40 lda #BIAS128 ; biased exponent for 128 bit value
5116 F84F07 80 66 bra fldu
5117
5118 .LONGA off
5119
5120 ; fldu64 - load fac with an unsigned 64 bit integer (n)
5121 ;
5122 ; entry:
5123 ; tm..tm+7 = n, unsigned 64 bit integer
5124 ;
5125 ; exit:
5126 ; fac = n
5127 ;
5128 ;------
5129 F84F09 fldu64:
5130 ;------
5131 F84F09 20 56 4E jsr fldz ; set fac=0
5132 F84F0C 64 24 stz facsgn
5133 F84F0E ACC16
5134 F84F0E C2 20 rep #PMFLAG
5135 .LONGA on
5136 .MNLIST
5137 F84F10 A5 06 lda tm+6 ; load 64 bit value
5138 F84F12 85 20 sta facm+14
5139 F84F14 A5 04 lda tm+4
5140 F84F16 85 1E sta facm+12
5141 F84F18 A5 02 lda tm+2
Tue Jul 17 11:00:18 2018 Page 44
5142 F84F1A 85 1C sta facm+10
5143 F84F1C A5 00 lda tm
5144 F84F1E 85 1A sta facm+8
5145 F84F20 05 1C ora facm+10 ; test if n=0
5146 F84F22 05 1E ora facm+12
5147 F84F24 05 20 ora facm+14
5148 F84F26 F0 05 beq okz ; n=0
5149 F84F28 A9 3E 40 lda #BIAS64 ; biased exponent for 64 bit value
5150 F84F2B 80 42 bra fldu
5151
5152 .LONGA off
5153
5154 F84F2D okz: ACC08
5155 F84F2D E2 20 sep #PMFLAG
5156 .LONGA off
5157 .MNLIST
5158 F84F2F 18 clc
5159 F84F30 60 rts
5160
5161 ; fldu32 - load fac with an unsigned 32 bit integer (n)
5162 ;
5163 ; entry:
5164 ; tm..tm+3 = n, unsigned 32 bit integer
5165 ;
5166 ; exit:
5167 ; fac = n
5168 ;
5169 ;------
5170 F84F31 fldu32:
5171 ;------
5172 F84F31 20 56 4E jsr fldz ; set fac=0
5173 F84F34 64 24 stz facsgn
5174 F84F36 ACC16
5175 F84F36 C2 20 rep #PMFLAG
5176 .LONGA on
5177 .MNLIST
5178 F84F38 A5 02 lda tm+2
5179 F84F3A 85 20 sta facm+14 ; load 32 bit value
5180 F84F3C A5 00 lda tm
5181 F84F3E 85 1E sta facm+12
5182 F84F40 05 20 ora facm+14 ; test if n=0
5183 F84F42 F0 E9 beq okz ; n=0
5184 F84F44 A9 1E 40 lda #BIAS32 ; biased exponent for 32 bit value
5185 F84F47 80 26 bra fldu
5186
5187 .LONGA off
5188
5189 ; fldbyt - load fac with an unsigned 8 bit integer (n)
5190 ;
5191 ; entry:
5192 ; A = n, unsigned 8 bit integer
5193 ;
5194 ; exit:
5195 ; fac = n
5196 ;
5197 ;------
5198 F84F49 fldbyt:
Tue Jul 17 11:00:18 2018 Page 45
5199 ;------
5200 F84F49 AA tax ; save A
5201 F84F4A 20 56 4E jsr fldz ; set fac=0
5202 F84F4D 64 24 stz facsgn
5203 F84F4F 8A txa
5204 F84F50 F0 DB beq okz ; n=0
5205 F84F52 86 21 stx facm+15 ; put byte in high order bits
5206 F84F54 ACC16
5207 F84F54 C2 20 rep #PMFLAG
5208 .LONGA on
5209 .MNLIST
5210 F84F56 A9 06 40 lda #BIAS8 ; biased exponent for 8 bit value
5211 F84F59 80 14 bra fldu
5212
5213 .LONGA off
5214 F84F5B
5215 ; fldu16 - load fac with an unsigned 16 bit integer (n)
5216 ;
5217 ; entry:
5218 ; A = low 8 bit of n, unsigned 16 bit integer
5219 ; Y = high 8 bit of n, unsigned 16 bit integer
5220 ;
5221 ; exit:
5222 ; fac = n
5223 ;
5224 ;------
5225 F84F5B fldu16:
5226 ;------
5227 F84F5B AA tax ; save A
5228 F84F5C 20 56 4E jsr fldz ; set fac=0
5229 F84F5F 86 20 stx facm+14 ; low 8 bit
5230 F84F61 84 21 sty facm+15 ; high 8 bit
5231 F84F63 64 24 stz facsgn
5232 F84F65 8A txa
5233 F84F66 05 21 ora facm+15 ; test if n=0
5234 F84F68 F0 C3 beq okz ; n=0
5235 F84F6A ACC16
5236 F84F6A C2 20 rep #PMFLAG
5237 .LONGA on
5238 .MNLIST
5239 F84F6C A9 0E 40 lda #BIAS16 ; biased exponent for 16 bit value
5240
5241 ;----
5242 F84F6F fldu:
5243 ;----
5244 F84F6F 85 22 sta facexp ; store exponent
5245 F84F71 ACC08
5246 F84F71 E2 20 sep #PMFLAG
5247 .LONGA off
5248 .MNLIST
5249 F84F73 64 25 stz facst ; normal fac <> 0
5250 F84F75 4C 62 46 jmp normfac ; normalize fac
5251
5252 ; uitrunc - convert the integral part of fac to unsigned 128 bit integer
5253 ;
5254 ; this routine truncate toward zero, and ignore fac sign
5255 ;
Tue Jul 17 11:00:18 2018 Page 46
5256 ; entry:
5257 ; fac = x
5258 ;
5259 ; exit:
5260 ; tm..tm+15 = unsigned 128 bit integer = integral part of |x|
5261 ; CF = 1 if the integral part of |x| not fit in 128 bit
5262 ;
5263 ; In overflow condition, or if fac=nan/inf, tm..tm+15 will be filled with
5264 ; the max. 128 bit value and the carry flag will be set.
5265 ;
5266 ;-------
5267 F84F78 uitrunc:
5268 ;-------
5269 F84F78 24 25 bit facst ; valid fac?
5270 F84F7A 10 1F bpl ?fv ; yes
5271 F84F7C ACC16 ; set tm..tm+15 to max.
5272 F84F7C C2 20 rep #PMFLAG
5273 .LONGA on
5274 .MNLIST
5275 F84F7E 38 ?ovf: sec ; invalid flag
5276 F84F7F A9 FF FF lda #$FFFF ; set max.
5277 F84F82 80 04 bra ?set
5278 F84F84 A9 00 00 ?z: lda #0
5279 F84F87 18 ?z1: clc ; valid flag
5280 F84F88 85 00 ?set: sta tm
5281 F84F8A 85 02 sta tm+2
5282 F84F8C 85 04 sta tm+4
5283 F84F8E 85 06 sta tm+6
5284 F84F90 85 08 sta tm+8
5285 F84F92 85 0A sta tm+10
5286 F84F94 85 0C sta tm+12
5287 F84F96 85 0E sta tm+14
5288 F84F98 ACC08
5289 F84F98 E2 20 sep #PMFLAG
5290 .LONGA off
5291 .MNLIST
5292 F84F9A 60 rts
5293 F84F9B ?fv: ACC16
5294 F84F9B C2 20 rep #PMFLAG
5295 .LONGA on
5296 .MNLIST
5297 F84F9D 70 E5 bvs ?z ; fac=0, so return tm=0
5298 F84F9F A5 22 lda facexp
5299 F84FA1 F0 E4 beq ?z1 ; fac=0, so return tm=0
5300 F84FA3 38 sec
5301 F84FA4 E9 FF 3F sbc #EBIAS ; unbias exponent
5302 F84FA7 90 DB bcc ?z ; fac<1, so return tm=0
5303 F84FA9 C9 80 00 cmp #MNTBITS ; limit to 128 bit integer
5304 F84FAC B0 D0 bcs ?ovf ; 128 bits integer overflow
5305 F84FAE E9 7E 00 sbc #MNTBITS-2 ; take in account CF=0 here
5306 F84FB1 AA tax ; A=X=negative count of shift toward right
5307 F84FB2 A5 12 lda facm ; move fac mantissa to tm
5308 F84FB4 85 00 sta tm
5309 F84FB6 A5 14 lda facm+2
5310 F84FB8 85 02 sta tm+2
5311 F84FBA A5 16 lda facm+4
5312 F84FBC 85 04 sta tm+4
Tue Jul 17 11:00:18 2018 Page 47
5313 F84FBE A5 18 lda facm+6
5314 F84FC0 85 06 sta tm+6
5315 F84FC2 A5 1A lda facm+8
5316 F84FC4 85 08 sta tm+8
5317 F84FC6 A5 1C lda facm+10
5318 F84FC8 85 0A sta tm+10
5319 F84FCA A5 1E lda facm+12
5320 F84FCC 85 0C sta tm+12
5321 F84FCE A5 20 lda facm+14
5322 F84FD0 85 0E sta tm+14
5323 F84FD2 ACC08
5324 F84FD2 E2 20 sep #PMFLAG
5325 .LONGA off
5326 .MNLIST
5327 F84FD4 8A txa ; A=negative count of shift toward right
5328 F84FD5 F0 05 beq ?done ; no shift so exit
5329 F84FD7 A2 00 ldx #tm ; shift tm..tm15 toward right
5330 F84FD9 20 3A 47 jsr shrmx ; align integer with exponent
5331 F84FDC 18 ?done: clc
5332 F84FDD 60 rts
5333
5334 ;---------------------------------------------------------------------------
5335 ; rounding routines
5336 ;---------------------------------------------------------------------------
5337
5338 ; fceil - returns the smallest f.p. integer greater than or equal the argument
5339 ;
5340 ; This routine truncates toward plus infinity
5341 ;
5342 ; entry:
5343 ; fac = x
5344 ;
5345 ; exit:
5346 ; fac = y = integral part of x truncated toward plus infinity
5347 ; CF = 1 if invalid result(inf or nan)
5348 ;
5349 ; fceil(3.0) = 3.0
5350 ; fceil(2.3) = 3.0
5351 ; fceil(0.5) = 1.0
5352 ; fceil(-0.5) = 0.0
5353 ; fceil(-2.3) = -2.0
5354 ; fceil(-3.0) = -3.0
5355 ;
5356 ;-----
5357 F84FDE fceil:
5358 ;-----
5359 F84FDE 24 25 bit facst
5360 F84FE0 10 02 bpl ?fv ; fac is valid
5361 F84FE2 38 sec ; return invalid flag
5362 F84FE3 60 rts
5363 F84FE4 50 04 ?fv: bvc ?nz ; fac <> 0
5364 F84FE6 64 24 stz facsgn ; return fac=0
5365 F84FE8 18 clc
5366 F84FE9 60 rts
5367 F84FEA A5 24 ?nz: lda facsgn
5368 F84FEC 49 FF eor #$FF ; fceil(x)=-floor(-x)
5369 F84FEE 85 24 sta facsgn
Tue Jul 17 11:00:18 2018 Page 48
5370 F84FF0 20 27 50 jsr floor
5371 F84FF3 A5 24 lda facsgn
5372 F84FF5 49 FF eor #$FF
5373 F84FF7 85 24 sta facsgn
5374 F84FF9 60 rts
5375
5376 ; fround - returns the integral value that is nearest to ergument x,
5377 ; with halfway cases rounded away from zero.
5378 ;
5379 ; This routine truncates toward the nearest integer value
5380 ;
5381 ; entry:
5382 ; fac = x
5383 ;
5384 ; exit:
5385 ; fac = y = integral part of x truncated toward the nearest
5386 ; CF = 1 if invalid result(inf or nan)
5387 ;
5388 ; fround(3.8) = 4.0
5389 ; fround(3.4) = 3.0
5390 ; fround(0.5) = 1.0
5391 ; fround(0.4) = 0.0
5392 ; fround(-0.4) = 0.0
5393 ; fround(-0.5) = -1.0
5394 ; fround(-3.4) = -3.0
5395 ; fround(-3.8) = -4.0
5396 ;
5397 ;------
5398 F84FFA fround:
5399 ;------
5400 F84FFA 24 25 bit facst
5401 F84FFC 10 02 bpl ?fv ; fac is valid
5402 F84FFE 38 sec ; return invalid flag
5403 F84FFF 60 ?ret: rts
5404 F85000 50 04 ?fv: bvc ?nz ; fac <> 0
5405 F85002 64 24 stz facsgn ; return fac=0
5406 F85004 18 clc
5407 F85005 60 rts
5408 F85006 A5 24 ?nz: lda facsgn
5409 F85008 48 pha ; save fac sign
5410 F85009 64 24 stz facsgn
5411 F8500B 20 67 45 jsr faddhalf ; |x|+0.5
5412 F8500E 68 pla
5413 F8500F 85 24 sta facsgn ; restore fac sign
5414 F85011 B0 EC bcs ?ret ; overflow
5415
5416 ; return sign(x)*ftrunc(|x|+0.5)
5417 F85013 30 C9 bmi fceil ; ftrunc(x)=fceil(x) if x<0
5418 F85015 80 10 bra floor ; ftrunc(x)=floor(x) if x>0
5419 F85017
5420 ; ftrunc - returns the nearest integral value that is not larger
5421 ; in magnitude than the argument x.
5422 ;
5423 ; This routine truncates toward zero
5424 ;
5425 ; entry:
5426 ; fac = x
Tue Jul 17 11:00:18 2018 Page 49
5427 ;
5428 ; exit:
5429 ; fac = y = integral part of x truncated toward zero
5430 ; CF = 1 if invalid result(inf or nan)
5431 ;
5432 ; ftrunc(3.0) = 3.0
5433 ; ftrunc(2.3) = 2.0
5434 ; ftrunc(0.5) = 0.0
5435 ; ftrunc(-0.5) = 0.0
5436 ; ftrunc(-2.3) = -2.0
5437 ; ftrunc(-3.0) = -3.0
5438 ;
5439 ;------
5440 F85017 ftrunc:
5441 ;------
5442 F85017 24 25 bit facst
5443 F85019 10 02 bpl ?fv ; fac is valid
5444 F8501B 38 sec ; return invalid flag
5445 F8501C 60 rts
5446 F8501D 50 04 ?fv: bvc ?nz ; fac <> 0
5447 F8501F 64 24 stz facsgn ; return fac=0
5448 F85021 18 clc
5449 F85022 60 rts
5450 F85023 A5 24 ?nz: lda facsgn
5451 F85025 30 B7 bmi fceil ; ftrunc(x)=fceil(x) if x<0
5452 ; ftrunc(x)=floor(x) if x>0
5453 F85027
5454 ; floor - returns the largest f.p. integer less than or equal to the argument
5455 ;
5456 ; This routine truncates toward minus infinity
5457 ;
5458 ; entry:
5459 ; fac = x
5460 ;
5461 ; exit:
5462 ; fac = y = integral part of x truncated toward minus infinity
5463 ; CF = 1 if invalid result(inf or nan)
5464 ;
5465 ; floor(3.0) = 3.0
5466 ; floor(2.3) = 2.0
5467 ; floor(0.5) = 0.0
5468 ; floor(-0.5) = -1
5469 ; floor(-2.3) = -3.0
5470 ; floor(-3.0) = -3.0
5471 ;
5472 ;-----
5473 F85027 floor:
5474 ;-----
5475 F85027 24 25 bit facst
5476 F85029 10 02 bpl ?fv ; fac is valid
5477 F8502B 38 sec ; return invalid flag
5478 F8502C 60 rts
5479 F8502D 50 04 ?fv: bvc ?nz ; fac <> 0
5480 F8502F 64 24 stz facsgn ; return fac=0
5481 F85031 18 clc
5482 F85032 60 rts
5483 F85033 20 26 4D ?nz: jsr frndm
Tue Jul 17 11:00:18 2018 Page 50
5484 F85036 ACC16
5485 F85036 C2 20 rep #PMFLAG
5486 .LONGA on
5487 .MNLIST
5488 F85038 A5 22 lda facexp
5489 F8503A 38 sec
5490 F8503B E9 FF 3F sbc #EBIAS
5491 F8503E 85 3E sta wftmp ; save unbiased exponent
5492 F85040 ACC08
5493 F85040 E2 20 sep #PMFLAG
5494 .LONGA off
5495 .MNLIST
5496 F85042 B0 0A bcs ?gt1 ; |fac|>=1
5497 F85044 24 24 bit facsgn
5498 F85046 30 03 bmi ?m1 ; if -1<fac<0 return fac=-1...
5499 F85048 4C 56 4E jmp fldz ; ...else return fac=0
5500 F8504B 4C 32 4E ?m1: jmp fldm1 ; return fac=-1
5501 F8504E 20 39 84 ?gt1: jsr mvftoa ; move fac to arg for later comparation
5502 F85051 ACC16 ; here CF=1
5503 F85051 C2 20 rep #PMFLAG
5504 .LONGA on
5505 .MNLIST
5506 F85053 A9 70 00 lda #SNBITS-1
5507 F85056 E5 3E sbc wftmp ; if this is <=0 then fac already integral
5508 F85058 ACC08
5509 F85058 E2 20 sep #PMFLAG
5510 .LONGA off
5511 .MNLIST
5512 F8505A 90 23 bcc ?int ; fac already integral
5513 F8505C F0 21 beq ?int ; fac already integral
5514 F8505E
5515 ; now A=count of bits to clear starting from mantissa ending
5516 ; and we can clear the fractional part to get just the integral part
5517 F8505E
5518 F8505E 64 13 stz facm+1 ; clear lsb
5519 F85060 3A dec a
5520 F85061 F0 1C beq ?int ; done: fac is integral
5521 F85063 A0 00 ldy #0 ; Y=0
5522 F85065 BB tyx ; X=0
5523 F85066 C9 08 ?lp: cmp #8 ; clear 8 bits at time?
5524 F85068 90 09 bcc ?bit ; no, we have to clear less than 8 bits
5525 F8506A 94 14 sty facm+2,x
5526 F8506C E8 inx
5527 F8506D E9 08 sbc #8 ; update count
5528 F8506F F0 0E beq ?int ; done: fac is integral
5529 F85071 80 F3 bra ?lp ; loop until we can clear 8 bits at time
5530 F85073 9B ?bit: txy ; save mantissa index
5531 F85074 AA tax ; X=count of bits
5532 F85075 CA dex
5533 F85076 BF B6 50 F8 lda >fmask,x ; load bits mask
5534 F8507A BB tyx ; X=mantissa index
5535 F8507B 35 14 and facm+2,x ; mask mantissa byte
5536 F8507D 95 14 sta facm+2,x
5537 F8507F 24 24 ?int: bit facsgn ; if fac>0...
5538 F85081 10 31 bpl ?end ; ...then done
5539 F85083 ACC16 ; ...else we compare if integral part...
5540 F85083 C2 20 rep #PMFLAG
Tue Jul 17 11:00:18 2018 Page 51
5541 .LONGA on
5542 .MNLIST
5543 ; ...is equal to original fac
5544 F85085 A5 14 lda facm+2
5545 F85087 C5 2C cmp argm+2
5546 F85089 D0 22 bne ?chk
5547 F8508B A5 16 lda facm+4
5548 F8508D C5 2E cmp argm+4
5549 F8508F D0 1C bne ?chk
5550 F85091 A5 18 lda facm+6
5551 F85093 C5 30 cmp argm+6
5552 F85095 D0 16 bne ?chk
5553 F85097 A5 1A lda facm+8
5554 F85099 C5 32 cmp argm+8
5555 F8509B D0 10 bne ?chk
5556 F8509D A5 1C lda facm+10
5557 F8509F C5 34 cmp argm+10
5558 F850A1 D0 0A bne ?chk
5559 F850A3 A5 1E lda facm+12
5560 F850A5 C5 36 cmp argm+12
5561 F850A7 D0 04 bne ?chk
5562 F850A9 A5 20 lda facm+14
5563 F850AB C5 38 cmp argm+14
5564 F850AD ?chk: ACC08
5565 F850AD E2 20 sep #PMFLAG
5566 .LONGA off
5567 .MNLIST
5568 F850AF F0 03 beq ?end ; if equal then return it...
5569 F850B1 4C 71 45 jmp fsubone ; ...otherwise subtract 1
5570 F850B4 18 ?end: clc
5571 F850B5 60 rts
5572
5573 ; bit mask to clear
5574 F850B6 fmask:
5575 F850B6 FE FC F8 F0 E0 .DB $FE,$FC,$F8,$F0,$E0,$C0,$80
C0 80
5576
5577 ;---------------------------------------------------------------------------
5578 ; remainders routines
5579 ;---------------------------------------------------------------------------
5580
5581 ; fpmod, fprem - returns the remainder of x/y
5582 ;
5583 ; entry:
5584 ; fac = y
5585 ; arg = x
5586 ;
5587 ; exit:
5588 ; fac = remainder
5589 ; arg = integral part of the quotient
5590 ; CF = 1 if invalid results
5591 ;
5592 ; The quotient is truncated toward zero in fpmod, and rounded to nearest
5593 ; in fprem. The remainder is computed as: x - n*y, where n is the integral
5594 ; quotient.
5595 ;
5596 ;-----
Tue Jul 17 11:00:18 2018 Page 52
5597 F850BD fpmod:
5598 ;-----
5599 F850BD 20 DD 50 jsr rdiv ; x/y
5600 F850C0 20 17 50 jsr ftrunc
5601 F850C3 80 06 bra rem
5602 F850C5
5603 ;-----
5604 F850C5 fprem:
5605 ;-----
5606 F850C5 20 DD 50 jsr rdiv ; x/y
5607 F850C8 20 FA 4F jsr fround
5608
5609 ;---
5610 F850CB rem:
5611 ;---
5612 F850CB 20 C0 84 jsr mvf_t2 ; tfr2 = n
5613 F850CE 20 FB 85 jsr mvt1_a ; y
5614 F850D1 20 DD 49 jsr fpmult ; y*n
5615 F850D4 20 CE 85 jsr mvt0_a
5616 F850D7 20 5F 45 jsr fpsub ; fac = x - y*n
5617 F850DA 4C 28 86 jmp mvt2_a ; arg = n
5618
5619 ;----
5620 F850DD rdiv:
5621 ;----
5622 F850DD 20 93 84 jsr mvf_t1 ; tfr1 = y
5623 F850E0 20 1A 85 jsr mva_t0 ; tfr0 = x
5624 F850E3 20 10 4A jsr fpdiv ; x/y
5625 F850E6 90 09 bcc ?ret ; ok
5626 F850E8 20 74 4E jsr fldnan ; return nan
5627 F850EB 20 39 84 jsr mvftoa
5628 F850EE 68 pla ; skip return address
5629 F850EF 68 pla
5630 F850F0 38 sec
5631 F850F1 60 ?ret: rts
5632 F850F2
5633 ; fpfrac - returns the integral part, trucated toward zero, and the fractional
5634 ; part of the argument x
5635 ;
5636 ; entry:
5637 ; fac = x
5638 ;
5639 ; exit:
5640 ; fac = y = fractional part of x, with: -1 < y < +1
5641 ; arg = k = integral part of x, as returned by ftrunc(x)
5642 ; CF = 1 if invalid result (inf or nan)
5643 ; in this case fac=arg=nan/inf
5644 ;
5645 ; note that y and k have the same sign of x and:
5646 ;
5647 ; x = k + y
5648 ;
5649 ;------
5650 F850F2 fpfrac:
5651 ;------
5652 F850F2 24 25 bit facst
5653 F850F4 10 05 bpl ?fv ; fac is valid
Tue Jul 17 11:00:18 2018 Page 53
5654 F850F6 20 39 84 ?er: jsr mvftoa ; set arg=fac
5655 F850F9 38 sec ; return invalid flag
5656 F850FA 60 rts
5657 F850FB 20 ED 84 ?fv: jsr mvf_t3 ; move fac to temp. reg. tfr3
5658 F850FE 20 17 50 jsr ftrunc ; fac=k=ftrunc(x)
5659 F85101 B0 F3 bcs ?er ; overflow
5660 F85103 20 C0 84 jsr mvf_t2 ; tfr2=k
5661 F85106 20 55 86 jsr mvt3_a ; arg=x
5662 F85109 20 5F 45 jsr fpsub ; fac=y=x-k
5663 F8510C 4C 28 86 jmp mvt2_a ; arg=k
5664
5665 ;---------------------------------------------------------------------------
5666 ; conversion decimal/hexadecimal to binary
5667 ;---------------------------------------------------------------------------
5668
5669 ; str2int, str2int2 - convert the initial portion of the source string to
5670 ; an unsigned or signed 128 bits integer.
5671 ;
5672 ; entry:
5673 ; A = low address of source string
5674 ; X = high address of source string
5675 ; Y = bank that hold source string
5676 ; B = flag signed conversion ($80), ignored for hex. string
5677 ;
5678 ; str2int2 is the re-entry point when long pointer tlp is already set,
5679 ; and in this case:
5680 ;
5681 ; entry:
5682 ; A = flag signed conversion ($80), ignored for hex. string
5683 ; tlp = long pointer to source string
5684 ;
5685 ; exit:
5686 ; facm..facm+15 = 128 bits integer
5687 ; facsiz = minimum number of bytes that can hold the integer
5688 ; A = first character where conversion stop
5689 ; tlp = long pointer to first char. where conversion stop
5690 ; CF = 0 if conversion was succesfully done
5691 ; VF = 1 if integer overflow
5692 ; CF = 1 (VF don't care) if input string is invalid
5693 ;
5694 ; Conversion start parsing source string from left toward right, skipping any
5695 ; leading blank and/or tab: if initial portion of string begin with '$',
5696 ; or '0x', or '0X', the conversion is done in base 16, otherwise in base 10.
5697 ; In decimal conversion an optional single sign '+' or '-' can precede any
5698 ; decimal digit, while in hexadecimal conversion just hexadecimal's digits
5699 ; (both lower case and upper case) can follow the initial '$' or '0x'.
5700 ; Conversion stop at the end of the string or at the first character that
5701 ; does not produce a valid digit in the given base, and tlp hold the long
5702 ; pointer to this character.
5703 ;
5704 ;-------
5705 F8510F str2int:
5706 ;-------
5707 F8510F 85 4C sta tlp ; set long pointer to source ascii string
5708 F85111 86 4D stx tlp+1
5709 F85113 84 4E sty tlp+2
5710 F85115 EB xba ; signed flag
Tue Jul 17 11:00:18 2018 Page 54
5711
5712 ;--------
5713 F85116 str2int2:
5714 ;--------
5715 F85116 29 80 and #$80 ; mask signed flag
5716 F85118 09 60 ora #$60 ; set bit 6&5 (assume integer = 0)
5717 F8511A 85 25 sta facst ; flag signed conversion
5718 F8511C 64 24 stz facsgn ; assume positive sign
5719 F8511E A2 11 ldx #17 ; clear facm
5720 F85120 74 12 ?clr: stz facm,x ; facexp used for overflow check (extension)
5721 F85122 CA dex
5722 F85123 10 FB bpl ?clr
5723 F85125 64 3F stz wftmp+1 ; digit's flag
5724 F85127 A0 00 ldy #0 ; init string pointer
5725 F85129 80 03 bra ?get0
5726 F8512B C8 ?nx0: iny
5727 F8512C F0 55 beq ?iy ; string index overflow
5728 F8512E B7 4C ?get0: lda [tlp],y ; get char
5729 F85130 F0 54 beq ?eos ; end of string
5730 F85132 C9 20 cmp #' '
5731 F85134 F0 F5 beq ?nx0 ; skip leading blanks
5732 F85136 C9 08 cmp #$08
5733 F85138 F0 F1 beq ?nx0 ; skip leading 'tab'
5734 F8513A C9 24 cmp #'$' ; hex. string?
5735 F8513C F0 7E beq ?hex ; yes, convert ascii hex. string
5736 F8513E C9 30 cmp #'0'
5737 F85140 D0 12 bne ?dec ; go to decimal conversion
5738 F85142 AA tax ; save char
5739 F85143 C8 iny ; bump pointer
5740 F85144 F0 3D beq ?iy ; string index overflow
5741 F85146 B7 4C lda [tlp],y ; get char
5742 F85148 C9 78 cmp #'x' ; '0x' so hex. conversion
5743 F8514A F0 70 beq ?hex
5744 F8514C C9 58 cmp #'X' ; '0X' so hex. conversion
5745 F8514E F0 6C beq ?hex
5746 F85150 88 dey ; re-fetch previous char
5747 F85151 8A txa ; this is '0'
5748 F85152 80 17 bra ?dec2 ; handle decimal digit
5749 F85154
5750 ; parsing of ascii decimal string
5751 F85154 C9 2B ?dec: cmp #'+'
5752 F85156 F0 0C beq ?nxt ; skip '+' sign
5753 F85158 C9 2D cmp #'-'
5754 F8515A D0 0F bne ?dec2 ; handle decimal digit
5755 F8515C 24 25 bit facst ; convert to unsigned?
5756 F8515E 10 26 bpl ?eos ; invalid '-' sign in unsigned conversion
5757 F85160 A9 80 lda #$80
5758 F85162 85 24 sta facsgn ; set negative sign flag
5759 F85164 C8 ?nxt: iny ; next byte
5760 F85165 F0 1C beq ?iy ; string index overflow
5761 F85167 B7 4C lda [tlp],y ; get next char
5762 F85169 F0 1B beq ?eos ; end of string
5763 F8516B 38 ?dec2: sec
5764 F8516C E9 3A sbc #'0'+10
5765 F8516E 18 clc
5766 F8516F 69 0A adc #10
5767 F85171 90 13 bcc ?eos ; not a digit: stop string parsing
Tue Jul 17 11:00:18 2018 Page 55
5768 F85173 20 44 52 jsr ?m10 ; facm*10
5769 F85176 B0 1A bcs ?ov ; overflow
5770 F85178 20 7E 52 jsr ?addg ; fac=fac+digit
5771 F8517B B0 15 bcs ?ov ; overflow
5772 F8517D A9 80 lda #$80
5773 F8517F 85 3F sta wftmp+1 ; decimal digit indicator
5774 F85181 80 E1 bra ?nxt ; get next char
5775 F85183 88 ?iy: dey ; string index overflow
5776 F85184 80 15 bra ?er ; invalid string
5777 F85186 84 4F ?eos: sty fpidx ; end of string or end of parsing
5778 F85188 A6 3F ldx wftmp+1 ; parsed at least one digit?
5779 F8518A F0 11 beq ?er2 ; no, so error (invalid string)
5780 F8518C 20 02 52 jsr ?test ; final conversion test
5781 F8518F B8 clv ; no overflow
5782 F85190 90 13 bcc ?done ; CF=0, VF=0 -- ok
5783 F85192 A9 40 ?ov: lda #$40
5784 F85194 14 25 trb facst
5785 F85196 18 clc
5786 F85197 E2 40 sep #PVFLAG ; VF=1 -- overflow
5787 F85199 80 0A bra ?done ; CF=0, VF=1 if signed integer overflow
5788 F8519B 84 4F ?er: sty fpidx ; save string pointer
5789 F8519D A2 11 ?er2: ldx #17 ; clear facm
5790 F8519F 74 12 ?clr2: stz facm,x
5791 F851A1 CA dex
5792 F851A2 10 FB bpl ?clr2
5793 F851A4 38 sec ; error flag (invalid string)
5794 F851A5 08 ?done: php ; save carry
5795 F851A6 20 A4 52 jsr ?gsiz ; compute min. size
5796 F851A9 A5 4C lda tlp ; update string pointer
5797 F851AB 18 clc
5798 F851AC 65 4F adc fpidx
5799 F851AE 85 4C sta tlp
5800 F851B0 90 06 bcc ?end
5801 F851B2 E6 4D inc tlp+1
5802 F851B4 D0 02 bne ?end
5803 F851B6 E6 4E inc tlp+2
5804 F851B8 A7 4C ?end: lda [tlp] ; A=last parsed character
5805 F851BA 28 plp ; restore carry
5806 F851BB 60 rts
5807 F851BC
5808 ; parsing of ascii hex. string
5809 F851BC A9 60 ?hex: lda #$60
5810 F851BE 85 25 sta facst ; unsigned conversion only
5811 F851C0 C8 ?hex1: iny ; bump pointer
5812 F851C1 F0 C0 beq ?iy ; string index overflow
5813 F851C3 B7 4C ?hex2: lda [tlp],y ; get next char
5814 F851C5 F0 BF beq ?eos ; end of string
5815 F851C7 C9 61 cmp #'a' ; test hex. digit
5816 F851C9 90 02 bcc ?hex3
5817 F851CB E9 20 sbc #$20 ; capitalize 'a', 'b',...
5818 F851CD 38 ?hex3: sec
5819 F851CE E9 3A sbc #('0'+10) ; check digits '0'..'9'
5820 F851D0 18 clc
5821 F851D1 69 0A adc #10
5822 F851D3 B0 09 bcs ?hex4 ; ok, valid hex. digit
5823 F851D5 E9 16 sbc #(6+16) ; check 'A'..'F'
5824 F851D7 18 clc
Tue Jul 17 11:00:18 2018 Page 56
5825 F851D8 69 06 adc #6
5826 F851DA 90 AA bcc ?eos ; no hex digit: stop parsing
5827 F851DC 69 09 adc #9 ; valid hex. digit
5828 F851DE 29 0F ?hex4: and #$0F ; mask low nibble
5829 F851E0 85 3E sta wftmp
5830 F851E2 ACC16
5831 F851E2 C2 20 rep #PMFLAG
5832 .LONGA on
5833 .MNLIST
5834 F851E4 20 6B 52 jsr ?m2 ; facm*16
5835 F851E7 20 6B 52 jsr ?m2
5836 F851EA 20 6B 52 jsr ?m2
5837 F851ED 20 6B 52 jsr ?m2
5838 F851F0 A5 22 lda facm+16 ; overflow test
5839 F851F2 ACC08
5840 F851F2 E2 20 sep #PMFLAG
5841 .LONGA off
5842 .MNLIST
5843 F851F4 D0 9C bne ?ov ; overflow
5844 F851F6 A5 3E lda wftmp ; add hex. digit
5845 F851F8 05 12 ora facm ; last low nibble
5846 F851FA 85 12 sta facm
5847 F851FC A9 80 lda #$80
5848 F851FE 85 3F sta wftmp+1 ; digits flag
5849 F85200 80 BE bra ?hex1 ; continue string parsing
5850
5851 F85202 ?test: ACC16
5852 F85202 C2 20 rep #PMFLAG
5853 .LONGA on
5854 .MNLIST
5855 F85204 A5 20 lda facm+14 ; check if zero
5856 F85206 A2 0C ldx #12
5857 F85208 15 12 ?lp1: ora facm,x
5858 F8520A CA dex
5859 F8520B CA dex
5860 F8520C 10 FA bpl ?lp1
5861 F8520E C9 00 00 cmp #$0000
5862 F85211 ACC08
5863 F85211 E2 20 sep #PMFLAG
5864 .LONGA off
5865 .MNLIST
5866 F85213 F0 2B beq ?vf ; finish: integer = 0
5867 F85215 A9 40 lda #$40
5868 F85217 14 25 trb facst ; not zero integer indicator
5869 F85219 24 25 bit facst ; conversion test
5870 F8521B 10 23 bpl ?vf ; wanted unsigned integer: finish
5871 F8521D 24 24 bit facsgn ; if negative decimal...
5872 F8521F 30 06 bmi ?neg ; ...should negate facm
5873 F85221 A5 21 lda facm+15 ; should be <$80 if positive signed integer
5874 F85223 10 1B bpl ?vf ; finish: positive signed integer
5875 F85225 30 1B bmi ?of ; signed integer overflow
5876 F85227 ?neg: ACC16
5877 F85227 C2 20 rep #PMFLAG
5878 .LONGA on
5879 .MNLIST
5880 F85229 A2 00 ldx #0 ; facm index
5881 F8522B A0 08 ldy #8 ; counter (8 words)
Tue Jul 17 11:00:18 2018 Page 57
5882 F8522D 38 sec
5883 F8522E A9 00 00 ?lp2: lda #0 ; two's complement
5884 F85231 F5 12 sbc facm,x
5885 F85233 95 12 sta facm,x
5886 F85235 E8 inx
5887 F85236 E8 inx
5888 F85237 88 dey
5889 F85238 D0 F4 bne ?lp2
5890 F8523A A5 20 lda facm+14 ; must be negative
5891 F8523C ACC08
5892 F8523C E2 20 sep #PMFLAG
5893 .LONGA off
5894 .MNLIST
5895 F8523E 10 02 bpl ?of ; signed integer overflow
5896 F85240 18 ?vf: clc ; valid flag
5897 F85241 60 rts
5898 F85242 38 ?of: sec ; overflow
5899 F85243 60 rts
5900 F85244
5901 F85244 A2 11 ?m10: ldx #17 ; multiplies facm by 10
5902 F85246 84 4F sty fpidx ; save Y
5903 F85248 85 3E sta wftmp ; save digit
5904 F8524A B5 12 ?m101: lda facm,x ; move facm to argm
5905 F8524C 95 2A sta argm,x
5906 F8524E CA dex
5907 F8524F 10 F9 bpl ?m101
5908 F85251 ACC16
5909 F85251 C2 20 rep #PMFLAG
5910 .LONGA on
5911 .MNLIST
5912 F85253 20 6B 52 jsr ?m2 ; facm*2
5913 F85256 20 6B 52 jsr ?m2 ; facm*4
5914 F85259 20 91 52 jsr ?add ; facm*4+argm=facm*5
5915 F8525C 20 6B 52 jsr ?m2 ; facm*10
5916 F8525F A5 22 lda facm+16 ; check overflow
5917 F85261 ACC08
5918 F85261 E2 20 sep #PMFLAG
5919 .LONGA off
5920 .MNLIST
5921 F85263 F0 01 beq ?nof ; no overflow
5922 F85265 38 sec ; overflow flag
5923 F85266 A4 4F ?nof: ldy fpidx ; restore Y
5924 F85268 A5 3E lda wftmp ; restore digit
5925 F8526A 60 rts
5926
5927 F8526B 06 12 ?m2: asl facm ; multiplies facm by 2
5928 F8526D 26 14 rol facm+2
5929 F8526F 26 16 rol facm+4
5930 F85271 26 18 rol facm+6
5931 F85273 26 1A rol facm+8
5932 F85275 26 1C rol facm+10
5933 F85277 26 1E rol facm+12
5934 F85279 26 20 rol facm+14
5935 F8527B 26 22 rol facm+16
5936 F8527D 60 rts
5937
5938 F8527E 84 4F ?addg: sty fpidx ; add digit to facm - save Y
Tue Jul 17 11:00:18 2018 Page 58
5939 F85280 85 2A sta argm ; digit
5940 F85282 ACC16 ; argm was already cleared
5941 F85282 C2 20 rep #PMFLAG
5942 .LONGA on
5943 .MNLIST
5944 F85284 20 91 52 jsr ?add
5945 F85287 A5 22 lda facm+16 ; check overflow
5946 F85289 ACC08
5947 F85289 E2 20 sep #PMFLAG
5948 .LONGA off
5949 .MNLIST
5950 F8528B F0 01 beq ?nof1 ; no overflow
5951 F8528D 38 sec ; overflow flag
5952 F8528E A4 4F ?nof1: ldy fpidx ; restore Y
5953 F85290 60 rts
5954
5955 F85291 18 ?add: clc ; facm=facm+argm
5956 F85292 A2 00 ldx #0 ; facm&argm index
5957 F85294 A0 09 ldy #9 ; counter (9 words)
5958 F85296 B5 12 ?ad1: lda facm,x ; facm=facm+argm
5959 F85298 75 2A adc argm,x
5960 F8529A 95 12 sta facm,x
5961 F8529C 74 2A stz argm,x ; and clear argm for later use
5962 F8529E E8 inx
5963 F8529F E8 inx
5964 F852A0 88 dey
5965 F852A1 D0 F3 bne ?ad1
5966 F852A3 60 rts
5967
5968 F852A4 B0 0E ?gsiz: bcs ?gse ; invalid string
5969 F852A6 A9 10 lda #16 ; assume max. possible size
5970 F852A8 85 24 sta facsgn
5971 F852AA 70 08 bvs ?gse ; overflow condition
5972 F852AC 24 25 bit facst ; compute min. integer size (in bytes #)
5973 F852AE 50 05 bvc ?gs0 ; not zero
5974 F852B0 A9 01 lda #1 ; zero can fit in one byte
5975 F852B2 85 24 sta facsgn
5976 F852B4 60 ?gse: rts
5977 F852B5 30 2C ?gs0: bmi ?gss ; signed integer
5978 F852B7 A2 10 ldx #16
5979 F852B9 ACC16
5980 F852B9 C2 20 rep #PMFLAG
5981 .LONGA on
5982 .MNLIST
5983 F852BB A5 20 lda facm+14
5984 F852BD 05 1E ora facm+12
5985 F852BF 05 1C ora facm+10
5986 F852C1 05 1A ora facm+8
5987 F852C3 D0 06 bne ?gs1 ; 16 bytes integer
5988 F852C5 A2 08 ldx #8
5989 F852C7 A5 18 lda facm+6
5990 F852C9 05 16 ora facm+4
5991 F852CB ?gs1: ACC08
5992 F852CB E2 20 sep #PMFLAG
5993 .LONGA off
5994 .MNLIST
5995 F852CD D0 11 bne ?gs2 ; 8 bytes integer
Tue Jul 17 11:00:18 2018 Page 59
5996 F852CF A2 04 ldx #4
5997 F852D1 A5 15 lda facm+3
5998 F852D3 D0 0B bne ?gs2 ; 4 bytes integer
5999 F852D5 CA dex
6000 F852D6 A5 14 lda facm+2
6001 F852D8 D0 06 bne ?gs2 ; 3 bytes integer (long pointer)
6002 F852DA CA dex
6003 F852DB A5 13 lda facm+1
6004 F852DD D0 01 bne ?gs2 ; 2 bytes integer
6005 F852DF CA dex ; 1 byte integer
6006 F852E0 86 24 ?gs2: stx facsgn
6007 F852E2 60 rts
6008 F852E3 A4 21 ?gss: ldy facm+15
6009 F852E5 10 3F bpl ?gsp ; signed integer is positive
6010 F852E7 A2 10 ldx #16
6011 F852E9 ACC16
6012 F852E9 C2 20 rep #PMFLAG
6013 .LONGA on
6014 .MNLIST
6015 F852EB A5 20 lda facm+14
6016 F852ED 25 1E and facm+12
6017 F852EF 25 1C and facm+10
6018 F852F1 25 1A and facm+8
6019 F852F3 C9 FF FF cmp #$FFFF
6020 F852F6 D0 29 bne ?gs4 ; 16 bytes signed integer
6021 F852F8 A5 18 lda facm+6
6022 F852FA 10 25 bpl ?gs4 ; 16 bytes signed integer
6023 F852FC A2 08 ldx #8
6024 F852FE 25 16 and facm+4
6025 F85300 C9 FF FF cmp #$FFFF
6026 F85303 D0 1C bne ?gs4 ; 8 bytes signed integer
6027 F85305 A5 14 lda facm+2
6028 F85307 10 18 bpl ?gs4 ; 8 bytes signed integer
6029 F85309 A2 04 ldx #4
6030 F8530B C9 FF FF cmp #$FFFF
6031 F8530E ACC08
6032 F8530E E2 20 sep #PMFLAG
6033 .LONGA off
6034 .MNLIST
6035 F85310 D0 0F bne ?gs4 ; 4 bytes signed integer
6036 F85312 A5 13 lda facm+1
6037 F85314 10 0B bpl ?gs4 ; 4 bytes signed integer
6038 F85316 A2 02 ldx #2
6039 F85318 C9 FF cmp #$FF
6040 F8531A D0 05 bne ?gs4 ; 2 bytes signed integer
6041 F8531C A5 12 lda facm
6042 F8531E 10 01 bpl ?gs4
6043 F85320 CA dex
6044 F85321 ?gs4: ACC08
6045 F85321 E2 20 sep #PMFLAG
6046 .LONGA off
6047 .MNLIST
6048 F85323 86 24 stx facsgn
6049 F85325 60 rts
6050 F85326 A2 10 ?gsp: ldx #16
6051 F85328 ACC16
6052 F85328 C2 20 rep #PMFLAG
Tue Jul 17 11:00:18 2018 Page 60
6053 .LONGA on
6054 .MNLIST
6055 F8532A A5 20 lda facm+14
6056 F8532C 05 1E ora facm+12
6057 F8532E 05 1C ora facm+10
6058 F85330 05 1A ora facm+8
6059 F85332 D0 25 bne ?gs6 ; 16 bytes signed integer
6060 F85334 A5 18 lda facm+6
6061 F85336 30 21 bmi ?gs6 ; 16 bytes signed integer
6062 F85338 A2 08 ldx #8
6063 F8533A 05 16 ora facm+4
6064 F8533C D0 1B bne ?gs6 ; 8 bytes signed integer
6065 F8533E A5 14 lda facm+2
6066 F85340 30 17 bmi ?gs6 ; 8 bytes signed integer
6067 F85342 A2 04 ldx #4
6068 F85344 C9 00 00 cmp #0
6069 F85347 D0 10 bne ?gs6 ; 4 bytes signed integer
6070 F85349 ACC08
6071 F85349 E2 20 sep #PMFLAG
6072 .LONGA off
6073 .MNLIST
6074 F8534B A5 13 lda facm+1
6075 F8534D 30 0A bmi ?gs6 ; 4 bytes signed integer
6076 F8534F A2 02 ldx #2
6077 F85351 A8 tay
6078 F85352 D0 05 bne ?gs6 ; 2 bytes signed integer
6079 F85354 A5 12 lda facm
6080 F85356 30 01 bmi ?gs6 ; 2 bytes signed integer
6081 F85358 CA dex ; 1 byte signed integer
6082 F85359 ?gs6: ACC08
6083 F85359 E2 20 sep #PMFLAG
6084 .LONGA off
6085 .MNLIST
6086 F8535B 86 24 stx facsgn
6087 F8535D 60 rts
6088 F8535E
6089 ; str2fp, str2fp2 - convert the initial portion of the source string to
6090 ; a 128 bits binary floating point.
6091 ;
6092 ; entry:
6093 ; A = low address of source string
6094 ; X = high address of source string
6095 ; Y = bank that hold source string
6096 ;
6097 ; str2fp2 is the re-entry point when long pointer tlp is already set,
6098 ; and in this case:
6099 ;
6100 ; entry:
6101 ; tlp = long pointer to source string
6102 ;
6103 ; exit:
6104 ; fac = converted floating point
6105 ; A = first character where conversion stop
6106 ; tlp = long pointer to first char. where conversion stop
6107 ; CF = 0 if conversion was succesfully done
6108 ; VF = 1 if fac=inf/nan
6109 ; CF = 1 (VF don't care) if input string is invalid
Tue Jul 17 11:00:18 2018 Page 61
6110 ;
6111 ; Conversion start parsing source string from left toward right, skipping any
6112 ; leading blank and/or tab.
6113 ; The expected form of the input string is either:
6114 ;
6115 ; +o an hexadecimal ascii string beginning with '$' or '0x' or '0X',
6116 ; followed by exactly 32 hexadecimal digits (case don't care) for
6117 ; the significand, followed by a 'p' or a 'P', followed by 4
6118 ; hexadecimals digits for the biased exponent. Significand sign
6119 ; should be ored with msb of the biased exponent.
6120 ; Example:
6121 ; $80000000000000000000000000000000pbfff = -1.0
6122 ; $80000000000000000000000000000000p3fff = +1.0
6123 ; $00000000000000000000000000000000p0000 = +0.0
6124 ; Number 0.0 can be expressed either by significand=0 and/or
6125 ; exponent=0.
6126 ;
6127 ; +0 an hexadecimal ascii string beginning with '#', followed by
6128 ; exactly 32 hexadecimal digits (case don't care), seen as a packed
6129 ; standard ieee quadruple format.
6130 ; Example:
6131 ; #bfff0000000000000000000000000000 = -1.0
6132 ; #3fff0000000000000000000000000000 = +1.0
6133 ; #00000000000000000000000000000000 = +0.0
6134 ;
6135 ; +o a decimal ascii string, beginning with an optional single '+'
6136 ; or '-' sign, followed by a decimal significand consisting of a
6137 ; sequence of decimal digits optionally containing a decimal-point
6138 ; character, '.'. The significand may be optionally followed by an
6139 ; exponent. An exponent consists of an 'E' or 'e' followed by an
6140 ; optional plus or minus sign, followed by a sequence of decimal
6141 ; digits; the exponent indicates the power of 10 by which the
6142 ; significand should be scaled.
6143 ;
6144 ; +o a string "+INF", "-INF", "+NAN", "-NAN", where the sign '+' or
6145 ; '-' is optional (case don't care).
6146 ;
6147 ; Conversion stop at the end of the string or at the first character that
6148 ; does not produce a valid digit in the given base, and tlp hold the long
6149 ; pointer to this character.
6150 ;
6151 ;------
6152 F8535E str2fp:
6153 ;------
6154 F8535E 85 4C sta tlp ; set long pointer to source ascii string
6155 F85360 86 4D stx tlp+1
6156 F85362 84 4E sty tlp+2
6157
6158 ;-------
6159 F85364 str2fp2:
6160 ;-------
6161 F85364 64 26 stz fexph ; clear exponent
6162 F85366 9C 6C 68 stz fexp+1
6163 F85369 64 B4 stz tmdot ; count of decimal digits (after a dot)
6164 F8536B 64 B5 stz tmdot+1
6165 F8536D 64 25 stz facst ; clear status
6166 F8536F 64 24 stz facsgn ; clear sign
Tue Jul 17 11:00:18 2018 Page 62
6167 F85371 64 B8 stz tmsgn ; sign&dot indicator
6168 F85373 64 B9 stz tmcnt ; count of mantissa digits
6169 F85375 64 BA stz tesgn ; sign&exponent indicator
6170 F85377 64 BB stz tecnt ; count of exponent digit
6171 F85379 20 56 4E jsr fldz ; set fac=0
6172 F8537C A0 00 ldy #0 ; init string pointer
6173 F8537E 80 03 bra ?get0
6174 F85380 C8 ?nx0: iny
6175 F85381 F0 69 beq ?iy ; string index overflow
6176 F85383 B7 4C ?get0: lda [tlp],y ; get char
6177 F85385 F0 68 beq ?eos ; end of string
6178 F85387 C9 20 cmp #' '
6179 F85389 F0 F5 beq ?nx0 ; skip leading blanks
6180 F8538B C9 08 cmp #$08
6181 F8538D F0 F1 beq ?nx0 ; skip leading 'tab'
6182 F8538F C9 23 cmp #'#' ; ieee packed hex. string?
6183 F85391 D0 05 bne ?ckh ; no
6184 F85393 20 74 55 jsr ?ieee ; convert hex. packed to float
6185 F85396 80 1D bra ?ehx
6186 F85398 C9 24 ?ckh: cmp #'$' ; hex. string?
6187 F8539A F0 16 beq ?hex ; yes, convert ascii hex. string
6188 F8539C C9 30 cmp #'0'
6189 F8539E D0 1B bne ?dec ; go to decimal conversion
6190 F853A0 AA tax ; save char
6191 F853A1 C8 iny ; bump pointer
6192 F853A2 F0 48 beq ?iy ; string index overflow
6193 F853A4 B7 4C lda [tlp],y ; get char
6194 F853A6 C9 78 cmp #'x' ; '0x' so hex. conversion
6195 F853A8 F0 08 beq ?hex
6196 F853AA C9 58 cmp #'X' ; '0X' so hex. conversion
6197 F853AC F0 04 beq ?hex
6198 F853AE 88 dey ; re-fetch previous char
6199 F853AF 8A txa ; this is '0'
6200 F853B0 80 1C bra ?dec2 ; handle decimal digit
6201 F853B2 20 C9 54 ?hex: jsr ?hfp ; convert hex. string to float
6202 F853B5 84 4F ?ehx: sty fpidx ; store index
6203 F853B7 B8 clv ; ignore VF for hex. conversion
6204 F853B8 4C 7F 54 jmp ?done
6205
6206 ; parsing of ascii decimal string
6207 F853BB C9 2B ?dec: cmp #'+'
6208 F853BD F0 08 beq ?nxt ; skip '+' sign
6209 F853BF C9 2D cmp #'-'
6210 F853C1 D0 0B bne ?dec2 ; handle decimal digit
6211 F853C3 A9 80 lda #$80
6212 F853C5 85 B8 sta tmsgn ; set negative sign flag
6213 F853C7 C8 ?nxt: iny ; next byte
6214 F853C8 F0 22 beq ?iy ; string index overflow
6215 F853CA B7 4C lda [tlp],y ; get next char
6216 F853CC F0 21 beq ?eos ; end of string
6217 F853CE 38 ?dec2: sec
6218 F853CF E9 3A sbc #'0'+10
6219 F853D1 18 clc
6220 F853D2 69 0A adc #10
6221 F853D4 90 29 bcc ?ndg ; is not a digit
6222 F853D6 24 BA bit tesgn ; will process exponent digits?
6223 F853D8 70 09 bvs ?edec ; yes
Tue Jul 17 11:00:18 2018 Page 63
6224 F853DA E6 B9 inc tmcnt ; count of mantissa digits
6225 F853DC 20 91 54 jsr ?mupd ; update mantissa (add digit)
6226 F853DF 90 E6 bcc ?nxt ; next byte
6227 F853E1 B0 5C bcs ?ovf ; overflow error
6228 F853E3 E6 BB ?edec: inc tecnt ; process exponent digit
6229 F853E5 20 AE 54 jsr ?eupd ; update exponent (add digit)
6230 F853E8 90 DD bcc ?nxt ; next byte
6231 F853EA B0 53 bcs ?ovf ; exponent overflow error
6232
6233 F853EC 88 ?iy: dey ; here when index overflow
6234 F853ED 80 5E bra ?nv ; invalid string
6235
6236 ; end of string or parsing of an invalid char
6237 F853EF 84 4F ?eos: sty fpidx ; store index
6238 F853F1 A6 B9 ldx tmcnt
6239 F853F3 F0 5A beq ?nv1 ; no mantissa digits: invalid string
6240 F853F5 24 BA bit tesgn
6241 F853F7 50 60 bvc ?sc ; no exponent: scale fac according decimals
6242 F853F9 A6 BB ldx tecnt
6243 F853FB F0 52 beq ?nv1 ; no exponent digits: invalid string
6244 F853FD 80 5A bra ?sc ; scale fac according to exponent&decimals
6245
6246 ; handle no-digit character
6247 F853FF 69 30 ?ndg: adc #'0' ; restore character
6248 F85401 C9 2E cmp #'.' ; check if decimal dot
6249 F85403 D0 0C bne ?cke ; go to check 'e', 'E'
6250 F85405 A6 B9 ldx tmcnt
6251 F85407 F0 44 beq ?nv ; no mantissa digits so error
6252 F85409 A9 40 lda #$40 ; test&set dot indicator
6253 F8540B 04 B8 tsb tmsgn
6254 F8540D D0 3E bne ?nv ; duplicate dot so error
6255 F8540F 80 B6 bra ?nxt ; next byte
6256 F85411 C9 45 ?cke: cmp #'E' ; check exponent
6257 F85413 F0 0B beq ?cke1
6258 F85415 C9 65 cmp #'e'
6259 F85417 F0 07 beq ?cke1
6260 F85419 20 F8 55 jsr ?ginf ; read INF or NAN string
6261 F8541C B0 D1 bcs ?eos ; invalid string
6262 F8541E 80 5F bra ?done
6263 F85420 A6 B9 ?cke1: ldx tmcnt
6264 F85422 F0 29 beq ?nv ; no mantissa digits so error
6265 F85424 A9 40 lda #$40 ; test&set dot indicator
6266 F85426 04 BA tsb tesgn
6267 F85428 D0 23 bne ?nv ; duplicate 'E' so error
6268 F8542A C8 iny ; get next byte
6269 F8542B F0 BF beq ?iy ; string index overflow
6270 F8542D B7 4C lda [tlp],y
6271 F8542F F0 BE beq ?eos ; end of string
6272 F85431 C9 2B cmp #'+'
6273 F85433 F0 92 beq ?nxt ; skip '+' sign
6274 F85435 C9 2D cmp #'-'
6275 F85437 D0 95 bne ?dec2 ; process this byte
6276 F85439 A9 80 lda #$80
6277 F8543B 04 BA tsb tesgn ; set negative exponent sign
6278 F8543D 80 88 bra ?nxt ; get next byte
6279
6280 ; mantissa or exponent overflow
Tue Jul 17 11:00:18 2018 Page 64
6281 F8543F 84 4F ?ovf: sty fpidx ; store index of last parsed byte
6282 F85441 A6 B8 ldx tmsgn ; attual mantissa sign
6283 F85443 86 24 stx facsgn
6284 F85445 20 7D 4E jsr fldinf ; load inf because overflow
6285 F85448 18 clc ; no error (string is valid)
6286 F85449 E2 40 sep #PVFLAG ; VF=1 (overflow)
6287 F8544B 80 32 bra ?done ; done
6288
6289 ; duplicate dot, duplicate 'E', no valid digits: invalid string
6290 F8544D 84 4F ?nv: sty fpidx
6291 F8544F A6 B8 ?nv1: ldx tmsgn ; attual mantissa sign
6292 F85451 86 24 stx facsgn
6293 F85453 20 56 4E jsr fldz ; fac=0
6294 F85456 38 sec ; error: invalid string
6295 F85457 80 26 bra ?done ; done
6296
6297 ; now scale fac according to decimal digits count & exponent
6298 F85459 A4 B8 ?sc: ldy tmsgn
6299 F8545B 84 24 sty facsgn
6300 F8545D A2 00 ldx #0
6301 F8545F ACC16
6302 F8545F C2 20 rep #PMFLAG
6303 .LONGA on
6304 .MNLIST
6305 F85461 38 sec
6306 F85462 8A txa ; change sign to decimal count
6307 F85463 E5 B4 sbc tmdot
6308 F85465 85 B4 sta tmdot
6309 F85467 A5 26 lda fexph
6310 F85469 A4 BA ldy tesgn ; check exponent sign
6311 F8546B 10 04 bpl ?sc1
6312 F8546D 49 FF FF eor #$FFFF ; change sign to exponent
6313 F85470 1A inc a
6314 F85471 18 ?sc1: clc
6315 F85472 65 B4 adc tmdot ; scale fac with this value
6316 F85474 ACC08
6317 F85474 E2 20 sep #PMFLAG
6318 .LONGA off
6319 .MNLIST
6320 F85476 20 2E 49 jsr scale10
6321 F85479 B8 clv ; VF=0
6322 F8547A 90 03 bcc ?done ; no overflow
6323 F8547C 18 clc ; no error (string is valid)
6324 F8547D E2 40 sep #PVFLAG ; VF=1 (overflow)
6325 F8547F 08 ?done: php ; save CF&VF
6326 F85480 A5 4C lda tlp
6327 F85482 18 clc
6328 F85483 65 4F adc fpidx
6329 F85485 85 4C sta tlp
6330 F85487 90 06 bcc ?rts
6331 F85489 E6 4D inc tlp+1
6332 F8548B D0 02 bne ?rts
6333 F8548D E6 4E inc tlp+2
6334 F8548F 28 ?rts: plp
6335 F85490 60 rts
6336
6337 ; update mantissa: fac=(fac*10)+byte (where A=byte)
Tue Jul 17 11:00:18 2018 Page 65
6338 F85491 84 B7 ?mupd: sty tmpy ; save Y
6339 F85493 85 B6 sta tmpa ; save A
6340 F85495 24 B8 bit tmsgn ; digit after a decimal dot?
6341 F85497 50 02 bvc ?mupd1 ; no
6342 F85499 E6 B4 inc tmdot ; increment decimal count
6343 F8549B 20 D1 49 ?mupd1: jsr mult10 ; fac=fac*10
6344 F8549E B0 0B bcs ?mupd2 ; invalid
6345 F854A0 20 39 84 jsr mvftoa ; move fac to arg
6346 F854A3 A5 B6 lda tmpa
6347 F854A5 20 49 4F jsr fldbyt ; load byte into fac
6348 F854A8 20 7D 45 jsr fpadd ; fac=(fac*10)+A
6349 F854AB A4 B7 ?mupd2: ldy tmpy ; restore string index
6350 F854AD 60 rts ; CF=1 if overflow
6351
6352 ; update exponent: fexph=(10*fexph)+A
6353 F854AE 85 B6 ?eupd: sta tmpa ; save byte to add
6354 F854B0 64 B7 stz tmpa+1 ; high byte = 0
6355 F854B2 ACC16
6356 F854B2 C2 20 rep #PMFLAG
6357 .LONGA on
6358 .MNLIST
6359 F854B4 A5 26 lda fexph
6360 F854B6 C9 CC 0C cmp #$0CCC ; check overflow condition
6361 F854B9 B0 0B bcs ?eupd1 ; limit exponent to $7FFF
6362 F854BB 85 3E sta wftmp
6363 F854BD 0A asl a ; mult. 10
6364 F854BE 0A asl a
6365 F854BF 65 3E adc wftmp
6366 F854C1 0A asl a
6367 F854C2 65 B6 adc tmpa ; add byte
6368 F854C4 85 26 sta fexph ; update exponent
6369 F854C6 ?eupd1: ACC08
6370 F854C6 E2 20 sep #PMFLAG
6371 .LONGA off
6372 .MNLIST
6373 F854C8 60 rts ; CF=1 if exponent overflow
6374
6375 ; convert hexadecimal string: $xxx...xxpyyyy
6376 ; where xx...xx=significand, yyyy=biased exponent
6377 F854C9 20 12 55 ?hfp: jsr ?ghex ; convert hex. to fp
6378 F854CC B0 50 bcs ?ghx ; error getting significand
6379 F854CE A2 0F ldx #15
6380 F854D0 B5 00 ?hfl: lda tm,x ; move tm to facm
6381 F854D2 95 12 sta facm,x
6382 F854D4 CA dex
6383 F854D5 10 F9 bpl ?hfl
6384 F854D7 20 1F 55 jsr ?hexp ; get high exponent
6385 F854DA B0 42 bcs ?ghx ; error
6386 F854DC AA tax
6387 F854DD 29 80 and #$80
6388 F854DF 85 24 sta facsgn ; sign
6389 F854E1 8A txa
6390 F854E2 29 7F and #$7F
6391 F854E4 85 23 sta facexp+1
6392 F854E6 20 2C 55 jsr ?2hex ; get low exponent
6393 F854E9 B0 33 bcs ?ghx ; error
6394 F854EB 85 22 sta facexp
Tue Jul 17 11:00:18 2018 Page 66
6395 F854ED 20 61 55 jsr ?hsep ; check end of string
6396 F854F0 B0 2C bcs ?ghx ; error
6397 F854F2 64 25 stz facst
6398 F854F4 20 E6 46 jsr chkz ; check if fac=0
6399 F854F7 24 25 bit facst
6400 F854F9 70 23 bvs ?ghx ; fac=0, exit (CF=0)
6401 F854FB A5 22 lda facexp
6402 F854FD 05 23 ora facexp+1 ; exponent=0?
6403 F854FF F0 0E beq ?hfz ; yes, set fac=0
6404 F85501 AA tax
6405 F85502 A5 21 lda facm+15
6406 F85504 30 06 bmi ?hf3 ; normal
6407 F85506 E0 01 cpx #1 ; subnormal should have exponent=1
6408 F85508 D0 68 bne ?1hex4 ; invalid string
6409 F8550A 18 clc
6410 F8550B 60 rts
6411 F8550C 4C DC 55 ?hf3: jmp ?htst ; test inf/nan
6412 F8550F 4C 56 4E ?hfz: jmp fldz
6413 F85512
6414 F85512 A2 0F ?ghex: ldx #15 ; get 128 bits hex
6415 F85514 20 2C 55 ?ghl: jsr ?2hex
6416 F85517 B0 05 bcs ?ghx ; error
6417 F85519 95 00 sta tm,x ; store (high-to-low order)
6418 F8551B CA dex
6419 F8551C 10 F6 bpl ?ghl
6420 F8551E 60 ?ghx: rts ; CF=0 if no error
6421
6422 F8551F C8 ?hexp: iny ; get 'p' biased high exponent
6423 F85520 F0 4F beq ?1hex3 ; string index overflow
6424 F85522 B7 4C lda [tlp],y ; get next char
6425 F85524 C9 70 cmp #'p' ; exponent indicator
6426 F85526 F0 04 beq ?2hex ; ok
6427 F85528 C9 50 cmp #'P'
6428 F8552A D0 46 bne ?1hex4 ; invalid string
6429
6430 F8552C 20 3F 55 ?2hex: jsr ?1hex ; convert two digits at time
6431 F8552F B0 ED bcs ?ghx ; error
6432 F85531 0A asl a ; high nibble
6433 F85532 0A asl a
6434 F85533 0A asl a
6435 F85534 0A asl a
6436 F85535 85 3E sta wftmp
6437 F85537 20 3F 55 jsr ?1hex ; get low nibble
6438 F8553A B0 E2 bcs ?ghx ; error
6439 F8553C 05 3E ora wftmp ; concatenate high & low nibble
6440 F8553E 60 rts ; CF=0, no error
6441
6442 F8553F C8 ?1hex: iny ; convert one hex. digit
6443 F85540 F0 2F beq ?1hex3 ; string index overflow
6444 F85542 B7 4C lda [tlp],y ; get next char
6445 F85544 F0 2C beq ?1hex4 ; premature end of string
6446 F85546 C9 61 cmp #'a' ; convert one hex digit
6447 F85548 90 02 bcc ?1hex1
6448 F8554A E9 20 sbc #$20 ; capitalize 'a', 'b',...
6449 F8554C 38 ?1hex1: sec
6450 F8554D E9 3A sbc #('0'+10) ; check digits '0'..'9'
6451 F8554F 18 clc
Tue Jul 17 11:00:18 2018 Page 67
6452 F85550 69 0A adc #10
6453 F85552 B0 09 bcs ?1hex2 ; ok, valid hex. digit
6454 F85554 E9 16 sbc #(6+16) ; check 'A'..'F'
6455 F85556 18 clc
6456 F85557 69 06 adc #6
6457 F85559 90 17 bcc ?1hex4 ; no hex digit: error
6458 F8555B 69 09 adc #9 ; valid hex. digit
6459 F8555D 29 0F ?1hex2: and #$0F ; mask low nibble
6460 F8555F 18 ?hxok: clc ; digit ok
6461 F85560 60 rts
6462 F85561 C8 ?hsep: iny ; check valid separator at the end of string
6463 F85562 F0 0D beq ?1hex3 ; string index overflow
6464 F85564 B7 4C lda [tlp],y ; get next char
6465 F85566 F0 F7 beq ?hxok ; ok, end of string
6466 F85568 C9 20 cmp #' ' ; should be a separator
6467 F8556A F0 F3 beq ?hxok ; blank
6468 F8556C C9 08 cmp #$08
6469 F8556E F0 EF beq ?hxok ; tab
6470 F85570 C8 iny ; invalid string
6471 F85571 88 ?1hex3: dey ; string too long
6472 F85572 38 ?1hex4: sec ; error
6473 F85573 60 rts
6474
6475 F85574 20 12 55 ?ieee: jsr ?ghex ; convert hex. to fp
6476 F85577 B0 A5 bcs ?ghx ; error getting significand
6477 F85579 20 61 55 jsr ?hsep ; check end of string
6478 F8557C B0 A0 bcs ?ghx ; error
6479 F8557E A5 0F lda tm+15
6480 F85580 AA tax
6481 F85581 29 80 and #$80
6482 F85583 85 24 sta facsgn ; sign
6483 F85585 8A txa
6484 F85586 29 7F and #$7F
6485 F85588 85 23 sta facexp+1
6486 F8558A A5 0E lda tm+14
6487 F8558C 85 22 sta facexp
6488 F8558E 38 sec ; hidden bit
6489 F8558F 05 23 ora facexp+1
6490 F85591 D0 04 bne ?ie1 ; normal: hidden bit=1
6491 F85593 18 clc ; subnormal: hidden bit=0
6492 F85594 1A inc a
6493 F85595 85 22 sta facexp ; subnormal have biased exponent=1
6494 F85597 ?ie1: ACC16
6495 F85597 C2 20 rep #PMFLAG
6496 .LONGA on
6497 .MNLIST
6498 F85599 A5 0C lda tm+12
6499 F8559B 6A ror a ; rotate in hidden bit
6500 F8559C 85 20 sta facm+14
6501 F8559E A5 0A lda tm+10
6502 F855A0 6A ror a
6503 F855A1 85 1E sta facm+12
6504 F855A3 A5 08 lda tm+8
6505 F855A5 6A ror a
6506 F855A6 85 1C sta facm+10
6507 F855A8 A5 06 lda tm+6
6508 F855AA 6A ror a
Tue Jul 17 11:00:18 2018 Page 68
6509 F855AB 85 1A sta facm+8
6510 F855AD A5 04 lda tm+4
6511 F855AF 6A ror a
6512 F855B0 85 18 sta facm+6
6513 F855B2 A5 02 lda tm+2
6514 F855B4 6A ror a
6515 F855B5 85 16 sta facm+4
6516 F855B7 A5 00 lda tm
6517 F855B9 6A ror a
6518 F855BA 85 14 sta facm+2
6519 F855BC A9 00 00 lda #0 ; significand lsb
6520 F855BF 6A ror a
6521 F855C0 85 12 sta facm
6522 F855C2 05 14 ora facm+2 ; check if zero
6523 F855C4 05 16 ora facm+4
6524 F855C6 05 18 ora facm+6
6525 F855C8 05 1A ora facm+8
6526 F855CA 05 1C ora facm+10
6527 F855CC 05 1E ora facm+12
6528 F855CE 05 20 ora facm+14
6529 F855D0 D0 0A bne ?htst
6530 F855D2 85 22 sta facexp ; fac = 0
6531 F855D4 ACC08
6532 F855D4 E2 20 sep #PMFLAG
6533 .LONGA off
6534 .MNLIST
6535 F855D6 A9 40 lda #$40
6536 F855D8 85 25 sta facst
6537 F855DA 18 clc
6538 F855DB 60 rts
6539 F855DC ?htst: ACC16 ; test inf/nan
6540 F855DC C2 20 rep #PMFLAG
6541 .LONGA on
6542 .MNLIST
6543 F855DE A2 00 ldx #0
6544 F855E0 A5 22 lda facexp
6545 F855E2 C9 FF 7F cmp #INFEXP
6546 F855E5 90 0B bcc ?ie2 ; valid float
6547 F855E7 A2 C0 ldx #$C0 ; assume inf
6548 F855E9 A5 20 lda facm+14 ; check type
6549 F855EB C9 00 80 cmp #INFSND
6550 F855EE F0 02 beq ?ie2 ; set inf in fac stastus
6551 F855F0 A2 80 ldx #$80 ; set nan in fac status
6552 F855F2 86 25 ?ie2: stx facst
6553 F855F4 ACC08
6554 F855F4 E2 20 sep #PMFLAG
6555 .LONGA off
6556 .MNLIST
6557 F855F6 18 clc
6558 F855F7 60 rts
6559
6560 F855F8 C9 49 ?ginf: cmp #'I'
6561 F855FA F0 0E beq ?inf
6562 F855FC C9 69 cmp #'i'
6563 F855FE F0 0A beq ?inf
6564 F85600 C9 4E cmp #'N'
6565 F85602 F0 35 beq ?nan
Tue Jul 17 11:00:18 2018 Page 69
6566 F85604 C9 6E cmp #'n'
6567 F85606 F0 31 beq ?nan
6568 F85608 38 sec ; invalid string
6569 F85609 60 rts
6570 F8560A C8 ?inf: iny
6571 F8560B F0 29 beq ?inf3 ; string index overflow
6572 F8560D B7 4C lda [tlp],y ; get next char
6573 F8560F F0 26 beq ?inf4 ; end of string
6574 F85611 09 20 ora #$20
6575 F85613 C9 6E cmp #'n'
6576 F85615 D0 20 bne ?inf4
6577 F85617 C8 iny
6578 F85618 F0 1C beq ?inf3 ; string index overflow
6579 F8561A B7 4C lda [tlp],y ; get next char
6580 F8561C F0 19 beq ?inf4 ; end of string
6581 F8561E 09 20 ora #$20
6582 F85620 C9 66 cmp #'f'
6583 F85622 D0 13 bne ?inf4
6584 F85624 20 61 55 jsr ?hsep ; terminator or separator
6585 F85627 B0 0F bcs ?inf5
6586 F85629 84 4F sty fpidx
6587 F8562B 20 7D 4E jsr fldinf
6588 F8562E 18 ?inf0: clc
6589 F8562F A5 B8 lda tmsgn
6590 F85631 85 24 sta facsgn
6591 F85633 E2 40 sep #PVFLAG
6592 F85635 60 rts
6593 F85636 88 ?inf3: dey ; string too long
6594 F85637 38 ?inf4: sec ; error
6595 F85638 60 ?inf5: rts
6596
6597 F85639 C8 ?nan: iny
6598 F8563A F0 FA beq ?inf3 ; string index overflow
6599 F8563C B7 4C lda [tlp],y ; get next char
6600 F8563E F0 F7 beq ?inf4 ; end of string
6601 F85640 09 20 ora #$20
6602 F85642 C9 61 cmp #'a'
6603 F85644 D0 F1 bne ?inf4
6604 F85646 C8 iny
6605 F85647 F0 ED beq ?inf3 ; string index overflow
6606 F85649 B7 4C lda [tlp],y ; get next char
6607 F8564B F0 EA beq ?inf4 ; end of string
6608 F8564D 09 20 ora #$20
6609 F8564F C9 6E cmp #'n'
6610 F85651 D0 E4 bne ?inf4
6611 F85653 20 61 55 jsr ?hsep ; terminator or separator
6612 F85656 B0 E0 bcs ?inf5
6613 F85658 84 4F sty fpidx
6614 F8565A 20 74 4E jsr fldnan
6615 F8565D 80 CF bra ?inf0
6616 F8565F
6617 ;---------------------------------------------------------------------------
6618 ; conversion from binary to decimal
6619 ;---------------------------------------------------------------------------
6620
6621 ; int2str - convert an integer to asciiz string (decimal or hexadecimal)
6622 ;
Tue Jul 17 11:00:18 2018 Page 70
6623 ; This routine is intended to format a string used by sprintf()-like function,
6624 ; but can be used in stand-alone mode too.
6625 ;
6626 ; entry:
6627 ; facm = integer (1, 2, 4, 8, 16 bytes)
6628 ;
6629 ; A = additional formattation flags
6630 ; <7>: alternate format
6631 ; <6>: group thousands
6632 ; <1>: emit a sign '+' rather than a blank (if bit0=1)
6633 ; <0>: take account of bit 1, otherwise no '+'/blank emitted
6634 ;
6635 ; Y = format: x,X,p,P,d
6636 ;
6637 ; X = precision (minimum number of digits)
6638 ;
6639 ; exit:
6640 ; X = pointer to ascii buffer
6641 ; Y = size of buffer
6642 ;
6643 ; The integer parameter stored in facm will be converted, according to the
6644 ; format specifier and the requested precision, formatting the output ascii
6645 ; string null-terminated:
6646 ;
6647 ; p,P format: the integer is interpreted as long pointer (24 bits) and
6648 ; formatted as 6 hexadecimal digits prepended by '$' or by
6649 ; '0x' or '0X' if alternate format was specified.
6650 ; Precision ignored.
6651 ;
6652 ; x,X format: the integer is converted as unsigned and formatted as
6653 ; sequence of hexadecimal digits prepended by '$' or by
6654 ; '0x' or '0X' if alternate format was specified.
6655 ;
6656 ; d format: the integer is converted according to the status byte
6657 ; (facst) either as signed or unsigned integer, and
6658 ; formatted as sequence of decimal digits.
6659 ; If bit 6 of flags is 1, thousands are grouped
6660 ; 3 digits by 3 digits, separated by a comma.
6661 ;
6662 ; The precision, if any, gives the minimum number of digits that must appear;
6663 ; if the converted value requires fewer digits, it is padded on the left
6664 ; with zeros (precision is ignored for pP format).
6665 ;
6666 ;-------
6667 F8565F int2str:
6668 ;-------
6669 F8565F 85 CF sta fpaltf ; alternate flag format
6670 F85661 98 tya ; A=format char
6671 F85662 A0 00 ldy #0 ; upper case
6672 F85664 C9 61 cmp #'a'
6673 F85666 90 08 bcc ?nc
6674 F85668 C9 7B cmp #'z'+1
6675 F8566A B0 04 bcs ?nc
6676 F8566C 29 DF and #$DF ; capitalize
6677 F8566E A0 20 ldy #$20 ; lower case
6678 F85670 84 D0 ?nc: sty fpcap
6679 F85672 C9 50 cmp #'P'
Tue Jul 17 11:00:18 2018 Page 71
6680 F85674 F0 0A beq ?stf
6681 F85676 C9 58 cmp #'X'
6682 F85678 F0 06 beq ?stf
6683 F8567A C9 44 cmp #'D'
6684 F8567C F0 02 beq ?stf
6685 F8567E A9 44 lda #'D' ; force 'D' format if unknow one
6686 F85680 85 CE ?stf: sta fpfmt ; format style
6687 F85682 E0 50 cpx #XCVTMAX ; limit the precision to the buffer size
6688 F85684 90 02 bcc ?pr1
6689 F85686 A2 50 ldx #XCVTMAX
6690 F85688 C9 50 ?pr1: cmp #'P' ; 'P' format?
6691 F8568A D0 02 bne ?pr2
6692 F8568C A2 06 ldx #6 ; fixed precision = 6 for 'P' format
6693 F8568E 86 CC ?pr2: stx fpprec ; store wanted precision
6694 F85690 C9 44 cmp #'D'
6695 F85692 F0 24 beq ?dec ; decimal conversion
6696 F85694 A9 06 lda #$06 ; value to add for digits A..F
6697 F85696 05 D0 ora fpcap
6698 F85698 85 3E sta wftmp
6699 F8569A A9 7F lda #$7F ; ignore all format bits but bit 7
6700 F8569C 14 CF trb fpaltf
6701 F8569E A2 0F ldx #15 ; counter
6702 F856A0 A0 00 ldy #0
6703 F856A2 B5 12 ?hex: lda facm,x
6704 F856A4 20 74 5A jsr b2hex ; convert to hexadecimal
6705 F856A7 99 50 3F sta !P0FPU+fpstr,y ; store high digit
6706 F856AA C8 iny
6707 F856AB EB xba
6708 F856AC 99 50 3F sta !P0FPU+fpstr,y ; store low digit
6709 F856AF C8 iny
6710 F856B0 CA dex
6711 F856B1 10 EF bpl ?hex
6712 F856B3 BB tyx
6713 F856B4 74 50 stz fpstr,x ; put terminator
6714 F856B6 80 03 bra ?fmt ; final formattation
6715 F856B8 20 64 5B ?dec: jsr int2dec ; convert to decimal
6716 F856BB A2 50 ?fmt: ldx #fpstr ; get pointer to first and last digits
6717 F856BD 20 40 57 jsr ?frst ; X -> first, Y->last, A=size
6718 F856C0 20 1B 57 jsr ?thg ; move (and group) to the xcvt
6719 F856C3 BB tyx ; X = pointer to fisrt significative digit
6720 F856C4 85 3E sta wftmp ; A = size of significative string
6721 F856C6 A5 CC lda fpprec
6722 F856C8 38 sec
6723 F856C9 E5 3E sbc wftmp
6724 F856CB F0 0C beq ?nop ; no padding needs
6725 F856CD 90 0A bcc ?nop ; no padding needs
6726 F856CF A0 30 ldy #'0'
6727 F856D1 CA ?pad: dex
6728 F856D2 94 00 sty <0,x ; padding string with '0'
6729 F856D4 3A dec a
6730 F856D5 D0 FA bne ?pad
6731 F856D7 A5 CC lda fpprec
6732 F856D9 A8 ?nop: tay ; Y = string size
6733 F856DA A5 CE lda fpfmt
6734 F856DC C9 44 cmp #'D'
6735 F856DE F0 1D beq ?sts ; decimal formattation
6736 F856E0 C9 50 cmp #'P'
Tue Jul 17 11:00:18 2018 Page 72
6737 F856E2 D0 02 bne ?hx0
6738 F856E4 A2 C5 ldx #XCVTEND-6
6739 F856E6 24 CF ?hx0: bit fpaltf
6740 F856E8 10 0C bpl ?hx1 ; '$' prefix
6741 F856EA CA dex
6742 F856EB A9 58 lda #'X'
6743 F856ED 05 D0 ora fpcap ; add lower case
6744 F856EF 95 00 sta <0,x
6745 F856F1 C8 iny ; update size
6746 F856F2 A9 30 lda #'0' ; '0x' or '0X' prefix
6747 F856F4 80 02 bra ?hx2
6748 F856F6 A9 24 ?hx1: lda #'$'
6749 F856F8 CA ?hx2: dex
6750 F856F9 95 00 sta <0,x
6751 F856FB C8 iny ; update size
6752 F856FC 60 rts
6753 F856FD 84 4F ?sts: sty fpidx ; store sign according format flags
6754 F856FF 24 4A bit dsgn ; sign test
6755 F85701 10 04 bpl ?sts1 ; positive
6756 F85703 A0 2D ldy #'-' ; negative: store sign '-'
6757 F85705 80 0C bra ?sts2
6758 F85707 A5 CF ?sts1: lda fpaltf ; check if should store sign/blank
6759 F85709 4A lsr a ; fpaltf<0>: 1 if should store
6760 F8570A 90 0C bcc ?done ; no store
6761 F8570C A0 2B ldy #'+'
6762 F8570E 4A lsr a ; fpaltf<1>: 1 if should store blank
6763 F8570F B0 02 bcs ?sts2 ; store '+' sign
6764 F85711 A0 20 ldy #' ' ; store blank
6765 F85713 CA ?sts2: dex
6766 F85714 94 00 sty <0,x
6767 F85716 E6 4F inc fpidx
6768 F85718 A4 4F ?done: ldy fpidx
6769 F8571A 60 rts
6770
6771 ; move digits from fpstr buffer to xcvt buffer and
6772 ; group the digits in thousands (use comma as separator)
6773 ; on entry: Y = index of first significative digit on fpstr
6774 ; X = pointer to last digit on fpstr
6775 ; on exit: Y = pointer to first significative digit
6776 ; A = size of string
6777 ; X = pointer to last digit
6778 F8571B 84 3E ?thg: sty wftmp ; index of first significative digit
6779 F8571D 9B txy ; Y = pointer to last digit
6780 F8571E A2 CB ldx #XCVTEND ; X = pointer to end of xcvt buffer
6781 F85720 74 00 stz <0,x ; put string terminator
6782 F85722 CA dex ; bump pointer
6783 F85723 A9 03 ?thg2: lda #3 ; goups 3 digits
6784 F85725 EB ?thg4: xba ; B = digits counter
6785 F85726 B9 00 3F lda !P0FPU,y ; A = current digit
6786 F85729 95 00 sta <0,x ; move digit
6787 F8572B 88 dey
6788 F8572C C4 3E cpy wftmp ; finish?
6789 F8572E 90 10 bcc ?frst ; yes
6790 F85730 EB xba ; A = digits counter
6791 F85731 CA dex
6792 F85732 3A dec a
6793 F85733 D0 F0 bne ?thg4 ; groups 3 digits
Tue Jul 17 11:00:18 2018 Page 73
6794 F85735 24 CF bit fpaltf ; check if should groups thousands
6795 F85737 50 EA bvc ?thg2 ; no groups
6796 F85739 A9 2C lda #',' ; thousands separator
6797 F8573B 95 00 sta <0,x
6798 F8573D CA dex
6799 F8573E 80 E3 bra ?thg2 ; repeat until end of source string
6800
6801 ; get the pointer to first significative digit (not '0')
6802 ; on entry: X = pointer to first digit
6803 ; on exit: Y = pointer to first significative digit
6804 ; A = size of string
6805 ; X = pointer to last digit
6806 F85740 86 3F ?frst: stx wftmp+1
6807 F85742 B5 00 ?fr0: lda <0,x
6808 F85744 F0 07 beq ?fr1 ; end of string
6809 F85746 C9 30 cmp #'0'
6810 F85748 D0 04 bne ?fr2 ; first significative digit
6811 F8574A E8 inx
6812 F8574B 80 F5 bra ?fr0 ; search again
6813 F8574D CA ?fr1: dex ; X = pointer to last digit
6814 F8574E 9B ?fr2: txy ; Y = pointer to first significative digit
6815 F8574F A6 3F ldx wftmp+1 ; start of string
6816 F85751 B5 00 ?fr3: lda <0,x ; search end of string
6817 F85753 F0 03 beq ?fr4
6818 F85755 E8 inx
6819 F85756 80 F9 bra ?fr3
6820 F85758 CA ?fr4: dex ; X = pointer to last digit
6821 F85759 8A txa
6822 F8575A 84 3E sty wftmp
6823 F8575C 38 sec
6824 F8575D E5 3E sbc wftmp
6825 F8575F 1A inc a ; significative string size
6826 F85760 60 rts
6827
6828 ; fp2str - convert a quadruple precision floating point to asciiz string
6829 ;
6830 ; This routine is intended to format a string used by sprintf()-like function,
6831 ; but can be used in stand-alone mode too.
6832 ;
6833 ; entry:
6834 ; fac = floating point argument
6835 ;
6836 ; A = additional formattation flags
6837 ; <7>: alternate format
6838 ; <6>: not discriminate +0.0 from -0.0
6839 ; <1>: emit a sign '+' rather than a blank (if bit0=1)
6840 ; <0>: take account of bit 1, otherwise no '+'/blank emitted
6841 ;
6842 ; Y = format: e,E,f,F,g,G,a,A,k,K
6843 ;
6844 ; X = precision/count of decimal digits (after the '.')
6845 ;
6846 ; exit:
6847 ; X = pointer to ascii buffer
6848 ; Y = size of buffer
6849 ;
6850 ; The formatted decimal string is either the f/F format:
Tue Jul 17 11:00:18 2018 Page 74
6851 ; [sign]ddd.ddd
6852 ; or the e/E format:
6853 ; [sign]d.ddde+|-[d][d]dd
6854 ; where the number of digits after the decimal-point character is equal to
6855 ; precision specification. The exponent in E format always contains at least
6856 ; two digits; if the value is zero, the exponent is 00.
6857 ; In the G format, precision specifies the number of significant digits: if
6858 ; it is zero, is teeated as 1. G format can format decimal string in E style
6859 ; or F style: style E is used if the exponent from its conversion is less
6860 ; than MINGEXP or greater than or equal to the precision.
6861 ; Trailing decimal points are usually suppressed, as also are trailing
6862 ; fraction zeroes in the G/g format. If bit 7 of additional flag is 1
6863 ; then trailing decimal dot remain, and G/g format will not trim zeroes.
6864 ; The format a/A format an hexadecimal string that contain 32 hexadecimal
6865 ; digits (the content of the 128 bits mantissa), followed by the biased
6866 ; exponent (introduced by literal 'p' or 'P'), or-ed at bit 15 with sign of
6867 ; the float. Hexadecimal string is prepended either by '$' or '0x' or '0X'.
6868 ; The no-standard format k/K format an hexadecimal string that contain the 32
6869 ; hexadecimal digits of the packed float (ieee format).
6870 ; Hexadecimal string is prepended by '#'.
6871 ;
6872 ; The result formatted string can have at max. XCVTMAX characters: if the
6873 ; requested format & precision cannot fit into this limit, the format is
6874 ; switched to 'E' and limited in size.
6875 ;
6876 ;------
6877 F85761 fp2str:
6878 ;------
6879 F85761 85 CF sta fpaltf ; alternate flag format
6880 F85763 64 D1 stz fpstyle ; assume 'E' style
6881 F85765 98 tya ; A=format char
6882 F85766 A0 00 ldy #0 ; upper case
6883 F85768 C9 61 cmp #'a'
6884 F8576A 90 08 bcc ?nc
6885 F8576C C9 7B cmp #'z'+1
6886 F8576E B0 04 bcs ?nc
6887 F85770 29 DF and #$DF ; capitalize
6888 F85772 A0 20 ldy #$20 ; lower case
6889 F85774 84 D0 ?nc: sty fpcap
6890 F85776 C9 45 cmp #'E'
6891 F85778 F0 0E beq ?stf
6892 F8577A C9 46 cmp #'F'
6893 F8577C F0 0A beq ?stf
6894 F8577E C9 41 cmp #'A'
6895 F85780 F0 06 beq ?stf
6896 F85782 C9 4B cmp #'K'
6897 F85784 F0 02 beq ?stf
6898 F85786 A9 47 lda #'G' ; force 'G' format if unknow one
6899 F85788 85 CE ?stf: sta fpfmt ; format style
6900 F8578A E0 50 cpx #XCVTMAX ; limit the precision to the buffer size
6901 F8578C 90 02 bcc ?pr1
6902 F8578E A2 50 ldx #XCVTMAX
6903 F85790 C9 47 ?pr1: cmp #'G' ; 'G' format?
6904 F85792 D0 05 bne ?pr2 ; no
6905 F85794 9B txy ; if precision=0 and 'G' format...
6906 F85795 F0 06 beq ?pr3 ; ...then set precision=1
6907 F85797 D0 05 bne ?pr4 ; significant digits for 'G' format
Tue Jul 17 11:00:18 2018 Page 75
6908 F85799 C9 45 ?pr2: cmp #'E' ; 'E' format?
6909 F8579B D0 01 bne ?pr4 ; no
6910 F8579D E8 ?pr3: inx ; 'E' format need one digit more
6911 F8579E 86 CC ?pr4: stx fpprec ; store wanted precision
6912 F857A0 64 CD stz fpprec+1 ; extend precision P to 16 bits
6913
6914 ; P=fpprec specifies significant digits for 'E' & 'G' format,
6915 ; and digit counts of fractional part for 'F' format
6916 F857A2
6917 F857A2 C9 41 cmp #'A' ; 'A' format?
6918 F857A4 D0 5B bne ?kfmt ; no
6919 F857A6
6920 ; format floating point as hexadecimal full mantissa
6921 ; plus biased exponent (or-ed with mantissa sign)
6922 F857A6 A0 00 ldy #0 ; string index
6923 F857A8 24 CF bit fpaltf
6924 F857AA 10 0C bpl ?a1 ; '$' prfix
6925 F857AC A2 30 ldx #'0' ; '0x' or '0X' prefix
6926 F857AE 96 78 stx xcvt,y
6927 F857B0 C8 iny
6928 F857B1 A9 58 lda #'X'
6929 F857B3 05 D0 ora fpcap ; add lower case
6930 F857B5 AA tax
6931 F857B6 80 02 bra ?a2
6932 F857B8 A2 24 ?a1: ldx #'$'
6933 F857BA 96 78 ?a2: stx xcvt,y
6934 F857BC C8 iny
6935 F857BD A9 06 lda #$06 ; value to add for digits A..F
6936 F857BF 05 D0 ora fpcap
6937 F857C1 85 3E sta wftmp
6938 F857C3 A2 0F ldx #15 ; counter
6939 F857C5 B5 12 ?a4: lda facm,x
6940 F857C7 20 74 5A jsr b2hex ; convert
6941 F857CA 99 78 3F sta !P0FPU+xcvt,y ; store high digit
6942 F857CD C8 iny
6943 F857CE EB xba
6944 F857CF 99 78 3F sta !P0FPU+xcvt,y ; store low digit
6945 F857D2 C8 iny
6946 F857D3 CA dex
6947 F857D4 10 EF bpl ?a4
6948 F857D6 A9 50 lda #'P' ; exponent separator
6949 F857D8 05 D0 ora fpcap
6950 F857DA AA tax
6951 F857DB 96 78 stx xcvt,y
6952 F857DD C8 iny
6953 F857DE A5 24 lda facsgn
6954 F857E0 29 80 and #$80 ; mask sign
6955 F857E2 05 23 ora facexp+1
6956 F857E4 20 74 5A jsr b2hex ; convert high exponent + sign
6957 F857E7 99 78 3F sta !P0FPU+xcvt,y ; store high digit
6958 F857EA C8 iny
6959 F857EB EB xba
6960 F857EC 99 78 3F sta !P0FPU+xcvt,y ; store low digit
6961 F857EF C8 iny
6962 F857F0 A5 22 lda facexp
6963 F857F2 20 74 5A jsr b2hex ; convert low exponent
6964 F857F5 99 78 3F sta !P0FPU+xcvt,y ; store high digit
Tue Jul 17 11:00:18 2018 Page 76
6965 F857F8 C8 iny
6966 F857F9 EB xba
6967 F857FA 99 78 3F sta !P0FPU+xcvt,y ; store low digit
6968 F857FD C8 iny
6969 F857FE 4C A7 58 jmp ?done
6970
6971 F85801 C9 4B ?kfmt cmp #'K' ; packed format?
6972 F85803 D0 2B bne ?cvt ; no
6973 F85805 A9 00 lda #tm
6974 F85807 A2 3F ldx #>P0FPU
6975 F85809 A0 00 ldy #0
6976 F8580B 20 54 4D jsr fpack ; pack to tm..tm+15
6977 F8580E A0 00 ldy #0
6978 F85810 A2 23 ldx #'#'
6979 F85812 96 78 stx xcvt,y
6980 F85814 C8 iny
6981 F85815 A9 06 lda #$06 ; value to add for digits A..F
6982 F85817 05 D0 ora fpcap
6983 F85819 85 3E sta wftmp
6984 F8581B A2 0F ldx #15 ; counter
6985 F8581D B5 00 ?kl: lda tm,x
6986 F8581F 20 74 5A jsr b2hex ; convert
6987 F85822 99 78 3F sta !P0FPU+xcvt,y ; store high digit
6988 F85825 C8 iny
6989 F85826 EB xba
6990 F85827 99 78 3F sta !P0FPU+xcvt,y ; store low digit
6991 F8582A C8 iny
6992 F8582B CA dex
6993 F8582C 10 EF bpl ?kl
6994 F8582E 80 77 bra ?done
6995 F85830
6996 ; The basic conversion to a decimal string is done by fp2dec,
6997 ; with this function responsible for "customizing" the simple
6998 ; format which fp2dec returns.
6999 F85830 20 89 5A ?cvt: jsr fp2dec ; let E=dexp=decimal exponent
7000 F85833 24 25 bit facst ; fac is valid?
7001 F85835 10 14 bpl ?vf ; yes
7002 F85837 20 E0 59 jsr ?sts ; store sign
7003 F8583A A2 00 ldx #0 ; store string NAN or INF
7004 F8583C B5 50 ?inv: lda fpstr,x
7005 F8583E 05 D0 ora fpcap ; add lower case
7006 F85840 99 78 3F sta !P0FPU+xcvt,y ; store
7007 F85843 C8 iny
7008 F85844 E8 inx
7009 F85845 E0 03 cpx #3
7010 F85847 90 F3 bcc ?inv
7011 F85849 80 5C bra ?done ; done
7012 F8584B 20 FA 59 ?vf: jsr ?round10 ; round up decimal number
7013 F8584E
7014 ; Now that we have the basic string, decide what format the caller
7015 ; wants it to be put into. Use the F format if either of the
7016 ; following is true:
7017 ; o+ the format is 'f' or 'F'
7018 ; o+ the format is 'g' or 'G' and the exponent
7019 ; is between MINGEXP and precision (fpprec)
7020 ; and if overall digits count is less than XCVTMAX.
7021 F8584E A5 CE lda fpfmt
Tue Jul 17 11:00:18 2018 Page 77
7022 F85850 C9 45 cmp #'E'
7023 F85852 F0 42 beq ?end2 ; caller wants 'E' format
7024 F85854 C9 47 cmp #'G'
7025 F85856 ACC16CLC
7026 F85856 C2 21 rep #(PMFLAG.OR.PCFLAG)
7027 .LONGA on
7028 .MNLIST
7029 F85858 D0 1C bne ?ff ; caller wants 'F' format
7030 F8585A A5 48 lda dexp ; if E < 0...
7031 F8585C 30 08 bmi ?g1 ; ...compare vs. MINGEXP
7032 F8585E C5 CC cmp fpprec ; ...else compare with P
7033 F85860 B0 32 bcs ?end ; if E >= P select 'E' style
7034 F85862 A5 CC lda fpprec ; 'G' format, E>=0: overall digits count = P
7035 F85864 80 0C bra ?g2
7036 F85866 C9 FC FF ?g1: cmp #MINGEXP
7037 F85869 90 29 bcc ?end ; if E < MINGEXP select 'E' style
7038 F8586B 49 FF FF eor #$FFFF ; complement decimal exponent
7039 F8586E 1A inc a
7040 F8586F 18 clc
7041 F85870 65 CC adc fpprec ; 'G' format, E<0...
7042 F85872 85 3E ?g2: sta wftmp ; ...overall digits count = |E|+P
7043 F85874 80 0B bra ?f2
7044 F85876 A5 CC ?ff: lda fpprec ; 'F' format: P = P + 1
7045 F85878 1A inc a
7046 F85879 A6 49 ldx dexp+1
7047 F8587B 30 02 bmi ?f1 ; 'F', E<0: overall digits count = P+1
7048 F8587D 65 48 adc dexp ; 'F', E>=0: overall digits count = E+P+1
7049 F8587F 85 3E ?f1: sta wftmp
7050 F85881 C9 50 00 ?f2: cmp #XCVTMAX ; fit into buffer?
7051 F85884 ACC08
7052 F85884 E2 20 sep #PMFLAG
7053 .LONGA off
7054 .MNLIST
7055 F85886 90 06 bcc ?f3 ; yes
7056 F85888 A9 24 lda #MAXDIGITS
7057 F8588A 85 CC sta fpprec
7058 F8588C B0 08 bcs ?end2 ; force 'E' style
7059 F8588E A2 80 ?f3: ldx #$80
7060 F85890 86 D1 stx fpstyle ; select 'F' style
7061 F85892 80 02 bra ?end2
7062 F85894 ?end: ACC08
7063 F85894 E2 20 sep #PMFLAG
7064 .LONGA off
7065 .MNLIST
7066 F85896 20 E0 59 ?end2: jsr ?sts ; emit sign
7067 F85899 84 4F sty fpidx ; index of the first digit
7068 F8589B 24 D1 bit fpstyle ; 'F' format?
7069 F8589D 10 05 bpl ?ee ; no, 'E' format
7070 F8589F 20 AE 58 jsr ?ffmt
7071 F858A2 80 03 bra ?done
7072 F858A4 20 33 59 ?ee: jsr ?efmt
7073 F858A7 A2 00 ?done: ldx #0
7074 F858A9 96 78 stx xcvt,y
7075 F858AB A2 78 ldx #xcvt
7076 F858AD 60 rts
7077
7078 ; If E<0, the 'F' format place a digit '0' followed by a decimal dot,
Tue Jul 17 11:00:18 2018 Page 78
7079 ; followed by |E|-1 leading zeroes. After, place all needs significant
7080 ; digits.
7081 F858AE 64 4B ?ffmt: stz fpdot
7082 F858B0 A5 48 lda dexp ; exponent E
7083 F858B2 10 1A bpl ?ffp ; E>=0
7084 F858B4 A2 30 ldx #'0'
7085 F858B6 96 78 stx xcvt,y
7086 F858B8 C8 iny
7087 F858B9 A2 2E ldx #'.'
7088 F858BB 96 78 stx xcvt,y
7089 F858BD C8 iny
7090 F858BE C6 3E dec wftmp ; update digits count
7091 F858C0 C6 4B dec fpdot ; decimal dot indicatr
7092 F858C2 A2 30 ldx #'0'
7093 F858C4 1A ?ff0: inc a
7094 F858C5 F0 08 beq ?ffr ; when E=0 put significant...
7095 F858C7 96 78 stx xcvt,y ; put leading zeroes...
7096 F858C9 C8 iny
7097 F858CA C6 3E dec wftmp
7098 F858CC 80 F6 bra ?ff0 ; ...until E=0
7099 F858CE 1A ?ffp: inc a ; we increment exponent for easily manage '.'
7100 F858CF A2 00 ?ffr: ldx #0 ; index
7101 F858D1 85 46 sta scexp ; save current exponent
7102 F858D3
7103 ; Now write the regular digits, inserting a '.' if it is somewhere
7104 ; in the middle of the numeral.
7105 F858D3 B5 50 ?ffl: lda fpstr,x ; regular digit
7106 F858D5 F0 15 beq ?ff2 ; end
7107 F858D7 99 78 3F sta !P0FPU+xcvt,y ; store digit
7108 F858DA C8 iny
7109 F858DB E8 inx
7110 F858DC C6 3E dec wftmp
7111 F858DE C6 46 dec scexp
7112 F858E0 D0 F1 bne ?ffl ; loop until last digit or E=0
7113 F858E2 A9 2E lda #'.'
7114 F858E4 99 78 3F sta !P0FPU+xcvt,y ; store '.'
7115 F858E7 C8 iny
7116 F858E8 C6 4B dec fpdot ; decimal dot indicatr
7117 F858EA 80 E7 bra ?ffl
7118 F858EC A6 48 ?ff2: ldx dexp
7119 F858EE 30 19 bmi ?ff4 ; 0.dddd... form
7120 F858F0 24 4B bit fpdot
7121 F858F2 30 15 bmi ?ff4 ; no more integral digits
7122 F858F4 A5 46 lda scexp ; ddd.ddd... form
7123 F858F6 F0 11 beq ?ff4 ; no more integral digits
7124 F858F8 A2 30 ldx #'0' ; must complete an integral number padding it..
7125 F858FA 96 78 ?ff3: stx xcvt,y ; ...with zeroes
7126 F858FC C8 iny
7127 F858FD C6 3E dec wftmp
7128 F858FF 3A dec a
7129 F85900 D0 F8 bne ?ff3
7130 F85902 A2 2E ldx #'.' ; put in a trailing decimal dot
7131 F85904 96 78 stx xcvt,y
7132 F85906 C8 iny
7133 F85907 C6 4B dec fpdot ; decimal dot indicator
7134 F85909 A5 CE ?ff4: lda fpfmt
7135 F8590B C9 47 cmp #'G' ; 'G' format remove trailing zeroes...
Tue Jul 17 11:00:18 2018 Page 79
7136 F8590D D0 0B bne ?ff5
7137 F8590F 24 CF bit fpaltf ; ...if not alternate format
7138 F85911 30 07 bmi ?ff5
7139 F85913 24 4B bit fpdot ; ...and if was putted in a decimal dot
7140 F85915 10 03 bpl ?ff5
7141 F85917 4C CF 59 jmp ?trim ; trim trailing zeroes
7142 F8591A A5 3E ?ff5: lda wftmp ; pad string with '0'
7143 F8591C F0 08 beq ?ff7
7144 F8591E A2 30 ldx #'0'
7145 F85920 96 78 ?ff6: stx xcvt,y
7146 F85922 C8 iny
7147 F85923 3A dec a
7148 F85924 D0 FA bne ?ff6
7149 F85926 24 CF ?ff7: bit fpaltf ; trim trailing '.' if any...
7150 F85928 30 08 bmi ?ff8 ; ...and not alternate format
7151 F8592A 88 dey
7152 F8592B B6 78 ldx xcvt,y
7153 F8592D E0 2E cpx #'.'
7154 F8592F F0 01 beq ?ff8
7155 F85931 C8 iny
7156 F85932 60 ?ff8: rts
7157
7158 ; The E format always places one digit to the left of the decimal
7159 ; point, followed by fraction digits, and then an 'E' followed
7160 ; by a decimal exponent. The exponent is always 2 digits unless
7161 ; it is of magnitude > 99.
7162 F85933 A6 CC ?efmt: ldx fpprec
7163 F85935 E0 4A cpx #XCVTMAX-6
7164 F85937 90 02 bcc ?e0
7165 F85939 A2 4A ldx #XCVTMAX-6
7166 F8593B 86 3E ?e0: stx wftmp ; overall digits count
7167 F8593D A2 00 ldx #0 ; decimal string index
7168 F8593F B5 50 lda fpstr,x
7169 F85941 99 78 3F sta !P0FPU+xcvt,y ; store first digit
7170 F85944 C6 3E dec wftmp
7171 F85946 E8 inx
7172 F85947 C8 iny
7173 F85948 A9 2E lda #'.' ; decimal dot
7174 F8594A EB xba ; B='.'
7175 F8594B B5 50 lda fpstr,x ; follow a digit?
7176 F8594D D0 0B bne ?e2 ; yes
7177 F8594F 24 CF bit fpaltf ; if alternate format is false...
7178 F85951 10 36 bpl ?exx ; ...not emit trailing '.'
7179 F85953 EB xba ; otherwise yes
7180 F85954 99 78 3F sta !P0FPU+xcvt,y ; store '.'
7181 F85957 C8 iny
7182 F85958 80 2F bra ?exx ; emit exponent
7183 F8595A E8 ?e2: inx ; bump pointer
7184 F8595B EB xba
7185 F8595C 99 78 3F sta !P0FPU+xcvt,y ; store '.'
7186 F8595F C8 iny
7187 F85960 EB xba ; 2nd digit
7188 F85961 99 78 3F ?e3: sta !P0FPU+xcvt,y ; store following digits
7189 F85964 C8 iny
7190 F85965 C6 3E dec wftmp
7191 F85967 B5 50 lda fpstr,x ; next digit
7192 F85969 F0 03 beq ?e4 ; no more digits
Tue Jul 17 11:00:18 2018 Page 80
7193 F8596B E8 inx
7194 F8596C 80 F3 bra ?e3
7195 F8596E A5 CE ?e4: lda fpfmt
7196 F85970 C9 47 cmp #'G' ; 'G' format remove trailing zeroes...
7197 F85972 D0 09 bne ?e5
7198 F85974 24 CF bit fpaltf ; ...if not alternate format
7199 F85976 30 05 bmi ?e5
7200 F85978 20 CF 59 jsr ?trim ; trim trailing zeroes
7201 F8597B 80 0C bra ?exx ; emit exponent
7202 F8597D A5 3E ?e5: lda wftmp ; pad string with '0'
7203 F8597F F0 08 beq ?exx
7204 F85981 A2 30 ldx #'0'
7205 F85983 96 78 ?e6: stx xcvt,y
7206 F85985 C8 iny
7207 F85986 3A dec a
7208 F85987 D0 FA bne ?e6
7209 F85989 A9 45 ?exx: lda #'E' ; emit exponent
7210 F8598B 05 D0 ora fpcap ; add letter case
7211 F8598D 99 78 3F sta !P0FPU+xcvt,y
7212 F85990 C8 iny
7213 F85991 ACC16
7214 F85991 C2 20 rep #PMFLAG
7215 .LONGA on
7216 .MNLIST
7217 F85993 A2 2B ldx #'+'
7218 F85995 A5 48 lda dexp
7219 F85997 10 06 bpl ?exs ; positive exponent
7220 F85999 49 FF FF eor #$FFFF
7221 F8599C 1A inc a
7222 F8599D A2 2D ldx #'-'
7223 F8599F 85 00 ?exs: sta tm ; store unsigned exponent
7224 F859A1 85 46 sta scexp
7225 F859A3 96 78 stx xcvt,y ; store exponent sign
7226 F859A5 C8 iny
7227 F859A6 84 4F sty fpidx ; save string index
7228 F859A8 ACC08
7229 F859A8 E2 20 sep #PMFLAG
7230 .LONGA off
7231 .MNLIST
7232 F859AA 20 15 5C jsr w2dec ; convert exponent to decimal
7233 F859AD ACC16
7234 F859AD C2 20 rep #PMFLAG
7235 .LONGA on
7236 .MNLIST
7237 F859AF A2 01 ldx #1 ; index if exp>=1000
7238 F859B1 A5 46 lda scexp
7239 F859B3 C9 E8 03 cmp #1000
7240 F859B6 B0 07 bcs ?ex2
7241 F859B8 E8 inx ; 100 <= exp < 1000
7242 F859B9 C9 64 00 cmp #100
7243 F859BC B0 01 bcs ?ex2
7244 F859BE E8 inx ; exp < 100
7245 F859BF ?ex2: ACC08
7246 F859BF E2 20 sep #PMFLAG
7247 .LONGA off
7248 .MNLIST
7249 F859C1 A4 4F ldy fpidx ; string index
Tue Jul 17 11:00:18 2018 Page 81
7250 F859C3 B5 50 ?ex3: lda fpstr,x
7251 F859C5 F0 07 beq ?ex4
7252 F859C7 99 78 3F sta !P0FPU+xcvt,y
7253 F859CA C8 iny
7254 F859CB E8 inx
7255 F859CC 80 F5 bra ?ex3
7256 F859CE 60 ?ex4: rts
7257
7258 ; trim trailing zeroes
7259 F859CF 88 ?trim: dey ; pointer to last character
7260 F859D0 C4 4F cpy fpidx ; if it is the first digit...
7261 F859D2 F0 0A beq ?tr1 ; ...restore pointer and exit
7262 F859D4 B6 78 ldx xcvt,y
7263 F859D6 E0 30 cpx #'0' ; trim trailing '0'...
7264 F859D8 F0 F5 beq ?trim
7265 F859DA E0 2E cpx #'.' ; trim trailing '.' if any
7266 F859DC F0 01 beq ?tr2
7267 F859DE C8 ?tr1: iny
7268 F859DF 60 ?tr2: rts
7269
7270 F859E0 A0 00 ?sts: ldy #0 ; store sign according format flags
7271 F859E2 24 4A bit dsgn ; sign test
7272 F859E4 10 04 bpl ?sts1 ; positive
7273 F859E6 A2 2D ldx #'-' ; negative: store sign '-'
7274 F859E8 80 0C bra ?sts2
7275 F859EA A5 CF ?sts1: lda fpaltf ; check if should store sign/blank
7276 F859EC 4A lsr a ; fpaltf<0>: 1 if should store
7277 F859ED 90 0A bcc ?sts3 ; no store
7278 F859EF A2 2B ldx #'+'
7279 F859F1 4A lsr a ; fpaltf<1>: 1 if should store blank
7280 F859F2 B0 02 bcs ?sts2 ; store '+' sign
7281 F859F4 A2 20 ldx #' ' ; store blank
7282 F859F6 96 78 ?sts2: stx xcvt,y
7283 F859F8 C8 iny
7284 F859F9 60 ?sts3: rts
7285
7286 F859FA ?round10:
7287 ; Round up the decimal string according to the wanted precision P
7288 ; We round directly the decimal string at the N-th digit, where:
7289 ; o+ N=P if 'E' or 'G' format
7290 ; o+ N=E+P+1 if 'F' format
7291 ; round up with usual decimal method: round to nearest away from zero
7292 ;
7293 ; on entry VF=1 if decimal float = 0.0
7294
7295 F859FA A6 CC ldx fpprec ; X=P=precision (8 bit)
7296 F859FC A5 CE lda fpfmt ; A=wanted format
7297 F859FE 70 60 bvs ?zz ; number = 0
7298 F85A00 C9 46 cmp #'F'
7299 F85A02 D0 13 bne ?rnd ; 'E'&'G' format: N=P
7300 F85A04 ACC16CLC ; 'F' format: N=E+P+1
7301 F85A04 C2 21 rep #(PMFLAG.OR.PCFLAG)
7302 .LONGA on
7303 .MNLIST
7304 F85A06 A5 48 lda dexp ; signed addition
7305 F85A08 65 CC adc fpprec
7306 F85A0A 1A inc a ; N=E+P+1
Tue Jul 17 11:00:18 2018 Page 82
7307 F85A0B 30 40 bmi ?rtz ; if N<0 we round to zero
7308 F85A0D C9 24 00 cmp #MAXDIGITS ; we limit rounding to the max. possible
7309 F85A10 ACC08
7310 F85A10 E2 20 sep #PMFLAG
7311 .LONGA off
7312 .MNLIST
7313 F85A12 90 02 bcc ?rnd0
7314 F85A14 A9 24 lda #MAXDIGITS
7315 F85A16 AA ?rnd0: tax
7316 F85A17 E0 24 ?rnd: cpx #MAXDIGITS ; limit the digit index to round up
7317 F85A19 90 05 bcc ?rnd1 ; round up at N-th digit
7318 F85A1B A2 24 ldx #MAXDIGITS
7319 F85A1D 74 50 stz fpstr,x ; truncate??
7320 F85A1F 60 rts
7321 F85A20 B5 50 ?rnd1: lda fpstr,x ; last digit: can cause round up
7322 F85A22 74 50 stz fpstr,x ; truncate decimal string
7323 F85A24 C9 35 cmp #'5' ; if last digits < '5'...
7324 F85A26 90 24 bcc ?rend ; no round up
7325 F85A28 9B txy ; X=0?
7326 F85A29 D0 04 bne ?rnd2 ; no
7327 F85A2B
7328 ; special case for 'F' format when E<0: can happen that N=E+P+1=0
7329 ; in this case we round up to '1' theb first digit and increment
7330 ; decimal exponent
7331 F85A2B 64 51 stz fpstr+1 ; string contain just one digits '1'...
7332 F85A2D 80 13 bra ?rinc ; ...and we increment exponent
7333 F85A2F A0 30 ?rnd2: ldy #'0'
7334 F85A31 CA ?rndl: dex ; previous digit index
7335 F85A32 30 0E bmi ?rinc ; rounding up zeroes all digits...
7336 F85A34 B5 50 lda fpstr,x
7337 F85A36 1A inc a ; round up digit
7338 F85A37 C9 3A cmp #'9'+1
7339 F85A39 90 04 bcc ?rnd3 ; stop rounding up
7340 F85A3B 94 50 sty fpstr,x ; round digit to '0'...
7341 F85A3D B0 F2 bcs ?rndl ; ...and repeat
7342 F85A3F 95 50 ?rnd3: sta fpstr,x ; store rounded digit
7343 F85A41 60 rts ; stop rounding up
7344 F85A42 ?rinc: ACC16 ; rounding generate a carry to first digit
7345 F85A42 C2 20 rep #PMFLAG
7346 .LONGA on
7347 .MNLIST
7348 F85A44 E6 48 inc dexp ; increment decimal exponent
7349 F85A46 ACC08
7350 F85A46 E2 20 sep #PMFLAG
7351 .LONGA off
7352 .MNLIST
7353 F85A48 A9 31 lda #'1' ; store '1' because rounding change a 999...
7354 F85A4A 85 50 sta fpstr ; ...to 1000...
7355 F85A4C 60 ?rend: rts
7356 F85A4D ?rtz: ACC08 ; round to zero
7357 F85A4D E2 20 sep #PMFLAG
7358 .LONGA off
7359 .MNLIST
7360 F85A4F A9 30 lda #'0'
7361 F85A51 A2 25 ldx #EXP10-1 ; zeroes all digits...
7362 F85A53 74 51 stz fpstr+1,x
7363 F85A55 95 50 ?zlp: sta fpstr,x
Tue Jul 17 11:00:18 2018 Page 83
7364 F85A57 CA dex
7365 F85A58 10 FB bpl ?zlp
7366 F85A5A 64 48 stz dexp ; clear decimal exponent
7367 F85A5C A6 CC ldx fpprec
7368 F85A5E A5 CE lda fpfmt ; A=wanted format
7369 F85A60 C9 46 ?zz: cmp #'F'
7370 F85A62 D0 01 bne ?z1
7371 F85A64 E8 inx ; 'F' format: one digit more for '0'
7372 F85A65 E0 24 ?z1: cpx #MAXDIGITS ; limit the digit index
7373 F85A67 90 02 bcc ?z2
7374 F85A69 A2 24 ldx #MAXDIGITS
7375 F85A6B 74 50 ?z2: stz fpstr,x ; truncate string
7376 F85A6D 24 CF bit fpaltf ; check for a signed zero or not
7377 F85A6F 50 02 bvc ?z3 ; standard signed zero
7378 F85A71 64 4A stz dsgn ; force +0.0
7379 F85A73 60 ?z3: rts
7380
7381 ; convert byte to 2 hex. digits
7382 ; return A=high digit, B=low digit
7383 F85A74 b2hex:
7384 F85A74 48 pha ; save value
7385 F85A75 20 7E 5A jsr ?hex
7386 F85A78 EB xba ; B=low digit
7387 F85A79 68 pla ; restore value
7388 F85A7A 4A lsr a ; divide by 16
7389 F85A7B 4A lsr a
7390 F85A7C 4A lsr a
7391 F85A7D 4A lsr a
7392 F85A7E 29 0F ?hex: and #$0F ; mask nibble
7393 F85A80 C9 0A cmp #10
7394 F85A82 90 02 bcc ?hex1
7395 F85A84 65 3E adc wftmp ; add value for a..f/A..F
7396 F85A86 69 30 ?hex1: adc #'0'
7397 F85A88 60 rts
7398 F85A89
7399
7400 ; fp2dec - convert the floating point fac to decimal ascii string
7401 ;
7402 ; entry:
7403 ; fac = argument (either valid or invalid)
7404 ;
7405 ; exit:
7406 ; fpstr = 38 digits ascii decimal string (null terminated)
7407 ; (implicit decimal dot between first and 2nd digit)
7408 ; dsgn = sign of the decimal significand
7409 ; dexp = decimal exponent (2's complement)
7410 ;
7411 ; If fac is not valid return either the string 'NAN' or 'INF' according
7412 ; with fac status (dexp=don't care).
7413 ; If fac=0 (or rounded to 0.0), return a string of digits '0',
7414 ; and dexp=0.
7415 ;
7416 ; strategy:
7417 ;
7418 ; o find the decimal exponent N of the 'normalized' decimal floating
7419 ; point number, such that:
7420 ;
Tue Jul 17 11:00:18 2018 Page 84
7421 ; N
7422 ; |x| = d.ffff... 10 1<= d <=9, f=fractional part
7423 ;
7424 ; o scale |x| by a power of ten equal to M = 37 - N, such that:
7425 ;
7426 ; M N 37 - N 37
7427 ; y = x * 10 = d.ffff... * 10 * 10 = d.ffff... * 10
7428 ;
7429 ; select 37 justified by the fact that the maximum decimal exponent
7430 ; for a 128 bits number is 38.
7431 ;
7432 ; o this scaling give an y such that:
7433 ;
7434 ; 37 38
7435 ; 10 <= y < 10
7436 ;
7437 ; and y can be regarded as 'integral' value with 38 significative digits
7438 ; (first d digit, followed by 37 ffff... digits of the fractional part),
7439 ; and can be converted to decimal string. The implicit decimal dot is
7440 ; between first and 2nd digits.
7441 ;
7442 ; This routine is used internally and not intended for end use.
7443 ;
7444 ;------
7445 F85A89 fp2dec:
7446 ;------
7447 F85A89 A5 24 lda facsgn
7448 F85A8B 64 24 stz facsgn ; absolute fac
7449 F85A8D 85 4A sta dsgn ; save sign of decimal float
7450 F85A8F 64 48 stz dexp ; clear decimal exponent
7451 F85A91 64 49 stz dexp+1
7452 F85A93 24 25 bit facst
7453 F85A95 10 1B bpl ?vf
7454 F85A97 ACC16
7455 F85A97 C2 20 rep #PMFLAG
7456 .LONGA on
7457 .MNLIST
7458 F85A99 50 0A bvc ?nan ; fac=nan
7459 F85A9B A9 49 4E lda #'NI' ; fac=inf
7460 F85A9E 85 50 sta fpstr
7461 F85AA0 A9 46 00 lda #'F' ; store 'INF'
7462 F85AA3 80 08 bra ?end
7463 F85AA5 A9 4E 41 ?nan: lda #'AN'
7464 F85AA8 85 50 sta fpstr
7465 F85AAA A9 4E 00 lda #'N' ; store 'NAN'
7466 F85AAD 85 52 ?end: sta fpstr+2
7467 F85AAF ACC08
7468 F85AAF E2 20 sep #PMFLAG
7469 .LONGA off
7470 .MNLIST
7471 F85AB1 60 rts
7472 F85AB2 50 0C ?vf: bvc ?nz ; fac <> 0
7473 F85AB4 A9 30 lda #'0'
7474 F85AB6 A2 25 ldx #37 ; store 38 digits '0'...
7475 F85AB8 74 51 stz fpstr+1,x
7476 F85ABA 95 50 ?z: sta fpstr,x
7477 F85ABC CA dex
Tue Jul 17 11:00:18 2018 Page 85
7478 F85ABD 10 FB bpl ?z
7479 F85ABF 60 rts ; ...and exit
7480 F85AC0 A2 00 ?nz: ldx #0
7481 F85AC2 A5 21 lda facm+15
7482 F85AC4 30 09 bmi ?nf ; normal float
7483 F85AC6 A9 C5 lda #<fce64 ; pre-scale by 1e64 the subnormal float
7484 F85AC8 A0 5F ldy #>fce64
7485 F85ACA 20 D5 49 jsr fcmult
7486 F85ACD A2 FF ldx #$FF
7487 F85ACF 86 10 ?nf: stx fsubnf ; remember if we prescaled by 1e64
7488 F85AD1 20 26 4D jsr frndm ; round mantissa to 113 bits
7489 F85AD4
7490 ; For a fast evaluation of the decimal exponent, we make a swift
7491 ; estimate of the log10 of the float, then check it later.
7492 ; We can form the estimate by multiplying the binary exponent
7493 ; by a conversion factor Log10(2) with 16 bit accuracy, using
7494 ; an integer signed multiplication 16x16 and taking the high
7495 ; 16 bit of the result. The error is at most one digit up or
7496 ; down.
7497
7498 F85AD4 ACC16 ; get an estimate of the decimal exponent
7499 F85AD4 C2 20 rep #PMFLAG
7500 .LONGA on
7501 .MNLIST
7502 F85AD6 38 sec
7503 F85AD7 A5 22 lda facexp
7504 F85AD9 E9 FF 3F sbc #EBIAS
7505 F85ADC A2 10 ldx #<LOG2H ; log(2)*$10000 (approximate to 16 bits)
7506 F85ADE A0 4D ldy #>LOG2H
7507 F85AE0 20 CE 87 jsr imult ; return C=estimate exponent (high 16 bits)
7508 F85AE3 85 48 sta dexp ; this can be +/-1 from the real decimal exp.
7509 F85AE5 A9 25 00 lda #EXP10-1 ; get difference exponent with 1e37...
7510 F85AE8 38 sec ; ... to scale fac in range [1e37..1e38-1]
7511 F85AE9 E5 48 sbc dexp
7512 F85AEB ACC08
7513 F85AEB E2 20 sep #PMFLAG
7514 .LONGA off
7515 .MNLIST
7516 F85AED 20 2E 49 jsr scale10 ; scale fac by 37 - N
7517 F85AF0
7518 ; now check if we will divide by 10 or multiplies by 10 to get
7519 ; the exact decimal exponent; should be: 1e37 <= fac < 1e38
7520
7521 F85AF0 A9 ED lda #<fce38 ; now compare fac vs. 1e38
7522 F85AF2 A0 5E ldy #>fce38
7523 F85AF4 20 5E 87 jsr fccmp ; should be fac<1e38
7524 F85AF7 30 0B bmi ?tst ; fac < 1e38, so go to check if fac>=1e37
7525 F85AF9 ACC16
7526 F85AF9 C2 20 rep #PMFLAG
7527 .LONGA on
7528 .MNLIST
7529 F85AFB E6 48 inc dexp ; increment decimal exponent...
7530 F85AFD ACC08 ; ...because next division by 10
7531 F85AFD E2 20 sep #PMFLAG
7532 .LONGA off
7533 .MNLIST
7534 F85AFF 20 06 4A jsr div10 ; fac=fac/10 so now fac<1e38
Tue Jul 17 11:00:18 2018 Page 86
7535 F85B02 80 14 bra ?cvt ; convert to decimal
7536 F85B04 A9 DB ?tst: lda #<fce37 ; now compare fac vs. 1e37
7537 F85B06 A0 5E ldy #>fce37
7538 F85B08 20 5E 87 jsr fccmp
7539 F85B0B F0 0B beq ?cvt ; fac=1e37
7540 F85B0D 10 09 bpl ?cvt ; fac>1e37
7541 F85B0F ACC16
7542 F85B0F C2 20 rep #PMFLAG
7543 .LONGA on
7544 .MNLIST
7545 F85B11 C6 48 dec dexp ; decrement decimal exponent because...
7546 F85B13 ACC08
7547 F85B13 E2 20 sep #PMFLAG
7548 .LONGA off
7549 .MNLIST
7550 F85B15 20 D1 49 jsr mult10 ; ...we mult x 10
7551
7552 ; now we have 1e37 <= fac < 1e38
7553 ; note that we no round fac because we use all 128 bits mantissa
7554 ; move fac mantissa (128 bits) to temporary mantissa tm
7555 F85B18 ?cvt: ACC16
7556 F85B18 C2 20 rep #PMFLAG
7557 .LONGA on
7558 .MNLIST
7559 F85B1A A6 10 ldx fsubnf ; we prescaled the float?
7560 F85B1C F0 08 beq ?cvt1 ; no
7561 F85B1E 38 sec
7562 F85B1F A5 48 lda dexp ; adjust decimal exponent
7563 F85B21 E9 40 00 sbc #64
7564 F85B24 85 48 sta dexp
7565 F85B26 A5 12 ?cvt1: lda facm ; we use guard bits too in conversion
7566 F85B28 85 00 sta tm
7567 F85B2A A5 14 lda facm+2
7568 F85B2C 85 02 sta tm+2
7569 F85B2E A5 16 lda facm+4
7570 F85B30 85 04 sta tm+4
7571 F85B32 A5 18 lda facm+6
7572 F85B34 85 06 sta tm+6
7573 F85B36 A5 1A lda facm+8
7574 F85B38 85 08 sta tm+8
7575 F85B3A A5 1C lda facm+10
7576 F85B3C 85 0A sta tm+10
7577 F85B3E A5 1E lda facm+12
7578 F85B40 85 0C sta tm+12
7579 F85B42 A5 20 lda facm+14
7580 F85B44 85 0E sta tm+14
7581 F85B46 A5 22 lda facexp ; get how many shift need to align tm...
7582 F85B48 38 sec ; ...to get the effective long integer
7583 F85B49 E9 7E 40 sbc #EBIAS+MNTBITS-1
7584 F85B4C ACC08 ; negative or null, just 8 bits value
7585 F85B4C E2 20 sep #PMFLAG
7586 .LONGA off
7587 .MNLIST
7588 F85B4E F0 05 beq ?cvt2 ; tm aligned, no shift
7589 F85B50 A2 00 ldx #tm
7590 F85B52 20 3A 47 jsr shrmx ; shift tm to right to align at 128 bits int.
7591 F85B55 20 9B 5B ?cvt2: jsr ui2dec ; convert integer to 39 decimal digits
Tue Jul 17 11:00:18 2018 Page 87
7592
7593 ; first digit is always a leading '0', beacuse 1e37 <= fac < 1e38
7594 ; max. integer is: 340282366920938463463374607431768211455 (> 1e38)
7595 F85B58
7596 F85B58 A2 00 ldx #0 ; we shift one digit to left (normalitation)
7597 F85B5A B5 51 ?sh: lda fpstr+1,x
7598 F85B5C 95 50 sta fpstr,x
7599 F85B5E F0 03 beq ?done
7600 F85B60 E8 inx
7601 F85B61 80 F7 bra ?sh
7602 F85B63 60 ?done: rts ; 38 digits + null terminator
7603
7604 ; int2dec - convert a signed/unsigned 128 bits long integer to decimal ascii
7605 ;
7606 ; entry:
7607 ; facm..facm+15 = signed long integer
7608 ;
7609 ; exit:
7610 ; fpstr = 39 digits ascii decimal string (null terminated)
7611 ;
7612 ; This routine check automatically if signed/unsigned (facst byte test, bit 7)
7613 ; Note: this routine store leading not-significative digits '0'
7614 ;
7615 ;-------
7616 F85B64 int2dec:
7617 ;-------
7618 F85B64 64 4A stz dsgn
7619 F85B66 A2 0F ldx #15 ; move facm to tm
7620 F85B68 B5 12 ?lp: lda facm,x
7621 F85B6A 95 00 sta tm,x
7622 F85B6C CA dex
7623 F85B6D 10 F9 bpl ?lp
7624 F85B6F 24 25 bit facst
7625 F85B71 10 28 bpl ui2dec ; unsigned integer
7626 F85B73 A5 0F lda tm+15
7627 F85B75 85 4A sta dsgn ; decimal sign
7628 F85B77 10 22 bpl ui2dec ; positive
7629 F85B79 ACC16
7630 F85B79 C2 20 rep #PMFLAG
7631 .LONGA on
7632 .MNLIST
7633 F85B7B A2 00 ldx #0
7634 F85B7D A0 08 ldy #8
7635 F85B7F 38 sec
7636 F85B80 A9 00 00 ?lp2: lda #0 ; two's complement
7637 F85B83 F5 00 sbc tm,x
7638 F85B85 95 00 sta tm,x
7639 F85B87 E8 inx
7640 F85B88 E8 inx
7641 F85B89 88 dey
7642 F85B8A D0 F4 bne ?lp2
7643 F85B8C ACC08
7644 F85B8C E2 20 sep #PMFLAG
7645 .LONGA off
7646 .MNLIST
7647 F85B8E 80 0B bra ui2dec ; negative
7648
Tue Jul 17 11:00:18 2018 Page 88
7649 ; uint2dec - convert an unsigned 128 bits long integer to decimal ascii
7650 ;
7651 ; entry:
7652 ; facm..facm+15 = unsigned long integer
7653 ;
7654 ; exit:
7655 ; fpstr = 39 digits ascii decimal string (null terminated)
7656 ;
7657 ; Note: this routine store leading not-significative digits '0'
7658 ;
7659 ;--------
7660 F85B90 uint2dec:
7661 ;--------
7662 F85B90 A2 0F ldx #15 ; move facm to tm
7663 F85B92 B5 12 ?lp: lda facm,x
7664 F85B94 95 00 sta tm,x
7665 F85B96 CA dex
7666 F85B97 10 F9 bpl ?lp
7667 F85B99 64 4A stz dsgn ; clear decimal sign
7668
7669 ; ui2dec - convert an unsigned 128 bits long integer to decimal ascii
7670 ;
7671 ; entry:
7672 ; tm..tm+15 = unsigned long integer
7673 ;
7674 ; exit:
7675 ; fpstr = 39 digits ascii decimal string (null terminated)
7676 ;
7677 ; Note: this routine store leading not-significative digits '0'
7678 ;
7679 ; This routine is used internally and not intended for end use.
7680 ;
7681 ;------
7682 F85B9B ui2dec:
7683 ;------
7684 F85B9B 8B phb ; save dbr
7685 F85B9C 4B phk
7686 F85B9D AB plb ; set current dbr=pbr
7687 F85B9E A2 00 ldx #0 ; index to decimal table
7688 F85BA0 86 3F stx wftmp+1 ; index to the destination ascii buffer
7689 F85BA2 A0 80 ldy #$80 ; partial quotient (alternate positive/neg.)
7690 F85BA4 ?lp: ACC16 ; main loop
7691 F85BA4 C2 20 rep #PMFLAG
7692 .LONGA on
7693 .MNLIST
7694 F85BA6 A5 00 ?sub: lda tm ; repeated subtraction's
7695 F85BA8 38 sec
7696 F85BA9 FD 6B 5C sbc !dectbl0,x ; low bytes
7697 F85BAC 85 00 sta tm
7698 F85BAE A5 02 lda tm+2
7699 F85BB0 FD 6D 5C sbc !dectbl0+2,x
7700 F85BB3 85 02 sta tm+2
7701 F85BB5 A5 04 lda tm+4
7702 F85BB7 FD 07 5D sbc !dectbl1,x
7703 F85BBA 85 04 sta tm+4
7704 F85BBC A5 06 lda tm+6
7705 F85BBE FD 09 5D sbc !dectbl1+2,x
Tue Jul 17 11:00:18 2018 Page 89
7706 F85BC1 85 06 sta tm+6
7707 F85BC3 A5 08 lda tm+8
7708 F85BC5 FD A3 5D sbc !dectbl2,x
7709 F85BC8 85 08 sta tm+8
7710 F85BCA A5 0A lda tm+10
7711 F85BCC FD A5 5D sbc !dectbl2+2,x
7712 F85BCF 85 0A sta tm+10
7713 F85BD1 A5 0C lda tm+12
7714 F85BD3 FD 3F 5E sbc !dectbl3,x
7715 F85BD6 85 0C sta tm+12
7716 F85BD8 A5 0E lda tm+14
7717 F85BDA FD 41 5E sbc !dectbl3+2,x
7718 F85BDD 85 0E sta tm+14 ; CF=0 if remainder is negative
7719 F85BDF C8 iny ; increment partial quotient (N flag)
7720 F85BE0 B0 04 bcs ?pr ; remainder is positive
7721 F85BE2 10 C2 bpl ?sub ; neg. rem. & pos. quot.: repeat subtraction
7722 F85BE4 30 02 bmi ?st ; else store digit
7723 F85BE6 30 BE ?pr: bmi ?sub ; pos. rem. & neg. quot.: repeat subtraction
7724 ; else store digit
7725 F85BE8 ?st: ACC08
7726 F85BE8 E2 20 sep #PMFLAG
7727 .LONGA off
7728 .MNLIST
7729 F85BEA 98 tya
7730 F85BEB 90 04 bcc ?nr ; remainder is negative
7731 F85BED 49 FF eor #$FF ; 10's complement of the quotient
7732 F85BEF 69 0A adc #10
7733 F85BF1 69 2F ?nr: adc #'0'-1 ; A is one more beacuse the 'iny'...
7734 F85BF3 A8 tay
7735 F85BF4 86 3E stx wftmp ; save counter
7736 F85BF6 A6 3F ldx wftmp+1 ; current decimal string index
7737 F85BF8 29 7F and #$7F ; strip off bit 7
7738 F85BFA 95 50 sta fpstr,x ; store digit
7739 F85BFC E8 inx
7740 F85BFD 86 3F stx wftmp+1 ; update string index
7741 F85BFF 98 tya ; invert sign of the starting quotient
7742 F85C00 49 FF eor #$FF
7743 F85C02 29 80 and #$80
7744 F85C04 A8 tay
7745 F85C05 A5 3E lda wftmp ; update table index
7746 F85C07 18 clc
7747 F85C08 69 04 adc #4
7748 F85C0A AA tax
7749 F85C0B E0 9C cpx #DTBLSIZ
7750 F85C0D 90 95 bcc ?lp ; repeat until done
7751 F85C0F A6 3F ldx wftmp+1 ; terminate decimal string...
7752 F85C11 74 50 stz fpstr,x ; ...with a null
7753 F85C13 AB plb ; restore dbr
7754 F85C14 60 rts
7755
7756 ; w2dec - convert an unsigned 16 bits integer to decimal ascii
7757 ;
7758 ; entry:
7759 ; C = unsigned 16 bits integer
7760 ;
7761 ; exit:
7762 ; fpstr = 5 bytes ascii decimal string (null terminated)
Tue Jul 17 11:00:18 2018 Page 90
7763 ;
7764 ; Note: this routine store leading not-significative digits '0'
7765 ;
7766 ;-----
7767 F85C15 w2dec:
7768 ;-----
7769 F85C15 8B phb ; save dbr
7770 F85C16 4B phk
7771 F85C17 AB plb ; set current dbr=pbr
7772 F85C18 A2 88 ldx #I16IDX ; index to decimal table
7773 F85C1A 64 3F stz wftmp+1 ; decimal string index
7774 F85C1C A0 80 ldy #$80 ; partial quotient (alternate positive/neg.)
7775 F85C1E ACC16
7776 F85C1E C2 20 rep #PMFLAG
7777 .LONGA on
7778 .MNLIST
7779 F85C20 85 00 sta tm ; 16 bit value
7780 F85C22 64 02 stz tm+2 ; sign extension
7781 F85C24 ?lp: ACC16 ; main loop
7782 F85C24 C2 20 rep #PMFLAG
7783 .LONGA on
7784 .MNLIST
7785 F85C26 A5 00 ?sub: lda tm ; repeated subtraction's
7786 F85C28 38 sec
7787 F85C29 FD 6B 5C sbc !dectbl0,x ; low bytes
7788 F85C2C 85 00 sta tm
7789 F85C2E A5 02 lda tm+2
7790 F85C30 FD 6D 5C sbc !dectbl0+2,x
7791 F85C33 85 02 sta tm+2 ; CF=0 if remainder is negative
7792 F85C35 C8 iny ; increment partial quotient
7793 F85C36 B0 04 bcs ?pr ; remainder is positive
7794 F85C38 10 EC bpl ?sub ; neg. rem. & pos. quot.: repeat subtraction
7795 F85C3A 30 02 bmi ?st ; else store digit
7796 F85C3C 30 E8 ?pr: bmi ?sub ; pos. rem. & neg. quot.: repeat subtraction
7797 ; else store digit
7798 F85C3E ?st: ACC08
7799 F85C3E E2 20 sep #PMFLAG
7800 .LONGA off
7801 .MNLIST
7802 F85C40 98 tya
7803 F85C41 90 04 bcc ?nr ; negative remainder
7804 F85C43 49 FF eor #$FF ; complement
7805 F85C45 69 0A adc #10
7806 F85C47 69 2F ?nr: adc #'0'-1
7807 F85C49 A8 tay
7808 F85C4A 86 3E stx wftmp
7809 F85C4C A6 3F ldx wftmp+1
7810 F85C4E 29 7F and #$7F
7811 F85C50 95 50 sta fpstr,x
7812 F85C52 E8 inx
7813 F85C53 86 3F stx wftmp+1
7814 F85C55 98 tya
7815 F85C56 49 FF eor #$FF
7816 F85C58 29 80 and #$80
7817 F85C5A A8 tay
7818 F85C5B A5 3E lda wftmp
7819 F85C5D 18 clc
Tue Jul 17 11:00:18 2018 Page 91
7820 F85C5E 69 04 adc #4
7821 F85C60 AA tax
7822 F85C61 E0 9C cpx #DTBLSIZ
7823 F85C63 90 BF bcc ?lp
7824 F85C65 A6 3F ldx wftmp+1
7825 F85C67 74 50 stz fpstr,x
7826 F85C69 AB plb
7827 F85C6A 60 rts
7828
7829 ; table of decreasing powers of ten, from 1e38 down to 1e0, with
7830 ; alternating sign, used to convert 128 bits integer in decimal
7831 ; Any constant is 128 bits, but table is splitted in four pieces,
7832 ; to easily access with an 8 bit index.
7833 ; bits from 0 to 31
7834 F85C6B dectbl0:
7835 F85C6B 00 00 00 00 .DB $00,$00,$00,$00 ; +1E38
7836 F85C6F 00 00 00 00 .DB $00,$00,$00,$00 ; -1E37
7837 F85C73 00 00 00 00 .DB $00,$00,$00,$00 ; +1E36
7838 F85C77 00 00 00 00 .DB $00,$00,$00,$00 ; -1E35
7839 F85C7B 00 00 00 00 .DB $00,$00,$00,$00 ; +1E34
7840 F85C7F 00 00 00 00 .DB $00,$00,$00,$00 ; -1E33
7841 F85C83 00 00 00 00 .DB $00,$00,$00,$00 ; +1E32
7842 F85C87 00 00 00 80 .DB $00,$00,$00,$80 ; -1E31
7843 F85C8B 00 00 00 40 .DB $00,$00,$00,$40 ; +1E30
7844 F85C8F 00 00 00 60 .DB $00,$00,$00,$60 ; -1E29
7845 F85C93 00 00 00 10 .DB $00,$00,$00,$10 ; +1E28
7846 F85C97 00 00 00 18 .DB $00,$00,$00,$18 ; -1E27
7847 F85C9B 00 00 00 E4 .DB $00,$00,$00,$E4 ; +1E26
7848 F85C9F 00 00 00 B6 .DB $00,$00,$00,$B6 ; -1E25
7849 F85CA3 00 00 00 A1 .DB $00,$00,$00,$A1 ; +1E24
7850 F85CA7 00 00 80 09 .DB $00,$00,$80,$09 ; -1E23
7851 F85CAB 00 00 40 B2 .DB $00,$00,$40,$B2 ; +1E22
7852 F85CAF 00 00 60 21 .DB $00,$00,$60,$21 ; -1E21
7853 F85CB3 00 00 10 63 .DB $00,$00,$10,$63 ; +1E20
7854 F85CB7 00 00 18 76 .DB $00,$00,$18,$76 ; -1E19
7855 F85CBB 00 00 64 A7 .DB $00,$00,$64,$A7 ; +1E18
7856 F85CBF 00 00 76 A2 .DB $00,$00,$76,$A2 ; -1E17
7857 F85CC3 00 00 C1 6F .DB $00,$00,$C1,$6F ; +1E16
7858 F85CC7 00 80 39 5B .DB $00,$80,$39,$5B ; -1E15
7859 F85CCB 00 40 7A 10 .DB $00,$40,$7A,$10 ; +1E14
7860 F85CCF 00 60 8D B1 .DB $00,$60,$8D,$B1 ; -1E13
7861 F85CD3 00 10 A5 D4 .DB $00,$10,$A5,$D4 ; +1E12
7862 F85CD7 00 18 89 B7 .DB $00,$18,$89,$B7 ; -1E11
7863 F85CDB 00 E4 0B 54 .DB $00,$E4,$0B,$54 ; +1E10
7864 F85CDF 00 36 65 C4 .DB $00,$36,$65,$C4 ; -1E09
7865 F85CE3 00 E1 F5 05 .DB $00,$E1,$F5,$05 ; +1E08
7866 F85CE7 80 69 67 FF .DB $80,$69,$67,$FF ; -1E07
7867 F85CEB 40 42 0F 00 .DB $40,$42,$0F,$00 ; +1E06
7868 F85CEF 60 79 FE FF .DB $60,$79,$FE,$FF ; -1E05
7869 F85CF3 10 27 00 00 .DB $10,$27,$00,$00 ; +1E04
7870 F85CF7 18 FC FF FF .DB $18,$FC,$FF,$FF ; -1E03
7871 F85CFB 64 00 00 00 .DB $64,$00,$00,$00 ; +1E02
7872 F85CFF F6 FF FF FF .DB $F6,$FF,$FF,$FF ; -1E01
7873 F85D03 01 00 00 00 .DB $01,$00,$00,$00 ; +1E00
7874
7875 ; bits from 32 to 63
7876 F85D07 dectbl1:
Tue Jul 17 11:00:18 2018 Page 92
7877 F85D07 40 22 8A 09 .DB $40,$22,$8A,$09 ; +1E38
7878 F85D0B 60 C9 0B FF .DB $60,$C9,$0B,$FF ; -1E37
7879 F85D0F 10 9F 4B B3 .DB $10,$9F,$4B,$B3 ; +1E36
7880 F85D13 18 70 78 D4 .DB $18,$70,$78,$D4 ; -1E35
7881 F85D17 64 8E 8D 37 .DB $64,$8E,$8D,$37 ; +1E34
7882 F85D1B F6 A4 3E C7 .DB $F6,$A4,$3E,$C7 ; -1E33
7883 F85D1F 81 EF AC 85 .DB $81,$EF,$AC,$85 ; +1E32
7884 F85D23 D9 B4 6E 3F .DB $D9,$B4,$6E,$3F ; -1E31
7885 F85D27 EA ED 74 46 .DB $EA,$ED,$74,$46 ; +1E30
7886 F85D2B 35 E8 8D 92 .DB $35,$E8,$8D,$92 ; -1E29
7887 F85D2F 61 02 25 3E .DB $61,$02,$25,$3E ; +1E28
7888 F85D33 C3 7F 2F 60 .DB $C3,$7F,$2F,$60 ; -1E27
7889 F85D37 D2 0C C8 DC .DB $D2,$0C,$C8,$DC ; +1E26
7890 F85D3B B7 FE EB E9 .DB $B7,$FE,$EB,$E9 ; -1E25
7891 F85D3F ED CC CE 1B .DB $ED,$CC,$CE,$1B ; +1E24
7892 F85D43 B5 1E 38 FD .DB $B5,$1E,$38,$FD ; -1E23
7893 F85D47 BA C9 E0 19 .DB $BA,$C9,$E0,$19 ; +1E22
7894 F85D4B 3A 52 36 CA .DB $3A,$52,$36,$CA ; -1E21
7895 F85D4F 2D 5E C7 6B .DB $2D,$5E,$C7,$6B ; +1E20
7896 F85D53 FB DC 38 75 .DB $FB,$DC,$38,$75 ; -1E19
7897 F85D57 B3 B6 E0 0D .DB $B3,$B6,$E0,$0D ; +1E18
7898 F85D5B 87 BA 9C FE .DB $87,$BA,$9C,$FE ; -1E17
7899 F85D5F F2 86 23 00 .DB $F2,$86,$23,$00 ; +1E16
7900 F85D63 81 72 FC FF .DB $81,$72,$FC,$FF ; -1E15
7901 F85D67 F3 5A 00 00 .DB $F3,$5A,$00,$00 ; +1E14
7902 F85D6B E7 F6 FF FF .DB $E7,$F6,$FF,$FF ; -1E13
7903 F85D6F E8 00 00 00 .DB $E8,$00,$00,$00 ; +1E12
7904 F85D73 E8 FF FF FF .DB $E8,$FF,$FF,$FF ; -1E11
7905 F85D77 02 00 00 00 .DB $02,$00,$00,$00 ; +1E10
7906 F85D7B FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E09
7907 F85D7F 00 00 00 00 .DB $00,$00,$00,$00 ; +1E08
7908 F85D83 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E07
7909 F85D87 00 00 00 00 .DB $00,$00,$00,$00 ; +1E06
7910 F85D8B FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E05
7911 F85D8F 00 00 00 00 .DB $00,$00,$00,$00 ; +1E04
7912 F85D93 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E03
7913 F85D97 00 00 00 00 .DB $00,$00,$00,$00 ; +1E02
7914 F85D9B FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E01
7915 F85D9F 00 00 00 00 .DB $00,$00,$00,$00 ; +1E00
7916
7917 ; bits from 64 to 95
7918 F85DA3 dectbl2:
7919 F85DA3 7A C4 86 5A .DB $7A,$C4,$86,$5A ; +1E38
7920 F85DA7 26 B9 25 2A .DB $26,$B9,$25,$2A ; -1E37
7921 F85DAB 15 07 C9 7B .DB $15,$07,$C9,$7B ; +1E36
7922 F85DAF 7D B2 38 8D .DB $7D,$B2,$38,$8D ; -1E35
7923 F85DB3 C0 87 AD BE .DB $C0,$87,$AD,$BE ; +1E34
7924 F85DB7 6C 72 BB 39 .DB $6C,$72,$BB,$39 ; -1E33
7925 F85DBB 5B 41 6D 2D .DB $5B,$41,$6D,$2D ; +1E32
7926 F85DBF DD DF 41 C8 .DB $DD,$DF,$41,$C8 ; -1E31
7927 F85DC3 D0 9C 2C 9F .DB $D0,$9C,$2C,$9F ; +1E30
7928 F85DC7 51 F0 E1 BC .DB $51,$F0,$E1,$BC ; -1E29
7929 F85DCB 5E CE 4F 20 .DB $5E,$CE,$4F,$20 ; +1E28
7930 F85DCF C3 D1 C4 FC .DB $C3,$D1,$C4,$FC ; -1E27
7931 F85DD3 D2 B7 52 00 .DB $D2,$B7,$52,$00 ; +1E26
7932 F85DD7 6A BA F7 FF .DB $6A,$BA,$F7,$FF ; -1E25
7933 F85DDB C2 D3 00 00 .DB $C2,$D3,$00,$00 ; +1E24
Tue Jul 17 11:00:18 2018 Page 93
7934 F85DDF D2 EA FF FF .DB $D2,$EA,$FF,$FF ; -1E23
7935 F85DE3 1E 02 00 00 .DB $1E,$02,$00,$00 ; +1E22
7936 F85DE7 C9 FF FF FF .DB $C9,$FF,$FF,$FF ; -1E21
7937 F85DEB 05 00 00 00 .DB $05,$00,$00,$00 ; +1E20
7938 F85DEF FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E19
7939 F85DF3 00 00 00 00 .DB $00,$00,$00,$00 ; +1E18
7940 F85DF7 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E17
7941 F85DFB 00 00 00 00 .DB $00,$00,$00,$00 ; +1E16
7942 F85DFF FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E15
7943 F85E03 00 00 00 00 .DB $00,$00,$00,$00 ; +1E14
7944 F85E07 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E13
7945 F85E0B 00 00 00 00 .DB $00,$00,$00,$00 ; +1E12
7946 F85E0F FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E11
7947 F85E13 00 00 00 00 .DB $00,$00,$00,$00 ; +1E10
7948 F85E17 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E09
7949 F85E1B 00 00 00 00 .DB $00,$00,$00,$00 ; +1E08
7950 F85E1F FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E07
7951 F85E23 00 00 00 00 .DB $00,$00,$00,$00 ; +1E06
7952 F85E27 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E05
7953 F85E2B 00 00 00 00 .DB $00,$00,$00,$00 ; +1E04
7954 F85E2F FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E03
7955 F85E33 00 00 00 00 .DB $00,$00,$00,$00 ; +1E02
7956 F85E37 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E01
7957 F85E3B 00 00 00 00 .DB $00,$00,$00,$00 ; +1E00
7958
7959 ; bits from 96 to 127
7960 F85E3F dectbl3:
7961 F85E3F A8 4C 3B 4B .DB $A8,$4C,$3B,$4B ; +1E38
7962 F85E43 EF 11 7A F8 .DB $EF,$11,$7A,$F8 ; -1E37
7963 F85E47 CE 97 C0 00 .DB $CE,$97,$C0,$00 ; +1E36
7964 F85E4B 9E BD EC FF .DB $9E,$BD,$EC,$FF ; -1E35
7965 F85E4F 09 ED 01 00 .DB $09,$ED,$01,$00 ; +1E34
7966 F85E53 B2 CE FF FF .DB $B2,$CE,$FF,$FF ; -1E33
7967 F85E57 EE 04 00 00 .DB $EE,$04,$00,$00 ; +1E32
7968 F85E5B 81 FF FF FF .DB $81,$FF,$FF,$FF ; -1E31
7969 F85E5F 0C 00 00 00 .DB $0C,$00,$00,$00 ; +1E30
7970 F85E63 FE FF FF FF .DB $FE,$FF,$FF,$FF ; -1E29
7971 F85E67 00 00 00 00 .DB $00,$00,$00,$00 ; +1E28
7972 F85E6B FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E27
7973 F85E6F 00 00 00 00 .DB $00,$00,$00,$00 ; +1E26
7974 F85E73 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E25
7975 F85E77 00 00 00 00 .DB $00,$00,$00,$00 ; +1E24
7976 F85E7B FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E23
7977 F85E7F 00 00 00 00 .DB $00,$00,$00,$00 ; +1E22
7978 F85E83 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E21
7979 F85E87 00 00 00 00 .DB $00,$00,$00,$00 ; +1E20
7980 F85E8B FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E19
7981 F85E8F 00 00 00 00 .DB $00,$00,$00,$00 ; +1E18
7982 F85E93 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E17
7983 F85E97 00 00 00 00 .DB $00,$00,$00,$00 ; +1E16
7984 F85E9B FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E15
7985 F85E9F 00 00 00 00 .DB $00,$00,$00,$00 ; +1E14
7986 F85EA3 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E13
7987 F85EA7 00 00 00 00 .DB $00,$00,$00,$00 ; +1E12
7988 F85EAB FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E11
7989 F85EAF 00 00 00 00 .DB $00,$00,$00,$00 ; +1E10
7990 F85EB3 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E09
Tue Jul 17 11:00:18 2018 Page 94
7991 F85EB7 00 00 00 00 .DB $00,$00,$00,$00 ; +1E08
7992 F85EBB FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E07
7993 F85EBF 00 00 00 00 .DB $00,$00,$00,$00 ; +1E06
7994 F85EC3 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E05
7995
7996 ; this portion is used by routine that convert 16 bits integer to decimal
7997 F85EC7 dec1e4:
7998 F85EC7 00 00 00 00 .DB $00,$00,$00,$00 ; +1E04
7999 F85ECB FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E03
8000 F85ECF 00 00 00 00 .DB $00,$00,$00,$00 ; +1E02
8001 F85ED3 FF FF FF FF .DB $FF,$FF,$FF,$FF ; -1E01
8002 F85ED7 00 00 00 00 .DB $00,$00,$00,$00 ; +1E00
8003
8004 00009C DTBLSIZ .EQU $-dectbl3
8005 000088 I16IDX .EQU dec1e4-dectbl3
8006
8007 ; limits for conversion float-to-decimal
8008 F85EDB 00 00 00 00 00 fce37: .DB $00,$00,$00,$00,$00,$D4,$86,$1E,$20
D4 86 1E 20
8009 F85EE4 DB 48 BB 1A C2 .DB $DB,$48,$BB,$1A,$C2,$BD,$F0,$79,$40 ; 1e37
BD F0 79 40
8010 F85EED
8011 F85EED 00 00 00 00 80 fce38: .DB $00,$00,$00,$00,$80,$44,$14,$13,$F4
44 14 13 F4
8012 F85EF6 88 0D B5 50 99 .DB $88,$0D,$B5,$50,$99,$76,$96,$7D,$40 ; 1e38
76 96 7D 40
8013
8014 ; table of constant for scaling (not rounded, 128 bits mantissa)
8015 ; used by scale10 routine (scaling by a power of ten)
8016 F85EFF 00 00 00 00 00 fce0: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8017 F85F08 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$80,$FF,$3F ; 1
00 80 FF 3F
8018 F85F11 00 00 00 00 00 fce1: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8019 F85F1A 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$A0,$02,$40 ; 10
00 A0 02 40
8020 F85F23 00 00 00 00 00 fce2: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8021 F85F2C 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$C8,$05,$40 ; 100
00 C8 05 40
8022 F85F35 00 00 00 00 00 fce3: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8023 F85F3E 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$FA,$08,$40 ; 1E3
00 FA 08 40
8024 F85F47 00 00 00 00 00 fce4: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8025 F85F50 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$40,$9C,$0C,$40 ; 1E4
40 9C 0C 40
8026 F85F59 00 00 00 00 00 fce5: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8027 F85F62 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$50,$C3,$0F,$40 ; 1E5
50 C3 0F 40
8028 F85F6B 00 00 00 00 00 fce6: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8029 F85F74 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$24,$F4,$12,$40 ; 1E6
24 F4 12 40
Tue Jul 17 11:00:18 2018 Page 95
8030 F85F7D 00 00 00 00 00 fce7: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8031 F85F86 00 00 00 00 80 .DB $00,$00,$00,$00,$80,$96,$98,$16,$40 ; 1E7
96 98 16 40
8032
8033 F85F8F 00 00 00 00 00 fce8: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8034 F85F98 00 00 00 00 20 .DB $00,$00,$00,$00,$20,$BC,$BE,$19,$40 ; 1E8
BC BE 19 40
8035
8036 F85FA1 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8037 F85FAA 00 00 04 BF C9 .DB $00,$00,$04,$BF,$C9,$1B,$8E,$34,$40 ; 1E16
1B 8E 34 40
8038
8039 F85FB3 00 00 00 00 00 fce32: .DB $00,$00,$00,$00,$00,$00,$20,$F0,$9D
00 20 F0 9D
8040 F85FBC B5 70 2B A8 AD .DB $B5,$70,$2B,$A8,$AD,$C5,$9D,$69,$40 ; 1E32
C5 9D 69 40
8041
8042 F85FC5 FA 25 6B C7 71 fce64: .DB $FA,$25,$6B,$C7,$71,$6B,$BF,$3C,$D5
6B BF 3C D5
8043 F85FCE A6 CF FF 49 1F .DB $A6,$CF,$FF,$49,$1F,$78,$C2,$D3,$40 ; 1E64
78 C2 D3 40
8044
8045 F85FD7 35 01 B1 36 6C .DB $35,$01,$B1,$36,$6C,$33,$6F,$C6,$DF
33 6F C6 DF
8046 F85FE0 8C E9 80 C9 47 .DB $8C,$E9,$80,$C9,$47,$BA,$93,$A8,$41 ; 1E128
BA 93 A8 41
8047
8048 F85FE9 B2 EA FE 98 1B .DB $B2,$EA,$FE,$98,$1B,$90,$BB,$DD,$8D
90 BB DD 8D
8049 F85FF2 DE F9 9D FB EB .DB $DE,$F9,$9D,$FB,$EB,$7E,$AA,$51,$43 ; 1E256
7E AA 51 43
8050 F85FFB
8051 F85FFB E8 58 50 BC 54 .DB $E8,$58,$50,$BC,$54,$5C,$65,$CC,$C6
5C 65 CC C6
8052 F86004 91 0E A6 AE A0 .DB $91,$0E,$A6,$AE,$A0,$19,$E3,$A3,$46 ; 1E512
19 E3 A3 46
8053
8054 F8600D B0 50 8B F1 28 .DB $B0,$50,$8B,$F1,$28,$3D,$0D,$65,$17
3D 0D 65 17
8055 F86016 0C 75 81 86 75 .DB $0C,$75,$81,$86,$75,$76,$C9,$48,$4D ; 1E1024
76 C9 48 4D
8056
8057 F8601F 22 CE 9A 32 CE .DB $22,$CE,$9A,$32,$CE,$28,$4D,$A7,$E4
28 4D A7 E4
8058 F86028 5D 3D C5 5D 3B .DB $5D,$3D,$C5,$5D,$3B,$8B,$9E,$92,$5A ; 1E2048
8B 9E 92 5A
8059
8060 F86031 fce4096:
8061 F86031 1A 4A 4A 80 3F .DB $1A,$4A,$4A,$80,$3F,$15,$4C,$C9,$9A
15 4C C9 9A
8062 F8603A 97 20 8A 02 52 .DB $97,$20,$8A,$02,$52,$60,$C4,$25,$75 ; 1E4096
60 C4 25 75
8063
8064 000012 FCSIZ .EQU $-fce4096
Tue Jul 17 11:00:18 2018 Page 96
8065
8066 ; constants address used by scxale10 routine
8067 F86043 fcaddr:
8068 F86043 FF5E 115F 235F .DW fce0, fce1, fce2, fce3, fce4, fce5, fce6, fce7
355F 475F 595F
6B5F 7D5F
8069
8070 ;----------------------------------------------------------------------------
8071 ; square root & cube root
8072 ;----------------------------------------------------------------------------
8073 F86053
8074 ; fsqrt - return the square root of the argument
8075 ;
8076 ; entry:
8077 ; fac = x
8078 ;
8079 ; exit:
8080 ; fac = sqrt(x)
8081 ; CF = 1 if invalid result (nan, inf)
8082 ;
8083 ; strategy:
8084 ; range reduction involves isolating the power of two of the
8085 ; argument and using a rational approximation to obtain
8086 ; a rough value for the square root; then Heron's (Newton) iteration
8087 ; is used four times to converge to an accurate value.
8088 ;
8089 ; 1) range reduction is accomplished by separating the argument x
8090 ; into an integer M and fraction z such that:
8091 ;
8092 ; 2*M
8093 ; x = z * 2 with: 0.25 <= z < 1
8094 ;
8095 ; 2) obtain a rough value w for the square root of z by a
8096 ; rational approximation:
8097 ;
8098 ; w = A*z + B - C/(z + D) (accuracy: 10/12 bits)
8099 ;
8100 ; 3) the estimate w is used as initial seed for Heron's iteration:
8101 ;
8102 ; y[n+1] = 0.5*(y[n] + z/y[n]) where y[0] = w, n = 3
8103 ;
8104 ; 4) finally, the square root of the x is obtained scaling back y:
8105 ;
8106 ; M M
8107 ; sqrt(x) = sqrt(z) * 2 = y * 2
8108 ;
8109 ; computation mean time: 30ms at 4MHz
8110 ;
8111 ;-----
8112 F86053 fsqrt:
8113 ;-----
8114 F86053 24 25 bit facst ; fac is valid?
8115 F86055 10 0B bpl ?fv ; yes
8116 F86057 70 07 bvs ?er ; fac=nan so return nan
8117 F86059 24 24 bit facsgn ; fac=inf so check sign
8118 F8605B 10 03 bpl ?er ; fac=+inf so return +inf
8119 F8605D 4C 74 4E ?nan: jmp fldnan ; fac=-inf so return nan
Tue Jul 17 11:00:18 2018 Page 97
8120 F86060 38 ?er: sec
8121 F86061 60 rts
8122 F86062 50 04 ?fv: bvc ?xp ; fac is not zero
8123 F86064 64 24 stz facsgn ; fac=+/-0 return always +0
8124 F86066 18 clc
8125 F86067 60 rts
8126 F86068 24 24 ?xp: bit facsgn ; check if fac>0
8127 F8606A 30 F1 bmi ?nan ; fac<0 so return nan
8128 F8606C 20 6E 48 jsr frexp ; reduce argument to range [0.5,1)
8129 F8606F CPU16
8130 F8606F C2 30 rep #(PMFLAG.OR.PXFLAG)
8131 .LONGA on
8132 .LONGI on
8133 .MNLIST
8134 F86071 A5 46 lda scexp ; the true 2 exponent
8135 F86073 AA tax
8136 F86074 4A lsr a ; CF=0 if exponent is divisible by 2
8137 F86075 8A txa ; C=exponent
8138 F86076 90 03 bcc ?sgn ; divisible by 2
8139 F86078 C6 22 dec facexp ; reduce argument to range [0.25, 0.5)
8140 F8607A 1A inc a ; increment the exponent (now divisible by 2)
8141 F8607B 0A ?sgn: asl a ; CF=exponent sign
8142 F8607C 90 01 bcc ?sgn2 ; positive
8143 F8607E 1A inc a ; negative: put sign in bit 0
8144 F8607F 6A ?sgn2: ror a ; restore exponent
8145 F86080 6A ror a ; divide by 2 with sign extension
8146 F86081 85 46 sta scexp ; scexp = M, fac = z
8147 F86083 CPU08
8148 F86083 E2 30 sep #(PMFLAG.OR.PXFLAG)
8149 .LONGA off
8150 .LONGI off
8151 .MNLIST
8152 F86085
8153 ; approximate sqrt(z) in range [0.25,1) with rational function:
8154 ; w = A*z + B - C/(z + D) (accuracy: 10/12 bits)
8155 F86085 20 66 84 jsr mvf_t0 ; tfr0 = z
8156 F86088 20 67 45 jsr faddhalf ; z + D (D=0.5)
8157 F8608B A9 D0 lda #<sqc ; C
8158 F8608D A0 61 ldy #>sqc
8159 F8608F 20 01 4A jsr fcdiv ; C/(z + D)
8160 F86092 A9 BE lda #<sqb ; B
8161 F86094 A0 61 ldy #>sqb
8162 F86096 20 5C 45 jsr fcsub ; B - C/(z + D)
8163 F86099 20 93 84 jsr mvf_t1
8164 F8609C 20 47 85 jsr mvt0_f ; z
8165 F8609F A9 AC lda #<sqa ; A
8166 F860A1 A0 61 ldy #>sqa
8167 F860A3 20 D5 49 jsr fcmult ; A*z
8168 F860A6 20 FB 85 jsr mvt1_a
8169 F860A9 20 7D 45 jsr fpadd ; A*z + B - C/(z + D)
8170
8171 ; Hero's iteration four times
8172 F860AC 20 BB 60 jsr ?nit
8173 F860AF 20 BB 60 jsr ?nit
8174 F860B2 20 BB 60 jsr ?nit
8175 F860B5 20 BB 60 jsr ?nit ; fac=sqrt(z)
8176
Tue Jul 17 11:00:18 2018 Page 98
8177 F860B8 4C B7 48 jmp fscale ; fac=sqrt(z)*(2^M)=sqrt(x)
8178
8179 ; newton iteration for sqrt
8180 ; y[n+1] = 0.5*(y[n] + z/y[n])
8181 ; where y[0]=w is the initial seed value
8182 ; note that is safe, when fac is normal and limited,
8183 ; to multiplies by 2 simply incrementing the exponent
8184 F860BB 20 93 84 ?nit: jsr mvf_t1 ; tfr1 = y[n]
8185 F860BE 20 CE 85 jsr mvt0_a ; arg = z
8186 F860C1 20 10 4A jsr fpdiv ; x/y[n]
8187 F860C4 20 FB 85 jsr mvt1_a ; arg = y[n]
8188 F860C7 20 7D 45 jsr fpadd ; y[n] + z/y[n]
8189 F860CA ACC16
8190 F860CA C2 20 rep #PMFLAG
8191 .LONGA on
8192 .MNLIST
8193 F860CC C6 22 dec facexp ; y[n+1] = 0.5*(y[n] + z/y[n])
8194 F860CE ACC08
8195 F860CE E2 20 sep #PMFLAG
8196 .LONGA off
8197 .MNLIST
8198 F860D0 60 rts
8199
8200 ; fcbrt - return the cube root of the argument
8201 ;
8202 ; entry:
8203 ; fac = x
8204 ;
8205 ; exit:
8206 ; fac = cbrt(x)
8207 ; CF = 1 if invalid result (nan, inf)
8208 ;
8209 ; strategy:
8210 ; range reduction involves isolating the power of two of the
8211 ; argument and using a rational approximation to obtain
8212 ; a rough value for the cube root; then one Newton iteration followed
8213 ; by one Halley iteration is used to converge to an accurate value.
8214 ;
8215 ; 1) range reduction is accomplished by separating the argument x
8216 ; into an integer M and fraction z such that:
8217 ;
8218 ; 3*M
8219 ; x = z * 2 with: 0.125 <= z < 1
8220 ;
8221 ; 2) obtain a rough value w for the square root of z by a
8222 ; rational approximation of 8th degree:
8223 ;
8224 ; w = N(z)/D(z) (accuracy: 22/24 bits)
8225 ;
8226 ; 3) the estimate w is used as initial seed for Newton's iteration:
8227 ;
8228 ; p = (1/3)*((z/w*w)) + 2*w)
8229 ;
8230 ; 4) the estimate p is used as seed for final Halley's iteration:
8231 ;
8232 ; y = p*((p*p*p+2*z)/(2*p*p*p+z))
8233 ;
Tue Jul 17 11:00:18 2018 Page 99
8234 ; 5) finally, the cube root of the x is obtained scaling back y:
8235 ;
8236 ; M M
8237 ; cbrt(x) = cbrt(z) * 2 = y * 2
8238 ;
8239 ; computation mean time: 75/80ms at 4MHz
8240 ;
8241 ;-----
8242 F860D1 fcbrt:
8243 ;-----
8244 F860D1 24 25 bit facst ; if fac is not valid return nan if fac=nan...
8245 F860D3 30 04 bmi ?er ; ...or return inf if fac=inf (same fac sign)
8246 F860D5 50 04 bvc ?ok ; fac is not zero
8247 F860D7 18 clc ; return fac=0
8248 F860D8 60 rts
8249 F860D9 38 ?er: sec
8250 F860DA 60 rts
8251 F860DB A5 24 ?ok: lda facsgn ; save fac sign...
8252 F860DD 85 4A sta dsgn
8253 F860DF 64 24 stz facsgn ; ...and work with absolute value
8254 F860E1 20 6E 48 jsr frexp ; reduce argument to range [0.5,1)
8255 F860E4 CPU16
8256 F860E4 C2 30 rep #(PMFLAG.OR.PXFLAG)
8257 .LONGA on
8258 .LONGI on
8259 .MNLIST
8260 F860E6 A2 03 00 ldx #3
8261 F860E9 A5 48 lda dexp ; absolute value of the exponent
8262 F860EB 20 11 88 jsr udiv ; C=quotient, Y=remainder (unsigned)
8263 F860EE BB tyx
8264 F860EF F0 2B beq ?go ; remainder=0, exponent is divisible by 3
8265 F860F1 98 tya ; C=remainder
8266 F860F2 A4 46 ldy scexp ; check exponent sign
8267 F860F4 30 06 bmi ?ne ; handle negative exponent
8268 F860F6 38 sec ; C=remainder, compute remainder such that...
8269 F860F7 E9 03 00 sbc #3 ; ...(exponent-C) is divisible by 3
8270 F860FA 80 04 bra ?ne2
8271 F860FC 49 FF FF ?ne: eor #$FFFF ; exponent is negative...
8272 F860FF 1A inc a ; ...so change sign to remainder
8273 F86100 85 3E ?ne2: sta wftmp ; save for later use
8274 F86102 18 clc
8275 F86103 65 22 adc facexp ; reduce argument to range [0.125,1)
8276 F86105 85 22 sta facexp
8277 F86107 38 sec
8278 F86108 A5 46 lda scexp ; find the new exponent after reduction
8279 F8610A E5 3E sbc wftmp
8280 F8610C F0 16 beq ?go2 ; exponent=0
8281 F8610E 85 46 sta scexp
8282 F86110 10 04 bpl ?pe
8283 F86112 49 FF FF eor #$FFFF
8284 F86115 1A inc a
8285 F86116 A2 03 00 ?pe: ldx #3 ; now exponent is divisible by 3
8286 F86119 20 11 88 jsr udiv ; C=new exponent
8287 F8611C A6 46 ?go: ldx scexp ; change sign if negative
8288 F8611E 10 04 bpl ?go2
8289 F86120 49 FF FF eor #$FFFF
8290 F86123 1A inc a
Tue Jul 17 11:00:18 2018 Page 100
8291 F86124 85 46 ?go2: sta scexp ; scexp=M=exponent of cube root
8292 F86126 CPU08 ; fac=z, range: [1/8, 1)
8293 F86126 E2 30 sep #(PMFLAG.OR.PXFLAG)
8294 .LONGA off
8295 .LONGI off
8296 .MNLIST
8297
8298 ; approximate cbrt(z) in range [0.125,1) with rational function:
8299 ; w = N(z)/D(z) (accuracy: 22/24 bits)
8300 F86128 20 66 84 jsr mvf_t0 ; tfr0 = z
8301 F8612B A9 F4 lda #<cbrn ; evaluate numerator
8302 F8612D A0 61 ldy #>cbrn
8303 F8612F A2 04 ldx #4 ; degree=4
8304 F86131 20 1C 87 jsr peval
8305 F86134 20 93 84 jsr mvf_t1 ; tfr1=N(z)
8306 F86137 A9 4E lda #<cbrd ; evaluate denominator
8307 F86139 A0 62 ldy #>cbrd
8308 F8613B A2 04 ldx #4 ; degree=4
8309 F8613D 20 1C 87 jsr peval
8310 F86140 20 FB 85 jsr mvt1_a ; arg=N(z)
8311 F86143 20 10 4A jsr fpdiv ; w=N(z)/D(z)
8312
8313 F86146 20 54 61 jsr ?nit ; Newton's iteration (evaluate p)
8314 F86149 20 73 61 jsr ?hit ; Halley's iteration (evaluate y)
8315 F8614C
8316 F8614C 20 B7 48 jsr fscale ; fac=cbrtt(z)*(2^M)=sqrt(x)
8317 F8614F A5 4A lda dsgn ; restore original argument sign
8318 F86151 85 24 sta facsgn
8319 F86153 60 rts
8320 F86154
8321 ?nit: ; Newton's iteration
8322 ; p = (1/3)*((z/w*w)) + 2*w)
8323 F86154 20 93 84 jsr mvf_t1 ; tfr1 = w (initial seed)
8324 F86157 20 CC 49 jsr fsquare ; w*w
8325 F8615A 20 CE 85 jsr mvt0_a ; arg=z
8326 F8615D 20 10 4A jsr fpdiv ; z/(w*w)
8327 F86160 20 FB 85 jsr mvt1_a ; arg=w
8328 F86163 ACC16 ; is safe here simply increment exponent
8329 F86163 C2 20 rep #PMFLAG
8330 .LONGA on
8331 .MNLIST
8332 F86165 E6 3A inc argexp ; arg=2*w
8333 F86167 ACC08
8334 F86167 E2 20 sep #PMFLAG
8335 .LONGA off
8336 .MNLIST
8337 F86169 20 7D 45 jsr fpadd ; 2*w + z/(w*w)
8338 F8616C A9 E2 lda #<c13 ; 1/3
8339 F8616E A0 61 ldy #>c13
8340 F86170 4C D5 49 jmp fcmult ; p = (1/3)*((x/(w*w)) + 2*w)
8341
8342 ?hit: ; Halley's iteration
8343 ; y = p*((p*p*p+2*z)/(2*p*p*p+z))
8344 F86173 20 93 84 jsr mvf_t1 ; tfr1=p
8345 F86176 20 CC 49 jsr fsquare ; p*p
8346 F86179 20 FB 85 jsr mvt1_a
8347 F8617C 20 DD 49 jsr fpmult ; p*p*p
Tue Jul 17 11:00:18 2018 Page 101
8348 F8617F 20 C0 84 jsr mvf_t2 ; tfr2=p*p*p
8349 F86182 20 CE 85 jsr mvt0_a ; z
8350 F86185 ACC16 ; is safe here simply increment exponent
8351 F86185 C2 20 rep #PMFLAG
8352 .LONGA on
8353 .MNLIST
8354 F86187 E6 3A inc argexp ; 2*z
8355 F86189 ACC08
8356 F86189 E2 20 sep #PMFLAG
8357 .LONGA off
8358 .MNLIST
8359 F8618B 20 7D 45 jsr fpadd
8360 F8618E 20 ED 84 jsr mvf_t3 ; tfr3=p*p*p+2*X
8361 F86191 20 28 86 jsr mvt2_a ; p*p*p
8362 F86194 ACC16 ; is safe here simply increment exponent
8363 F86194 C2 20 rep #PMFLAG
8364 .LONGA on
8365 .MNLIST
8366 F86196 E6 3A inc argexp ; 2*p*p*p
8367 F86198 ACC08
8368 F86198 E2 20 sep #PMFLAG
8369 .LONGA off
8370 .MNLIST
8371 F8619A 20 47 85 jsr mvt0_f ; z
8372 F8619D 20 7D 45 jsr fpadd ; 2*p*p*p+z
8373 F861A0 20 55 86 jsr mvt3_a ; p*p*p+2*z
8374 F861A3 20 10 4A jsr fpdiv ; (p*p*p+2*z)/(2*p*p*p+z)
8375 F861A6 20 FB 85 jsr mvt1_a ; p
8376 F861A9 4C DD 49 jmp fpmult ; p*((p*p*p+2*z)/(2*p*p*p+z))
8377
8378 ; coefficients for initial rational approximation to square root
8379 ; R(x) = Ax + B - C/(x + D) 10 bit (0.25 <= x < 1, D=0.5)
8380 F861AC 62 47 23 98 80 sqa: .DB $62,$47,$23,$98,$80,$52,$B7,$9F,$F7
52 B7 9F F7
8381 F861B5 6F 60 5B 7C 8C .DB $6F,$60,$5B,$7C,$8C,$BA,$AF,$FD,$3F ; A=0.343220129185
BA AF FD 3F
8382 F861BE 9E BA E5 B7 91 sqb: .DB $9E,$BA,$E5,$B7,$91,$09,$68,$DF,$B2
09 68 DF B2
8383 F861C7 76 6E E6 E6 13 .DB $76,$6E,$E6,$E6,$13,$52,$E6,$FE,$3F ; B=0.899689906952
52 E6 FE 3F
8384 F861D0 4C 28 D6 5D 7A sqc: .DB $4C,$28,$D6,$5D,$7A,$85,$E9,$00,$81
85 E9 00 81
8385 F861D9 17 23 D0 C7 70 .DB $17,$23,$D0,$C7,$70,$63,$BA,$FD,$3F ; C=0.364039921180
63 BA FD 3F
8386
8387 F861E2 AA AA AA AA AA c13: .DB $AA,$AA,$AA,$AA,$AA,$AA,$AA,$AA,$AA
AA AA AA AA
8388 F861EB AA AA AA AA AA .DB $AA,$AA,$AA,$AA,$AA,$AA,$AA,$FD,$3F ; 1/3
AA AA FD 3F
8389
8390 ; coefficients for initial rational approximation to cube root (0.125 <= x < 1)
8391 cbrn: ; numerator coefficients (degree 4)
8392 ; N[4] = 45.2548339756803022511987494
8393 F861F4 3C 10 33 78 FE .DB $3C,$10,$33,$78,$FE,$76,$9E,$89,$D0
76 9E 89 D0
8394 F861FD 83 D3 9D 32 F3 .DB $83,$D3,$9D,$32,$F3,$04,$B5,$04,$40
04 B5 04 40
Tue Jul 17 11:00:18 2018 Page 102
8395 ; N[3] = 192.2798368355061050458134625
8396 F86206 08 E3 5B 8C F2 .DB $08,$E3,$5B,$8C,$F2,$49,$06,$80,$97
49 06 80 97
8397 F8620F 00 B7 08 63 A3 .DB $00,$B7,$08,$63,$A3,$47,$C0,$06,$40
47 C0 06 40
8398 ; N[2] = 119.1654824285581628956914143
8399 F86218 42 D8 BC 63 FD .DB $42,$D8,$BC,$63,$FD,$2F,$EF,$90,$64
2F EF 90 64
8400 F86221 9F 70 E5 1C BA .DB $9F,$70,$E5,$1C,$BA,$54,$EE,$05,$40
54 EE 05 40
8401 ; N[1] = 13.43250139086239872172837314
8402 F8622A AA 47 0C 1F 85 .DB $AA,$47,$0C,$1F,$85,$FF,$A0,$76,$20
FF A0 76 20
8403 F86233 00 A8 13 94 86 .DB $00,$A8,$13,$94,$86,$EB,$D6,$02,$40
EB D6 02 40
8404 ; N[0] = 0.1636161226585754240958355063
8405 F8623C 7B C3 D8 3A B4 .DB $7B,$C3,$D8,$3A,$B4,$CC,$8B,$32,$6D
CC 8B 32 6D
8406 F86245 69 E9 AA 1F FC .DB $69,$E9,$AA,$1F,$FC,$8A,$A7,$FC,$3F
8A A7 FC 3F
8407
8408 cbrd: ; denominator coefficients (degree 4)
8409 ; D[4] = 14.80884093219134573786480845
8410 F8624E 1A 8E 1C AB 2F .DB $1A,$8E,$1C,$AB,$2F,$1C,$FF,$A5,$49
1C FF A5 49
8411 F86257 05 D9 76 30 03 .DB $05,$D9,$76,$30,$03,$F1,$EC,$02,$40
F1 EC 02 40
8412 ; D[3] = 151.9714051044435648658557668
8413 F86260 7A 6B 6B 1C FD .DB $7A,$6B,$6B,$1C,$FD,$4E,$DD,$A5,$C7
4E DD A5 C7
8414 F86269 A8 C0 42 01 AE .DB $A8,$C0,$42,$01,$AE,$F8,$97,$06,$40
F8 97 06 40
8415 ; D[2] = 168.5254414101568283957668343
8416 F86272 F6 AE F6 BD 0C .DB $F6,$AE,$F6,$BD,$0C,$B1,$C7,$0B,$85
B1 C7 0B 85
8417 F8627B 73 96 08 54 83 .DB $73,$96,$08,$54,$83,$86,$A8,$06,$40
86 A8 06 40
8418 ; D[1] = 33.9905941350215598754191872
8419 F86284 9C 0A 30 D2 E7 .DB $9C,$0A,$30,$D2,$E7,$F9,$A1,$D1,$F6
F9 A1 D1 F6
8420 F8628D A7 1B 16 4F 5E .DB $A7,$1B,$16,$4F,$5E,$F6,$87,$04,$40
F6 87 04 40
8421 ; D[0] = 1
8422 F86296 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
8423 F8629F 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$80,$FF,$3F
00 80 FF 3F
8424
8425 ;----------------------------------------------------------------------------
8426 ; logarithmic family functions
8427 ;----------------------------------------------------------------------------
8428
8429 ; flogep1 - return natural logarithm (base e) of x + 1
8430 ;
8431 ; entry:
8432 ; fac = x
8433 ;
Tue Jul 17 11:00:18 2018 Page 103
8434 ; exit:
8435 ; fac = loge(1 + x)
8436 ; CF = 1 if invalid result (nan, inf)
8437 ;
8438 ; computation mean time: 75/125ms at 4MHz
8439 ;
8440 ;-------
8441 F862A8 flogep1:
8442 ;-------
8443 F862A8 20 91 63 jsr cmnlogp1 ; return the logarithm of the fractional part
8444 F862AB A5 46 lda scexp ; if exponent M of the argument is zero...
8445 F862AD 05 47 ora scexp+1 ; ...we finish here...
8446 F862AF D0 0D bne lgem ; ...otherwise we add the loge(M)
8447 F862B1 18 clc ; return valid flag
8448 F862B2 60 rts
8449
8450 ; floge - return natural logarithm (base e) of x
8451 ;
8452 ; entry:
8453 ; fac = x
8454 ;
8455 ; exit:
8456 ; fac = loge(x)
8457 ; CF = 1 if invalid result (nan, inf)
8458 ;
8459 ; computation mean time: 75/125ms at 4MHz
8460 ;
8461 ;-----
8462 F862B3 floge:
8463 ;-----
8464 F862B3 20 DC 63 jsr cmnlog ; return the logarithm of the fractional part
8465 F862B6 A5 46 lda scexp ; if exponent M of the argument is zero...
8466 F862B8 05 47 ora scexp+1 ; ...we finish here...
8467 F862BA D0 02 bne lgem ; ...otherwise we add the loge(M)
8468 F862BC 18 clc ; return valid flag
8469 F862BD 60 rts
8470
8471 ; lgem - evaluate loge(2)*M and add to logarithm of fractional part
8472 ;
8473 ; M
8474 ; log(x) = loge(f * 2 ) = loge(f) + M * loge(2)
8475 ;
8476 ;----
8477 F862BE lgem:
8478 ;----
8479 F862BE 20 C0 84 jsr mvf_t2 ; tfr2=loge(f)
8480 F862C1 A5 46 lda scexp
8481 F862C3 A4 47 ldy scexp+1
8482 F862C5 20 5B 4F jsr fldu16 ; convert exponent M to float
8483 F862C8 A5 45 lda scsgn
8484 F862CA 85 24 sta facsgn ; sign of the exponent M
8485 F862CC 20 66 84 jsr mvf_t0
8486 F862CF A9 8D lda #<ln2c1 ; now evaluate M * loge(2)...
8487 F862D1 A0 67 ldy #>ln2c1
8488 F862D3 20 D5 49 jsr fcmult
8489 F862D6 20 93 84 jsr mvf_t1 ; ...splitted in two
8490 F862D9 20 47 85 jsr mvt0_f
Tue Jul 17 11:00:18 2018 Page 104
8491 F862DC A9 9F lda #<ln2c2
8492 F862DE A0 67 ldy #>ln2c2
8493 F862E0 20 D5 49 jsr fcmult
8494 F862E3 20 28 86 jsr mvt2_a
8495 F862E6 20 7D 45 jsr fpadd
8496 F862E9 20 FB 85 jsr mvt1_a
8497 F862EC 4C 7D 45 jmp fpadd
8498 F862EF
8499 ; flog10p1 - return decimal logarithm (base 10) of x + 1
8500 ;
8501 ; entry:
8502 ; fac = x
8503 ;
8504 ; exit:
8505 ; fac = log10(1 + x)
8506 ; CF = 1 if invalid result (nan, inf)
8507 ;
8508 ; computation mean time: 85/140ms at 4MHz
8509 ;
8510 ;--------
8511 F862EF flog10p1:
8512 ;--------
8513 F862EF 20 91 63 jsr cmnlogp1 ; return the loge of the fractional part
8514 F862F2 20 3C 63 jsr lg10 ; return the log10 of the fractional part
8515 F862F5 A5 46 lda scexp ; if exponent M of the argument is zero...
8516 F862F7 05 47 ora scexp+1 ; ...we finish here...
8517 F862F9 D0 10 bne lg10m ; ...otherwise we add the loge(M)
8518 F862FB 18 clc ; return valid flag
8519 F862FC 60 rts
8520
8521 ; flog10 - return decimal logarithm (base 10) of x
8522 ;
8523 ; entry:
8524 ; fac = x
8525 ;
8526 ; exit:
8527 ; fac = log10(x)
8528 ; CF = 1 if invalid result (nan, inf)
8529 ;
8530 ; computation mean time: 85/140ms at 4MHz
8531 ;
8532 ;------
8533 F862FD flog10:
8534 ;------
8535 F862FD 20 DC 63 jsr cmnlog ; return the loge of the fractional part
8536 F86300 20 3C 63 jsr lg10 ; return the log10 of the fractional part
8537 F86303 A5 46 lda scexp ; if exponent M of the argument is zero...
8538 F86305 05 47 ora scexp+1 ; ...we finish here...
8539 F86307 D0 02 bne lg10m ; ...otherwise we add the loge(M)
8540 F86309 18 clc ; return valid flag
8541 F8630A 60 rts
8542
8543 ; lg10m - evaluate log10(2)*M and add to logarithm of fractional part
8544 ;
8545 ; M
8546 ; log(x) = log(f * 2 ) = log10(f) + M * log10(2)
8547 ;
Tue Jul 17 11:00:18 2018 Page 105
8548 ;-----
8549 F8630B lg10m:
8550 ;-----
8551 F8630B 20 C0 84 jsr mvf_t2 ; tfr2=log10(f)
8552 F8630E A5 46 lda scexp
8553 F86310 A4 47 ldy scexp+1
8554 F86312 20 5B 4F jsr fldu16 ; convert exponent M to float
8555 F86315 A5 45 lda scsgn
8556 F86317 85 24 sta facsgn ; sign of the exponent M
8557 F86319 20 66 84 jsr mvf_t0
8558 F8631C A9 C3 lda #<l102a ; now evaluate M * log10(2)...
8559 F8631E A0 67 ldy #>l102a
8560 F86320 20 D5 49 jsr fcmult
8561 F86323 20 93 84 jsr mvf_t1 ; ...splitted in two
8562 F86326 20 47 85 jsr mvt0_f
8563 F86329 A9 D5 lda #<l102b
8564 F8632B A0 67 ldy #>l102b
8565 F8632D 20 D5 49 jsr fcmult
8566 F86330 20 28 86 jsr mvt2_a
8567 F86333 20 7D 45 jsr fpadd
8568 F86336 20 FB 85 jsr mvt1_a
8569 F86339 4C 7D 45 jmp fpadd
8570
8571 ; lg10 - convert the natural logarithm into decimal logarithm
8572 ;
8573 ; multiplies the log of the fraction by log10(e)
8574 ;
8575 ;----
8576 F8633C lg10:
8577 ;----
8578 F8633C 20 66 84 jsr mvf_t0 ; tfr0=loge(f)
8579 F8633F A9 E7 lda #<l10ea
8580 F86341 A0 67 ldy #>l10ea
8581 F86343 20 D5 49 jsr fcmult
8582 F86346 20 93 84 jsr mvf_t1
8583 F86349 20 47 85 jsr mvt0_f
8584 F8634C A9 F9 lda #<l10eb
8585 F8634E A0 67 ldy #>l10eb
8586 F86350 20 D5 49 jsr fcmult
8587 F86353 20 FB 85 jsr mvt1_a
8588 F86356 4C 7D 45 jmp fpadd
8589
8590 ; flog2p1 - return the base 2 logarithm of x + 1
8591 ;
8592 ; entry:
8593 ; fac = x
8594 ;
8595 ; exit:
8596 ; fac = log2(1 + x)
8597 ; CF = 1 if invalid result (nan, inf)
8598 ;
8599 ; computation mean time: 80/130ms at 4MHz
8600 ;
8601 ;-------
8602 F86359 flog2p1:
8603 ;-------
8604 F86359 20 91 63 jsr cmnlogp1 ; return the loge of the fractional part
Tue Jul 17 11:00:18 2018 Page 106
8605 F8635C A9 0B lda #<lg2e ; return the log2 of the fractional part
8606 F8635E A0 68 ldy #>lg2e
8607 F86360 20 D5 49 jsr fcmult
8608 F86363 A5 46 lda scexp ; if exponent M of the argument is zero...
8609 F86365 05 47 ora scexp+1 ; ...we finish here...
8610 F86367 D0 14 bne lg2m ; ...otherwise we add M
8611 F86369 18 clc ; return valid flag
8612 F8636A 60 rts
8613
8614 ; flog2 - return the base 2 logarithm of x
8615 ;
8616 ; entry:
8617 ; fac = x
8618 ;
8619 ; exit:
8620 ; fac = log2(x)
8621 ; CF = 1 if invalid result (nan, inf)
8622 ;
8623 ; computation mean time: 80/130ms at 4MHz
8624 ;
8625 ;-----
8626 F8636B flog2:
8627 ;-----
8628 F8636B 20 DC 63 jsr cmnlog ; return the loge of the fractional part
8629 F8636E A9 0B lda #<lg2e ; return the log2 of the fractional part
8630 F86370 A0 68 ldy #>lg2e
8631 F86372 20 D5 49 jsr fcmult
8632 F86375 A5 46 lda scexp ; if exponent M of the argument is zero...
8633 F86377 05 47 ora scexp+1 ; ...we finish here...
8634 F86379 D0 02 bne lg2m ; ...otherwise we add M
8635 F8637B 18 clc ; return valid flag
8636 F8637C 60 rts
8637
8638 ; lg2m - add exponent M to base 2 logarithm of fractional part
8639 ;
8640 ; M
8641 ; log(x) = log(f * 2 ) = log2(f) + M
8642 ;
8643 ;----
8644 F8637D lg2m:
8645 ;----
8646 F8637D 20 C0 84 jsr mvf_t2 ; tfr2=log2(f)
8647 F86380 A5 46 lda scexp
8648 F86382 A4 47 ldy scexp+1
8649 F86384 20 5B 4F jsr fldu16 ; convert exponent M to float
8650 F86387 A5 45 lda scsgn
8651 F86389 85 24 sta facsgn ; sign of the exponent M
8652 F8638B 20 28 86 jsr mvt2_a
8653 F8638E 4C 7D 45 jmp fpadd
8654 F86391
8655 ; cmnlogp1 - common logarithm evaluation
8656 ; return the natural logarithm (base e) of the fraction of x + 1
8657 ;
8658 ; Note that when evaluate log(x) with x very close to one, cancellation
8659 ; caused by computation of x - 1 can give a degrated result (precision loss).
8660 ; To avoid this negative effect is better evaluate log(1+x) when argument
8661 ; is very closed to one.
Tue Jul 17 11:00:18 2018 Page 107
8662 ;
8663 ; entry:
8664 ; fac = xm1 (xm1 = x - 1)
8665 ;
8666 ; exit:
8667 ; fac = loge(f), f = fraction of xm1 + 1
8668 ; scexp = M = exponent of the argument
8669 ;
8670 ; where:
8671 ; M
8672 ; 1 + x = f * 2 sqrt(2)/2 <= f < sqrt(2)
8673 ;
8674 ; strategy:
8675 ; The argument is separated into its exponent and fractional parts.
8676 ; If the exponent is between -2 and +2, the logarithm of the fraction,
8677 ; setting y = f - 1, is approximated by:
8678 ;
8679 ; 2 3
8680 ; loge(1+y) = y - 0.5 * y + y * P(y)/Q(y)
8681 ;
8682 ; otherwise, setting y = 2(f - 1)/(f + 1), is approximated by:
8683 ;
8684 ; 3 2
8685 ; loge(f) = y + y * R(z)/S(z), where z = y
8686 ;
8687 ;--------
8688 F86391 cmnlogp1:
8689 ;--------
8690 F86391 24 25 bit facst
8691 F86393 30 1C bmi ?nv ; invalid xm1
8692 F86395 18 clc
8693 F86396 70 23 bvs ?ex ; xm1=0 so return 0
8694 F86398 20 93 84 jsr mvf_t1 ; tfr1=xm1
8695 F8639B 20 6C 45 jsr faddone ; x=1+xm1
8696 F8639E B0 1B bcs ?ex ; x=+inf so return +inf
8697 F863A0 24 24 bit facsgn
8698 F863A2 30 13 bmi ?nan ; x<0 so return -nan
8699 F863A4 24 25 bit facst
8700 F863A6 50 16 bvc ?ok ; ok, x > 0
8701 F863A8 20 7D 4E jsr fldinf ; x=0 so return -inf
8702 F863AB A9 FF lda #$FF
8703 F863AD 85 24 sta facsgn
8704 F863AF 80 09 bra ?er
8705 F863B1 70 07 ?nv: bvs ?er ; xm1=nan so return nan
8706 F863B3 24 24 bit facsgn
8707 F863B5 10 03 bpl ?er ; xm1=+inf so return +inf
8708 F863B7 20 74 4E ?nan: jsr fldnan ; xm1=-inf so return -nan
8709 F863BA 38 ?er: sec ; invalid fac
8710 F863BB 68 ?ex: pla ; skip return address
8711 F863BC 68 pla
8712 F863BD 60 rts
8713 F863BE 20 A6 64 ?ok: jsr logscl ; argument reduction & exponent extraction
8714 F863C1 90 08 bcc ?tiny ; |M| < 3
8715 F863C3 20 66 84 jsr mvf_t0 ; tfr0=x
8716 F863C6 20 71 45 jsr fsubone ; x-1
8717 F863C9 80 40 bra lge ; evaluation for |M| > 2
8718 F863CB A5 46 ?tiny: lda scexp ; if M=0...
Tue Jul 17 11:00:18 2018 Page 108
8719 F863CD 05 47 ora scexp+1
8720 F863CF F0 06 beq ?xm1 ; ...use argument xm1
8721 F863D1 20 71 45 jsr fsubone ; ...otherwise use x - 1
8722 F863D4 4C 5B 64 jmp lgep1
8723 F863D7 20 74 85 ?xm1: jsr mvt1_f ; use xm1
8724 F863DA 80 7F bra lgep1
8725
8726 ; cmnlog - common logarithm evaluation
8727 ; return the natural logarithm (base e) of the fraction of the argument
8728 ;
8729 ; entry:
8730 ; fac = x
8731 ;
8732 ; exit:
8733 ; fac = loge(f)
8734 ; scexp = M = exponent of the argument
8735 ;
8736 ; where:
8737 ; M
8738 ; x = f * 2 sqrt(2)/2 <= f < sqrt(2)
8739 ;
8740 ; strategy:
8741 ; The argument is separated into its exponent and fractional parts.
8742 ; If the exponent is between -2 and +2, the logarithm of the fraction,
8743 ; setting y = f - 1, is approximated by:
8744 ;
8745 ; 2 3
8746 ; loge(1+y) = y - 0.5 * y + y * P(y)/Q(y)
8747 ;
8748 ; otherwise, setting y = 2(f - 1)/(f + 1), is approximated by:
8749 ;
8750 ; 3 2
8751 ; loge(f) = y + y * R(z)/S(z), where z = y
8752 ;
8753 ;------
8754 F863DC cmnlog:
8755 ;------
8756 F863DC 24 25 bit facst ; fac must be valid and > 0
8757 F863DE 10 08 bpl ?ckz
8758 F863E0 70 18 bvs ?er ; fac=nan so return nan
8759 F863E2 24 24 bit facsgn ; if fac=+inf...
8760 F863E4 10 14 bpl ?er ; ...return +inf...
8761 F863E6 30 06 bmi ?nan ; ...else return nan
8762 F863E8 70 09 ?ckz: bvs ?inf ; if fac=0 return -inf
8763 F863EA 24 24 bit facsgn ; if fac>0 go to evaluation...
8764 F863EC 10 10 bpl ?go ; ...else return nan
8765 F863EE 20 74 4E ?nan: jsr fldnan ; return nan
8766 F863F1 80 07 bra ?er
8767 F863F3 A9 FF ?inf: lda #$FF ; return -inf
8768 F863F5 85 24 sta facsgn
8769 F863F7 20 7D 4E jsr fldinf
8770 F863FA 68 ?er: pla ; skip return address
8771 F863FB 68 pla
8772 F863FC 38 sec ; return invalid result
8773 F863FD 60 rts
8774 F863FE 20 A6 64 ?go: jsr logscl ; argument reduction & exponent extraction
8775 F86401 08 php ; save carry (cf=0 if |exponent| < 3)
Tue Jul 17 11:00:18 2018 Page 109
8776 F86402 20 66 84 jsr mvf_t0 ; tfr0=f
8777 F86405 20 71 45 jsr fsubone ; fac=y=f-1
8778 F86408 28 plp
8779 F86409 90 50 bcc lgep1 ; if |exponent| < 3 evaluate for (1+f)
8780
8781 ; lge - approximate loge(f)
8782 ;
8783 ; 3 2
8784 ; loge(f) = y + y * R(z)/S(z), where z = y
8785 ;
8786 ; y = 2(f - 1)/(f + 1)
8787 ;
8788 ;---
8789 F8640B lge:
8790 ;---
8791 F8640B 20 93 84 jsr mvf_t1 ; tfr1=y=f-1
8792 F8640E 20 47 85 jsr mvt0_f ; fac=f
8793 F86411 20 6C 45 jsr faddone ; fac=f+1
8794 F86414 20 FB 85 jsr mvt1_a ; arg=f-1
8795 F86417 20 10 4A jsr fpdiv ; (f-1)/(f+1)
8796 F8641A ACC16
8797 F8641A C2 20 rep #PMFLAG
8798 .LONGA on
8799 .MNLIST
8800 F8641C A5 22 lda facexp
8801 F8641E F0 03 beq ?isz ; y=0
8802 F86420 1A inc a ; note that here y is always normal
8803 F86421 E6 22 inc facexp ; y=2*(x-1)/(x+1)
8804 F86423 ?isz: ACC08
8805 F86423 E2 20 sep #PMFLAG
8806 .LONGA off
8807 .MNLIST
8808 F86425 20 93 84 jsr mvf_t1 ; tfr1=y
8809 F86428 20 CC 49 jsr fsquare ; z=y*y
8810 F8642B 20 66 84 jsr mvf_t0 ; tfr0=z
8811 F8642E A9 F3 lda #<clnr
8812 F86430 A0 64 ldy #>clnr
8813 F86432 A2 05 ldx #5
8814 F86434 20 1C 87 jsr peval ; evaluate R(z)
8815 F86437 20 C0 84 jsr mvf_t2 ; tfr2=R(z)
8816 F8643A A9 5F lda #<clns
8817 F8643C A0 65 ldy #>clns
8818 F8643E A2 05 ldx #5
8819 F86440 20 3A 87 jsr pevalp1 ; evaluate S(z)
8820 F86443 20 28 86 jsr mvt2_a ; arg=R(z)
8821 F86446 20 10 4A jsr fpdiv ; R(z)/S(z)
8822 F86449 20 CE 85 jsr mvt0_a ; arg=z
8823 F8644C 20 DD 49 jsr fpmult ; z*R(z)/S(z)
8824 F8644F 20 FB 85 jsr mvt1_a ; arg=y
8825 F86452 20 DD 49 jsr fpmult ; y*z*R(z)/S(z)
8826 F86455 20 FB 85 jsr mvt1_a ; arg=y
8827 F86458 4C 7D 45 jmp fpadd ; loge(f)=y+y*z*R(z)/S(z)
8828 F8645B
8829 ; lgep1 - approximate loge(1+y)
8830 ;
8831 ; 2 3
8832 ; loge(1+y) = y - 0.5 * y + y * P(y)/Q(y)
Tue Jul 17 11:00:18 2018 Page 110
8833 ;
8834 ; y = f - 1
8835 ;
8836 ;-----
8837 F8645B lgep1:
8838 ;-----
8839 F8645B 20 66 84 jsr mvf_t0 ; tfr0=y=x-1
8840 F8645E 20 CC 49 jsr fsquare ; z=y*y
8841 F86461 20 93 84 jsr mvf_t1 ; tfr1=z
8842 F86464 A9 CB lda #<clnp
8843 F86466 A0 65 ldy #>clnp
8844 F86468 A2 0C ldx #12
8845 F8646A 20 1C 87 jsr peval ; evaluate P(y)
8846 F8646D 20 C0 84 jsr mvf_t2 ; tfr2=P(y)
8847 F86470 A9 B5 lda #<clnq
8848 F86472 A0 66 ldy #>clnq
8849 F86474 A2 0B ldx #11
8850 F86476 20 3A 87 jsr pevalp1 ; evaluate Q(y)
8851 F86479 20 28 86 jsr mvt2_a ; P(y)
8852 F8647C 20 10 4A jsr fpdiv ; P(y)/Q(y)
8853 F8647F 20 FB 85 jsr mvt1_a ; z
8854 F86482 20 DD 49 jsr fpmult ; z*P(y)/Q(y)
8855 F86485 20 CE 85 jsr mvt0_a ; y
8856 F86488 20 DD 49 jsr fpmult ; y*z*P(y)/Q(y)
8857 F8648B 20 FB 85 jsr mvt1_a ; z
8858 F8648E ACC16
8859 F8648E C2 20 rep #PMFLAG
8860 .LONGA on
8861 .MNLIST
8862 F86490 A5 3A lda argexp
8863 F86492 F0 03 beq ?isz ; z=0
8864 F86494 3A dec a
8865 F86495 85 3A sta argexp ; z/2
8866 F86497 ?isz: ACC08
8867 F86497 E2 20 sep #PMFLAG
8868 .LONGA off
8869 .MNLIST
8870 F86499 A9 FF lda #$FF
8871 F8649B 85 3C sta argsgn ; arg=-z/2
8872 F8649D 20 7D 45 jsr fpadd ; y*z*(P(y)/Q(y)) - z/2
8873 F864A0 20 CE 85 jsr mvt0_a ; arg=y
8874 F864A3 4C 7D 45 jmp fpadd ; loge(1+y)=y-z/2+y*z*(P(y)/Q(y))
8875
8876 ; logscl - argument reduction for logarithm evaluation
8877 ;
8878 ; entry:
8879 ; fac = x, valid float
8880 ;
8881 ; exit:
8882 ; fac = f, reduced argument
8883 ; scexp = |M|, exponent
8884 ; scsgn = sign of M
8885 ; CF = 0 if |M| < 3
8886 ;
8887 ; M
8888 ; x = f * 2 sqrt(2)/2 <= f < sqrt(2)
8889 ;
Tue Jul 17 11:00:18 2018 Page 111
8890 ;------
8891 F864A6 logscl:
8892 ;------
8893 F864A6 20 6E 48 jsr frexp ; now 0.5 <= fac < 1
8894 F864A9 A9 E1 lda #<rsqrt2h ; now compare fac vs. 1/sqrt(2)
8895 F864AB A0 64 ldy #>rsqrt2h
8896 F864AD 20 5E 87 jsr fccmp
8897 F864B0 ACC16
8898 F864B0 C2 20 rep #PMFLAG
8899 .LONGA on
8900 .MNLIST
8901 F864B2 F0 06 beq ?gte ; fac=1/sqrt(2)
8902 F864B4 10 04 bpl ?gte ; fac>1/sqrt(2)
8903 F864B6 E6 22 inc facexp ; fac=fac*2, now 1 <= fac < sqrt(2)
8904 F864B8 C6 46 dec scexp ; decrement exponent
8905 F864BA A2 00 ?gte: ldx #0 ; assume positive scaling exponent
8906 F864BC A5 46 lda scexp
8907 F864BE 10 07 bpl ?mp ; positive or null scaling
8908 F864C0 CA dex ; negative scaling
8909 F864C1 49 FF FF eor #$FFFF ; complement
8910 F864C4 1A inc a
8911 F864C5 85 46 sta scexp ; unsigned scaling exponent
8912 F864C7 86 45 ?mp: stx scsgn ; sign of scaling exponent
8913 F864C9 C9 03 00 cmp #3 ; return CF = 0 if |exponent| < 3
8914 F864CC ACC08
8915 F864CC E2 20 sep #PMFLAG
8916 .LONGA off
8917 .MNLIST
8918 F864CE 60 rts
8919
8920 ; unrounded 1/sqrt(2) - $B504F333F9DE6484597D89B3754ABE9FP3FFE
8921 F864CF 9F BE 4A 75 B3 sqrth: .DB $9F,$BE,$4A,$75,$B3,$89,$7D,$59,$84
89 7D 59 84
8922 F864D8 64 DE F9 33 F3 .DB $64,$DE,$F9,$33,$F3,$04,$B5,$FE,$3F
04 B5 FE 3F
8923
8924 ; 1/sqrt(2) rounded to 113 bits
8925 F864E1 rsqrt2h:
8926 F864E1 00 80 4A 75 B3 .DB $00,$80,$4A,$75,$B3,$89,$7D,$59,$84
89 7D 59 84
8927 F864EA 64 DE F9 33 F3 .DB $64,$DE,$F9,$33,$F3,$04,$B5,$FE,$3F
04 B5 FE 3F
8928
8929 ; coefficients for log(x), rational function R()/S()
8930 F864F3 clnr:
8931 ; R[5] = -8.828896441624934385266096344596648080902E-1
8932 F864F3 8E 15 84 6B 67 .DB $8E,$15,$84,$6B,$67,$72,$AA,$CE,$23
72 AA CE 23
8933 F864FC 34 AD A7 43 0E .DB $34,$AD,$A7,$43,$0E,$05,$E2,$FE,$BF
05 E2 FE BF
8934 ; R[4] = 8.057002716646055371965756206836056074715E1
8935 F86505 14 20 14 FB 86 .DB $14,$20,$14,$FB,$86,$D1,$08,$AB,$2D
D1 08 AB 2D
8936 F8650E 2B 8F CB 99 DA .DB $2B,$8F,$CB,$99,$DA,$23,$A1,$05,$40
23 A1 05 40
8937 ; R[3] = -2.024301798136027039250415126250455056397E3
8938 F86517 BC EF D7 01 BF .DB $BC,$EF,$D7,$01,$BF,$A2,$EE,$76,$48
Tue Jul 17 11:00:18 2018 Page 112
A2 EE 76 48
8939 F86520 5B 87 90 54 A8 .DB $5B,$87,$90,$54,$A8,$09,$FD,$09,$C0
09 FD 09 C0
8940 ; R[2] = 2.048819892795278657810231591630928516206E4
8941 F86529 1C CC E3 20 15 .DB $1C,$CC,$E3,$20,$15,$6E,$6A,$18,$09
6E 6A 18 09
8942 F86532 F5 76 E2 D9 65 .DB $F5,$76,$E2,$D9,$65,$10,$A0,$0D,$40
10 A0 0D 40
8943 ; R[1] = -8.977257995689735303686582344659576526998E4
8944 F8653B 37 36 95 61 03 .DB $37,$36,$95,$61,$03,$74,$9D,$2E,$47
74 9D 2E 47
8945 F86544 9C 11 07 3C 4A .DB $9C,$11,$07,$3C,$4A,$56,$AF,$0F,$C0
56 AF 0F C0
8946 ; R[0] = 1.418134209872192732479751274970992665513E5
8947 F8654D A8 4A 7E 5A 28 .DB $A8,$4A,$7E,$5A,$28,$99,$7D,$53,$01
99 7D 53 01
8948 F86556 B4 60 74 F1 5A .DB $B4,$60,$74,$F1,$5A,$7D,$8A,$10,$40
7D 8A 10 40
8949
8950 F8655F clns:
8951 ; S[5] = -1.186359407982897997337150403816839480438E2
8952 F8655F 3A 6E 31 96 EA .DB $3A,$6E,$31,$96,$EA,$56,$BE,$E6,$BA
56 BE E6 BA
8953 F86568 92 B1 45 08 9A .DB $92,$B1,$45,$08,$9A,$45,$ED,$05,$C0
45 ED 05 C0
8954 ; S[4] = 3.998526750980007367835804959888064681098E3
8955 F86571 C4 2A 76 05 E9 .DB $C4,$2A,$76,$05,$E9,$F4,$A8,$5F,$11
F4 A8 5F 11
8956 F8657A 48 84 6F 92 6D .DB $48,$84,$6F,$92,$6D,$E8,$F9,$0A,$40
E8 F9 0A 40
8957 ; S[3] = -5.748542087379434595104154610899551484314E4
8958 F86583 36 79 3E 93 5D .DB $36,$79,$3E,$93,$5D,$19,$08,$FE,$93
19 08 FE 93
8959 F8658C 75 8E 62 BE 6B .DB $75,$8E,$62,$BE,$6B,$8D,$E0,$0E,$C0
8D E0 0E C0
8960 ; S[2] = 4.001557694070773974936904547424676279307E5
8961 F86595 36 7C 5E 8E 90 .DB $36,$7C,$5E,$8E,$90,$52,$EB,$2D,$76
52 EB 2D 76
8962 F8659E 57 97 FB 9E 78 .DB $57,$97,$FB,$9E,$78,$63,$C3,$11,$40
63 C3 11 40
8963 ; S[1] = -1.332535117259762928288745111081235577029E6
8964 F865A7 E8 C3 BB 00 81 .DB $E8,$C3,$BB,$00,$81,$59,$F2,$48,$4F
59 F2 48 4F
8965 F865B0 F7 E2 25 F0 B8 .DB $F7,$E2,$25,$F0,$B8,$A9,$A2,$13,$C0
A9 A2 13 C0
8966 ; S[0] = 1.701761051846631278975701529965589676574E6
8967 F865B9 68 05 98 8B BC .DB $68,$05,$98,$8B,$BC,$65,$3C,$FD,$01
65 3C FD 01
8968 F865C2 0E 91 2E 6A 08 .DB $0E,$91,$2E,$6A,$08,$BC,$CF,$13,$40
BC CF 13 40
8969
8970 ; coefficients for log(1+x), rational function P()/Q()
8971 F865CB clnp:
8972 ; P[12] = 1.538612243596254322971797716843006400388E-6
8973 F865CB 2A C3 7D B0 42 .DB $2A,$C3,$7D,$B0,$42,$00,$91,$A4,$A1
00 91 A4 A1
8974 F865D4 4A C1 76 6B 50 .DB $4A,$C1,$76,$6B,$50,$82,$CE,$EB,$3F
Tue Jul 17 11:00:18 2018 Page 113
82 CE EB 3F
8975 ; P[11] = 4.998469661968096229986658302195402690910E-1
8976 F865DD 6C FE CF 17 46 .DB $6C,$FE,$CF,$17,$46,$8D,$F4,$5A,$4E
8D F4 5A 4E
8977 F865E6 17 E6 A3 09 F1 .DB $17,$E6,$A3,$09,$F1,$EB,$FF,$FD,$3F
EB FF FD 3F
8978 ; P[10] = 2.321125933898420063925789532045674660756E1
8979 F865EF DD 55 73 C9 52 .DB $DD,$55,$73,$C9,$52,$31,$F5,$21,$A6
31 F5 21 A6
8980 F865F8 33 4B 7F BC A8 .DB $33,$4B,$7F,$BC,$A8,$B0,$B9,$03,$40
B0 B9 03 40
8981 ; P[09] = 4.114517881637811823002128927449878962058E2
8982 F86601 62 F5 AF 82 FE .DB $62,$F5,$AF,$82,$FE,$EA,$8A,$CB,$29
EA 8A CB 29
8983 F8660A 7D 14 CE 31 D4 .DB $7D,$14,$CE,$31,$D4,$B9,$CD,$07,$40
B9 CD 07 40
8984 ; P[08] = 3.824952356185897735160588078446136783779E3
8985 F86613 98 15 15 FD 5B .DB $98,$15,$15,$FD,$5B,$9C,$06,$E3,$62
9C 06 E3 62
8986 F8661C 2F 09 D7 D9 3C .DB $2F,$09,$D7,$D9,$3C,$0F,$EF,$0A,$40
0F EF 0A 40
8987 ; P[07] = 2.128857716871515081352991964243375186031E4
8988 F86625 61 2D 76 77 32 .DB $61,$2D,$76,$77,$32,$6D,$65,$F8,$B4
6D 65 F8 B4
8989 F8662E B1 67 A8 82 27 .DB $B1,$67,$A8,$82,$27,$51,$A6,$0D,$40
51 A6 0D 40
8990 ; P[06] = 7.594356839258970405033155585486712125861E4
8991 F86637 F5 CF 31 FA 60 .DB $F5,$CF,$31,$FA,$60,$22,$5B,$82,$A8
22 5B 82 A8
8992 F86640 08 A0 16 C1 C8 .DB $08,$A0,$16,$C1,$C8,$53,$94,$0F,$40
53 94 0F 40
8993 ; P[05] = 1.797628303815655343403735250238293741397E5
8994 F86649 D2 08 FC D7 90 .DB $D2,$08,$FC,$D7,$90,$40,$A4,$21,$F6
40 A4 21 F6
8995 F86652 CA B8 F8 24 B5 .DB $CA,$B8,$F8,$24,$B5,$8C,$AF,$10,$40
8C AF 10 40
8996 ; P[04] = 2.854829159639697837788887080758954924001E5
8997 F8665B 98 EA 19 A8 D5 .DB $98,$EA,$19,$A8,$D5,$B8,$B8,$25,$24
B8 B8 25 24
8998 F86664 D1 AB 93 4F 5D .DB $D1,$AB,$93,$4F,$5D,$65,$8B,$11,$40
65 8B 11 40
8999 ; P[03] = 3.007007295140399532324943111654767187848E5
9000 F8666D 96 EF 0E 45 35 .DB $96,$EF,$0E,$45,$35,$32,$FC,$95,$4D
32 FC 95 4D
9001 F86676 F2 D3 2D 58 97 .DB $F2,$D3,$2D,$58,$97,$D3,$92,$11,$40
D3 92 11 40
9002 ; P[02] = 2.014652742082537582487669938141683759923E5
9003 F8667F 5E E2 69 C5 8D .DB $5E,$E2,$69,$C5,$8D,$BE,$39,$2E,$D6
BE 39 2E D6
9004 F86688 8B C6 A0 8C 51 .DB $8B,$C6,$A0,$8C,$51,$BE,$C4,$10,$40
BE C4 10 40
9005 ; P[01] = 7.771154681358524243729929227226708890930E4
9006 F86691 AE E9 03 6A 3B .DB $AE,$E9,$03,$6A,$3B,$ED,$92,$AC,$F8
ED 92 AC F8
9007 F8669A CF D0 FC FD C5 .DB $CF,$D0,$FC,$FD,$C5,$C7,$97,$0F,$40
C7 97 0F 40
9008 ; P[00] = 1.313572404063446165910279910527789794488E4
Tue Jul 17 11:00:18 2018 Page 114
9009 F866A3 35 07 BE 83 BC .DB $35,$07,$BE,$83,$BC,$26,$2A,$5C,$A0
26 2A 5C A0
9010 F866AC F3 77 E8 6A E5 .DB $F3,$77,$E8,$6A,$E5,$3E,$CD,$0C,$40
3E CD 0C 40
9011 F866B5
9012 F866B5 clnq:
9013 ; Q[11] = 4.839208193348159620282142911143429644326E1
9014 F866B5 19 97 D2 BF 46 .DB $19,$97,$D2,$BF,$46,$56,$ED,$89,$10
56 ED 89 10
9015 F866BE A5 9F 26 ED 7D .DB $A5,$9F,$26,$ED,$7D,$91,$C1,$04,$40
91 C1 04 40
9016 ; Q[10] = 9.104928120962988414618126155557301584078E2
9017 F866C7 C0 4E B7 7A BC .DB $C0,$4E,$B7,$7A,$BC,$63,$F1,$97,$7D
63 F1 97 7D
9018 F866D0 4F 2B BF 3B 8A .DB $4F,$2B,$BF,$3B,$8A,$9F,$E3,$08,$40
9F E3 08 40
9019 ; Q[09] = 9.147150349299596453976674231612674085381E3
9020 F866D9 E1 52 82 D3 69 .DB $E1,$52,$82,$D3,$69,$1A,$6A,$4C,$1D
1A 6A 4C 1D
9021 F866E2 F9 B2 2A F5 99 .DB $F9,$B2,$2A,$F5,$99,$EC,$8E,$0C,$40
EC 8E 0C 40
9022 ; Q[08] = 5.605842085972455027590989944010492125825E4
9023 F866EB B8 65 30 7A BB .DB $B8,$65,$30,$7A,$BB,$1D,$CD,$02,$A2
1D CD 02 A2
9024 F866F4 25 81 76 BD 6B .DB $25,$81,$76,$BD,$6B,$FA,$DA,$0E,$40
FA DA 0E 40
9025 ; Q[07] = 2.248234257620569139969141618556349415120E5
9026 F866FD A2 CA 5D F8 7F .DB $A2,$CA,$5D,$F8,$7F,$A4,$A6,$11,$B1
A4 A6 11 B1
9027 F86706 94 7F AF 3F DB .DB $94,$7F,$AF,$3F,$DB,$8D,$DB,$10,$40
8D DB 10 40
9028 ; Q[06] = 6.132189329546557743179177159925690841200E5
9029 F8670F 7A 44 71 27 79 .DB $7A,$44,$71,$27,$79,$DE,$89,$E3,$39
DE 89 E3 39
9030 F86718 73 DC 61 ED 2E .DB $73,$DC,$61,$ED,$2E,$B6,$95,$12,$40
B6 95 12 40
9031 ; Q[05] = 1.158019977462989115839826904108208787040E6
9032 F86721 2A BB 38 BE F1 .DB $2A,$BB,$38,$BE,$F1,$46,$B7,$69,$6C
46 B7 69 6C
9033 F8672A 9A 1D D8 D1 1F .DB $9A,$1D,$D8,$D1,$1F,$5C,$8D,$13,$40
5C 8D 13 40
9034 ; Q[04] = 1.514882452993549494932585972882995548426E6
9035 F86733 C0 3A 8A D9 4A .DB $C0,$3A,$8A,$D9,$4A,$87,$5D,$9C,$09
87 5D 9C 09
9036 F8673C 03 15 BB 9F 13 .DB $03,$15,$BB,$9F,$13,$EC,$B8,$13,$40
EC B8 13 40
9037 ; Q[03] = 1.347518538384329112529391120390701166528E6
9038 F86745 70 CA B9 8E 83 .DB $70,$CA,$B9,$8E,$83,$73,$EC,$DA,$BC
73 EC DA BC
9039 F8674E 71 71 9C 4E F4 .DB $71,$71,$9C,$4E,$F4,$7D,$A4,$13,$40
7D A4 13 40
9040 ; Q[02] = 7.777690340007566932935753241556479363645E5
9041 F86757 10 A8 3B 99 11 .DB $10,$A8,$3B,$99,$11,$F5,$D7,$57,$97
F5 D7 57 97
9042 F86760 A0 60 44 8B 90 .DB $A0,$60,$44,$8B,$90,$E2,$BD,$12,$40
E2 BD 12 40
9043 ; Q[01] = 2.626900195321832660448791748036714883242E5
Tue Jul 17 11:00:18 2018 Page 115
9044 F86769 97 4B 94 D0 A5 .DB $97,$4B,$94,$D0,$A5,$28,$E9,$C7,$1B
28 E9 C7 1B
9045 F86772 0B F5 01 A0 40 .DB $0B,$F5,$01,$A0,$40,$44,$80,$11,$40
44 80 11 40
9046 ; Q[00] = 3.940717212190338497730839731583397586124E4
9047 F8677B 95 DD E4 62 0D .DB $95,$DD,$E4,$62,$0D,$9D,$1F,$45,$B8
9D 1F 45 B8
9048 F86784 F6 59 2E 10 2C .DB $F6,$59,$2E,$10,$2C,$EF,$99,$0E,$40
EF 99 0E 40
9049
9050 ; C1 + C2 = loge(2) (splitted in two)
9051 ; C1 = 6.93145751953125E-1
9052 F8678D 00 00 00 00 00 ln2c1: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
9053 F86796 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$72,$B1,$FE,$3F
72 B1 FE 3F
9054
9055 ; C2 = 1.428606820309417232121458176568075500134E-6
9056 F8679F 98 07 7A B5 97 ln2c2: .DB $98,$07,$7A,$B5,$97,$1F,$C0,$9C,$1D
1F C0 9C 1D
9057 F867A8 4F 5E CD 7B 8E .DB $4F,$5E,$CD,$7B,$8E,$BE,$BF,$EB,$3F
BE BF EB 3F
9058
9059 ; ln(2) = 0.6931471805599453094172321214581765680755001
9060 F867B1 AF F6 F2 03 98 cln2: .DB $AF,$F6,$F2,$03,$98,$B3,$E3,$C9,$AB
B3 E3 C9 AB
9061 F867BA 79 CF D1 F7 17 .DB $79,$CF,$D1,$F7,$17,$72,$B1,$FE,$3F
72 B1 FE 3F
9062
9063 ; log10(2) = l102a + l102b (splitted in two)
9064 ; l102a = 0.3125
9065 F867C3 00 00 00 00 00 l102a: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
9066 F867CC 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$A0,$FD,$3F
00 A0 FD 3F
9067
9068 ; l102b = -1.14700043360188047862611052755069732318101185E-2
9069 F867D5 F8 D0 6D 90 7E l102b: .DB $F8,$D0,$6D,$90,$7E,$CA,$D4,$0E,$EE
CA D4 0E EE
9070 F867DE 0C 01 86 60 AF .DB $0C,$01,$86,$60,$AF,$EC,$BB,$F8,$BF
EC BB F8 BF
9071
9072 ; log10(e) = l10ea + l10eb (splitted in two)
9073 ; l10ea = 0.5
9074 F867E7 00 00 00 00 00 l10ea: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
9075 F867F0 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$80,$FE,$3F
00 80 FE 3F
9076 ; l10eb = -6.570551809674817234887108108339491770560299E-2
9077 F867F9 36 8F 30 4B 41 l10eb: .DB $36,$8F,$30,$4B,$41,$55,$91,$2A,$AB
55 91 2A AB
9078 F86802 39 5E 23 5B 9D .DB $39,$5E,$23,$5B,$9D,$90,$86,$FB,$BF
90 86 FB BF
9079
9080 ; log2(e) = 1/loge(2)
9081 ; lg2e = 1.442695040888963407359924681001892137426646
9082 F8680B 86 3E 1D 69 D0 lg2e: .DB $86,$3E,$1D,$69,$D0,$FE,$87,$BE,$BB
Tue Jul 17 11:00:18 2018 Page 116
FE 87 BE BB
9083 F86814 F0 17 5C 29 3B .DB $F0,$17,$5C,$29,$3B,$AA,$B8,$FF,$3F
AA B8 FF 3F
9084
9085 ;----------------------------------------------------------------------------
9086 ; exponential family functions
9087 ;----------------------------------------------------------------------------
9088
9089 ; fexp2 - return 2 raised to the x power
9090 ;
9091 ; entry:
9092 ; fac = x
9093 ;
9094 ; exit: x
9095 ; fac = 2
9096 ; CF = 1 if invalid result (nan, inf)
9097 ;
9098 ; computation mean time: 50ms at 4MHz (4ms for integer argument)
9099 ;
9100 ;-----
9101 F8681D fexp2:
9102 ;-----
9103 F8681D 24 25 bit facst
9104 F8681F 10 0D bpl ?fv ; fac is valid
9105 F86821 50 09 bvc ?er ; fac=nan so return nan
9106 F86823 24 24 bit facsgn
9107 F86825 10 05 bpl ?er ; fac=+inf so return +inf
9108 F86827 64 24 ?zz: stz facsgn ; fac=-inf so return 0
9109 F86829 4C 56 4E jmp fldz
9110 F8682C 38 ?er: sec
9111 F8682D 60 rts
9112 F8682E 20 26 4D ?fv: jsr frndm
9113 F86831 24 24 bit facsgn
9114 F86833 30 0E bmi ?xn ; x is negative
9115 F86835 A9 32 lda #<maxl2 ; check if argument can cause overflow
9116 F86837 A0 71 ldy #>maxl2
9117 F86839 20 5E 87 jsr fccmp
9118 F8683C 30 0E bmi ?ok ; if x < maxl2 then no overflow
9119 F8683E F0 0C beq ?ok
9120 F86840 4C 7D 4E jmp fldinf ; overflow so return +inf
9121 F86843 A9 44 ?xn: lda #<minl2 ; check if argument can cause underflow
9122 F86845 A0 71 ldy #>minl2
9123 F86847 20 5E 87 jsr fccmp
9124 F8684A 30 DB bmi ?zz ; if x < minl2 then underflow
9125 F8684C ?ok: ACC16
9126 F8684C C2 20 rep #PMFLAG
9127 .LONGA on
9128 .MNLIST
9129 F8684E 64 B4 stz fcpc0 ; log2(2) = 1
9130 F86850 64 B6 stz fcpc1
9131 F86852 64 B8 stz fcpc2
9132 F86854 A9 7E 70 lda #ce2p ; P coefficients
9133 F86857 85 BA sta fcpp
9134 F86859 A9 D8 70 lda #ce2q ; Q coefficients
9135 F8685C 85 BC sta fcpq
9136 F8685E A2 04 ldx #4 ; P: degree 4
9137 F86860 86 BE stx fcpd
Tue Jul 17 11:00:18 2018 Page 117
9138 F86862 86 BF stx fcqd ; Q: degree 4
9139 F86864 ACC08
9140 F86864 E2 20 sep #PMFLAG
9141 .LONGA off
9142 .MNLIST
9143 F86866 A9 FF lda #$FF ; Q polynomial N+1
9144 F86868 4C 18 69 jmp expev
9145
9146 ; fexp - return e raised to the x power
9147 ;
9148 ; entry:
9149 ; fac = x
9150 ;
9151 ; exit: x
9152 ; fac = e
9153 ; CF = 1 if invalid result (nan, inf)
9154 ;
9155 ; computation mean time: 60ms at 4MHz
9156 ;
9157 ;----
9158 F8686B fexp:
9159 ;----
9160 F8686B 24 25 bit facst
9161 F8686D 24 25 bit facst
9162 F8686F 10 0D bpl ?fv ; fac is valid
9163 F86871 50 09 bvc ?er ; fac=nan so return nan
9164 F86873 24 24 bit facsgn
9165 F86875 10 05 bpl ?er ; fac=+inf so return +inf
9166 F86877 64 24 ?zz: stz facsgn ; fac=-inf so return 0
9167 F86879 4C 56 4E jmp fldz
9168 F8687C 38 ?er: sec
9169 F8687D 60 rts
9170 F8687E 20 26 4D ?fv: jsr frndm
9171 F86881 24 24 bit facsgn
9172 F86883 30 0E bmi ?xn ; x is negative
9173 F86885 A9 04 lda #<maxln ; check if argument can cause overflow
9174 F86887 A0 6F ldy #>maxln
9175 F86889 20 5E 87 jsr fccmp
9176 F8688C 30 0E bmi ?ok ; if x <= maxln then no overflow
9177 F8688E F0 0C beq ?ok
9178 F86890 4C 7D 4E jmp fldinf ; overflow so return +inf
9179 F86893 A9 16 ?xn: lda #<minln ; check if argument can cause underflow
9180 F86895 A0 6F ldy #>minln
9181 F86897 20 5E 87 jsr fccmp
9182 F8689A 30 DB bmi ?zz ; if x < minln then underflow
9183 F8689C ?ok: ACC16
9184 F8689C C2 20 rep #PMFLAG
9185 .LONGA on
9186 .MNLIST
9187 F8689E A9 0B 68 lda #lg2e ; log2(e)
9188 F868A1 85 B4 sta fcpc0
9189 F868A3 A9 8D 67 lda #ln2c1 ; loge(2) first piece
9190 F868A6 85 B6 sta fcpc1
9191 F868A8 A9 9F 67 lda #ln2c2 ; loge(2) 2nd piece
9192 F868AB 85 B8 sta fcpc2
9193 F868AD A9 1E 6D lda #ceep ; P coefficients
9194 F868B0 85 BA sta fcpp
Tue Jul 17 11:00:18 2018 Page 118
9195 F868B2 A9 78 6D lda #ceeq ; Q coefficients
9196 F868B5 85 BC sta fcpq
9197 F868B7 A2 04 ldx #4 ; P: degree 4
9198 F868B9 86 BE stx fcpd
9199 F868BB E8 inx
9200 F868BC 86 BF stx fcqd ; Q: degree 5
9201 F868BE ACC08
9202 F868BE E2 20 sep #PMFLAG
9203 .LONGA off
9204 .MNLIST
9205 F868C0 A9 00 lda #$00 ; Q polynomial N
9206 F868C2 80 54 bra expev
9207
9208 ; fexp10 - return 10 raised to the x power
9209 ;
9210 ; entry:
9211 ; fac = x
9212 ;
9213 ; exit: x
9214 ; fac = 10
9215 ; CF = 1 if invalid result (nan, inf)
9216 ;
9217 ; computation mean time: 65ms at 4MHz
9218 ;
9219 ;------
9220 F868C4 fexp10:
9221 ;------
9222 F868C4 24 25 bit facst
9223 F868C6 10 0D bpl ?fv ; fac is valid
9224 F868C8 50 09 bvc ?er ; fac=nan so return nan
9225 F868CA 24 24 bit facsgn
9226 F868CC 10 05 bpl ?er ; fac=+inf so return +inf
9227 F868CE 64 24 ?zz: stz facsgn ; fac=-inf so return 0
9228 F868D0 4C 56 4E jmp fldz
9229 F868D3 38 ?er: sec
9230 F868D4 60 rts
9231 F868D5 20 26 4D ?fv: jsr frndm
9232 F868D8 24 24 bit facsgn
9233 F868DA 30 0E bmi ?xn ; x is negative
9234 F868DC A9 5A lda #<maxl10 ; check if argument can cause overflow
9235 F868DE A0 70 ldy #>maxl10
9236 F868E0 20 5E 87 jsr fccmp
9237 F868E3 30 0E bmi ?ok ; if x <= maxl10 then no overflow
9238 F868E5 F0 0C beq ?ok
9239 F868E7 4C 7D 4E jmp fldinf ; overflow so return +inf
9240 F868EA A9 6C ?xn: lda #<minl10 ; check if argument can cause underflow
9241 F868EC A0 70 ldy #>minl10
9242 F868EE 20 5E 87 jsr fccmp
9243 F868F1 30 DB bmi ?zz ; if x < minl10 then underflow
9244 F868F3 ?ok: ACC16
9245 F868F3 C2 20 rep #PMFLAG
9246 .LONGA on
9247 .MNLIST
9248 F868F5 A9 48 70 lda #lg210 ; log2(10)
9249 F868F8 85 B4 sta fcpc0
9250 F868FA A9 24 70 lda #lg102a ; log10(2) first piece
9251 F868FD 85 B6 sta fcpc1
Tue Jul 17 11:00:18 2018 Page 119
9252 F868FF A9 36 70 lda #lg102b ; log10(2) 2nd piece
9253 F86902 85 B8 sta fcpc2
9254 F86904 A9 4C 6F lda #ce10p ; P coefficients
9255 F86907 85 BA sta fcpp
9256 F86909 A9 B8 6F lda #ce10q ; Q coefficients
9257 F8690C 85 BC sta fcpq
9258 F8690E A2 05 ldx #5 ; degree
9259 F86910 86 BE stx fcpd
9260 F86912 86 BF stx fcqd
9261 F86914 ACC08
9262 F86914 E2 20 sep #PMFLAG
9263 .LONGA off
9264 .MNLIST
9265 F86916 A9 FF lda #$FF ; Q polynomial N+1
9266 F86918
9267 ; expev - common exponential function evaluation
9268 ;
9269 ; entry:
9270 ; fac = x, valid argument
9271 ; A = $00 if exp(x), otherwise A = $FF
9272 ; fcpc0 = pointer to a constant = log2(b)
9273 ; fcpc1 = pointer to a splitted constant = logb(2)
9274 ; fcpc2 = pointer to a splitted constant = logb(2)
9275 ; fcpp = pointer to P polynomial coefficients
9276 ; fcpq = pointer to Q polynomial coefficients
9277 ; fcpd = P polynomial degree
9278 ; fcqd = Q polynomial degree
9279 ;
9280 ; exit: x
9281 ; fac = b , where b=e or b=10 or b=2
9282 ;
9283 ; strategy:
9284 ;
9285 ; Range reduction is accomplished by separating the argument x into
9286 ; an integer M and a fraction f such that:
9287 ;
9288 ; x f M
9289 ; b = b * 2 where |f| < 0.5 * log (2)
9290 ; b
9291 ; f
9292 ; A rational function (Pade' form) is then used to approximate b in
9293 ; the basic range [-0.5 * log (2), +0.5 * log (2)]:
9294 ; b b
9295 ;
9296 ; f P(z) 2
9297 ; b = 1 + 2f ------------- where z = f
9298 ; Q(z) - fP(Z)
9299 ;
9300 ; Finally, get the result scaling the approximate exponential of the
9301 ; fraction by a power of two:
9302 ;
9303 ; x f M
9304 ; b = b * 2
9305 ;
9306 ; Note:
9307 ; Error amplification in the exponential function can be a serious matter.
9308 ; The error propagation involves exp(x(1+delta)) = exp(x)(1 + x*delta + ...),
Tue Jul 17 11:00:18 2018 Page 120
9309 ; which shows that a 1 lsb error in representing x produces a relative error
9310 ; of x times 1 lsb in the function.
9311 ; While the routine gives an accurate result for arguments that are exactly
9312 ; represented by a long double precision number, the result contains amplified
9313 ; roundoff error for large arguments not exactly represented.
9314 ;
9315 ;-----
9316 F86918 expev:
9317 ;-----
9318 F86918 85 C0 sta fcpolf ; Q polynomial flag degree N+1
9319 F8691A 20 93 84 jsr mvf_t1 ; tfr1=x (save argument)
9320 F8691D A5 B4 lda fcpc0 ; x * log2(b) (logarithm base 2 of b)
9321 F8691F AA tax
9322 F86920 05 B5 ora fcpc0+1 ; if b=2 skip this multiplication
9323 F86922 F0 06 beq ?no2
9324 F86924 8A txa
9325 F86925 A4 B5 ldy fcpc0+1
9326 F86927 20 D5 49 jsr fcmult ; x*log2(b)
9327 F8692A 20 67 45 ?no2: jsr faddhalf ; x*log2(b) + 0.5 (floor truncate toward -inf)
9328 F8692D 20 27 50 jsr floor ; get integral part w = floor(x*log2(b) + 0.5)
9329 F86930 20 66 84 jsr mvf_t0 ; tfr0=w
9330 F86933 20 78 4F jsr uitrunc ; convert w to integer 16 bit
9331 F86936 ACC16
9332 F86936 C2 20 rep #PMFLAG
9333 .LONGA on
9334 .MNLIST
9335 F86938 A5 00 lda tm
9336 F8693A A6 24 ldx facsgn ; sign of M
9337 F8693C 10 04 bpl ?mp
9338 F8693E 49 FF FF eor #$FFFF
9339 F86941 1A inc a
9340 F86942 85 46 ?mp: sta scexp ; scexp=M (for final scaling)
9341 F86944 ACC08
9342 F86944 E2 20 sep #PMFLAG
9343 .LONGA off
9344 .MNLIST
9345 F86946
9346 ; now compute x - logb(2)*w, the remainder of x/w
9347 F86946 20 47 85 jsr mvt0_f ; fac=w
9348 F86949 A5 B6 lda fcpc1 ; pointer to first piece of splitted -logb(2)
9349 F8694B AA tax
9350 F8694C 05 B7 ora fcpc1+1 ; if b=2 skip this multiplication
9351 F8694E F0 19 beq ?skp ; if b=2 the remainder is: x-w
9352 F86950 8A txa
9353 F86951 A4 B7 ldy fcpc1+1 ; logb(2) is splitted in two pieces
9354 F86953 20 D5 49 jsr fcmult ; first piece
9355 F86956 20 FB 85 jsr mvt1_a ; arg=x
9356 F86959 20 5F 45 jsr fpsub
9357 F8695C 20 93 84 jsr mvf_t1 ; tfr1=x-c1
9358 F8695F 20 47 85 jsr mvt0_f ; fac=w
9359 F86962 A5 B8 lda fcpc2
9360 F86964 A4 B9 ldy fcpc2+1
9361 F86966 20 D5 49 jsr fcmult ; 2nd piece
9362 F86969 20 FB 85 ?skp: jsr mvt1_a ; arg=x-c1
9363 F8696C 20 5F 45 jsr fpsub ; x-c1-c2 = x - logb(2)*w
9364 F8696F
9365 ; now we have fac = f = x - logb(2)*w, the fraction part
Tue Jul 17 11:00:18 2018 Page 121
9366 ; where: |f| < 0.5*logb(2), and we approximate exponential of fraction
9367 F8696F 20 93 84 jsr mvf_t1 ; tfr1=f
9368 F86972 20 CC 49 jsr fsquare ; z=f*f
9369 F86975 20 66 84 jsr mvf_t0 ; tfr0=z
9370 F86978 A5 BA lda fcpp ; pointer to P(z) coefficients
9371 F8697A A4 BB ldy fcpp+1
9372 F8697C A6 BE ldx fcpd ; P(z) degree
9373 F8697E 20 1C 87 jsr peval ; evaluate P(z)
9374 F86981 20 FB 85 jsr mvt1_a ; arg=f
9375 F86984 20 DD 49 jsr fpmult ; f*P(z)
9376 F86987 20 C0 84 jsr mvf_t2 ; tfr2=f*P(z)
9377 F8698A A5 BC lda fcpq ; pointer to Q(z) coefficients
9378 F8698C A4 BD ldy fcpq+1
9379 F8698E A6 BF ldx fcqd ; Q(z) dregree
9380 F86990 24 C0 bit fcpolf
9381 F86992 10 05 bpl ?dn ; exp(x)
9382 F86994 20 3A 87 jsr pevalp1 ; evaluate Q(z) for exp10(x) & exp2(x)
9383 F86997 80 03 bra ?dn2
9384 F86999 20 1C 87 ?dn: jsr peval ; evaluate Q(z) for exp(x)
9385 F8699C 20 28 86 ?dn2: jsr mvt2_a
9386 F8699F A5 3C lda argsgn
9387 F869A1 49 FF eor #$FF
9388 F869A3 85 3C sta argsgn ; arg=-f*P(z)
9389 F869A5 20 7D 45 jsr fpadd ; fac = Q(z) - f*P(z)
9390 F869A8 20 28 86 jsr mvt2_a ; arg = f*P(z)
9391 F869AB 20 10 4A jsr fpdiv ; y=f*P(z)/(Q(z) - f*P(z))
9392 F869AE 20 66 84 jsr mvf_t0 ; tfr0=y
9393 F869B1 20 6C 45 jsr faddone ; 1+y
9394 F869B4 20 CE 85 jsr mvt0_a
9395 F869B7 20 7D 45 jsr fpadd ; 1+y+y=1+2*y = 1 + 2*f*P(z)/(Q(z) - f*P(z))
9396 F869BA 4C B7 48 jmp fscale ; scale by M, return exponential
9397
9398 ; fexpm1 - return e raised to the x power, minus 1
9399 ;
9400 ; entry:
9401 ; fac = x
9402 ;
9403 ; exit: x
9404 ; fac = e - 1
9405 ; CF = 1 if invalid result (nan, inf)
9406 ;
9407 ; For small magnitude values of x, expm1 may be more accurate than exp(x) - 1
9408 ;
9409 ; strategy:
9410 ;
9411 ; Range reduction is accomplished by separating the argument x into
9412 ; an integer M and a fraction f such that:
9413 ;
9414 ; x f M
9415 ; e = e * 2 where |f| < 0.5 * log (2)
9416 ; e
9417 ; f
9418 ; A rational function is then used to approximate e - 1 in
9419 ; the basic range [-0.5 * log (2), +0.5 * log (2)]:
9420 ; e e
9421 ;
9422 ; f 2 3 P(f) f
Tue Jul 17 11:00:18 2018 Page 122
9423 ; e - 1 = f + 0.5f + f ------ = y, e = y + 1
9424 ; Q(f)
9425 ;
9426 ; Finally, get the result scaling the approximate exponential of the
9427 ; fraction by a power of two:
9428 ;
9429 ; x f M M
9430 ; e = e * 2 = (y + 1)*2 so:
9431 ;
9432 ; x M M
9433 ; e - 1 = y * 2 + 2 - 1
9434 ;
9435 ; computation mean time: 90ms at 4MHz
9436 ;
9437 ;------
9438 F869BD fexpm1:
9439 ;------
9440 F869BD 24 25 bit facst
9441 F869BF 10 0B bpl ?fv ; fac is valid
9442 F869C1 70 07 bvs ?er ; fac=nan so return nan
9443 F869C3 24 24 bit facsgn
9444 F869C5 10 03 bpl ?er ; fac=+inf so return +inf
9445 F869C7 4C 32 4E ?m1: jmp fldm1 ; fac=-inf so return -1
9446 F869CA 38 ?er: sec
9447 F869CB 60 rts
9448 F869CC 20 26 4D ?fv: jsr frndm
9449 F869CF 24 24 bit facsgn
9450 F869D1 30 0E bmi ?xn ; x is negative
9451 F869D3 A9 04 lda #<maxln ; check if argument can cause overflow
9452 F869D5 A0 6F ldy #>maxln
9453 F869D7 20 5E 87 jsr fccmp
9454 F869DA 30 0E bmi ?ok ; if x <= maxln then no overflow
9455 F869DC F0 0C beq ?ok
9456 F869DE 4C 7D 4E jmp fldinf ; overflow so return +inf
9457 F869E1 A9 28 ?xn: lda #<mxm1 ; check if argument can cause underflow
9458 F869E3 A0 6F ldy #>mxm1
9459 F869E5 20 5E 87 jsr fccmp
9460 F869E8 30 DD bmi ?m1 ; if x < mxm1 then underflow, return -1
9461 F869EA 20 66 84 ?ok: jsr mvf_t0 ; tfr0=x
9462 F869ED A9 0B lda #<lg2e ; x*log2(e)
9463 F869EF A0 68 ldy #>lg2e
9464 F869F1 20 D5 49 jsr fcmult
9465 F869F4 20 67 45 jsr faddhalf ; express x = ln 2 (M + remainder)...
9466 F869F7 20 27 50 jsr floor ; ...remainder not exceeding 1/2.
9467 F869FA 20 93 84 jsr mvf_t1 ; tfr1=w=integral part
9468 F869FD 20 78 4F jsr uitrunc ; convert to integer
9469 F86A00 ACC16
9470 F86A00 C2 20 rep #PMFLAG
9471 .LONGA on
9472 .MNLIST
9473 F86A02 A5 00 lda tm
9474 F86A04 A6 24 ldx facsgn ; sign of M
9475 F86A06 10 04 bpl ?mp
9476 F86A08 49 FF FF eor #$FFFF
9477 F86A0B 1A inc a
9478 F86A0C 85 46 ?mp: sta scexp ; scexp=M (for final scaling)
9479 F86A0E ACC08
Tue Jul 17 11:00:18 2018 Page 123
9480 F86A0E E2 20 sep #PMFLAG
9481 .LONGA off
9482 .MNLIST
9483 F86A10 20 74 85 jsr mvt1_f
9484 F86A13 A9 8D lda #<ln2c1 ; remainder times loge(2)
9485 F86A15 A0 67 ldy #>ln2c1
9486 F86A17 20 D5 49 jsr fcmult
9487 F86A1A 20 CE 85 jsr mvt0_a
9488 F86A1D 20 5F 45 jsr fpsub
9489 F86A20 20 66 84 jsr mvf_t0
9490 F86A23 20 74 85 jsr mvt1_f
9491 F86A26 A9 9F lda #<ln2c2
9492 F86A28 A0 67 ldy #>ln2c2
9493 F86A2A 20 D5 49 jsr fcmult
9494 F86A2D 20 CE 85 jsr mvt0_a
9495 F86A30 20 5F 45 jsr fpsub
9496 F86A33 20 66 84 jsr mvf_t0 ; tfr0=f=fraction
9497 F86A36 20 CC 49 jsr fsquare
9498 F86A39 20 93 84 jsr mvf_t1 ; tfr1=f*f
9499 F86A3C A9 E4 lda #<cem1p
9500 F86A3E A0 6D ldy #>cem1p
9501 F86A40 A2 07 ldx #7
9502 F86A42 20 1C 87 jsr peval ; evaluate P(f)
9503 F86A45 20 FB 85 jsr mvt1_a
9504 F86A48 20 DD 49 jsr fpmult ; f*f*P(f)
9505 F86A4B 20 CE 85 jsr mvt0_a
9506 F86A4E 20 DD 49 jsr fpmult ; f*f*f*P(f)
9507 F86A51 20 C0 84 jsr mvf_t2 ; tfr2=f*f*f*P(f)
9508 F86A54 A9 74 lda #<cem1q
9509 F86A56 A0 6E ldy #>cem1q
9510 F86A58 A2 07 ldx #7
9511 F86A5A 20 3A 87 jsr pevalp1 ; evaluate Q(f)
9512 F86A5D 20 28 86 jsr mvt2_a
9513 F86A60 20 10 4A jsr fpdiv ; f*f*f*P(f)/Q(f)
9514 F86A63 20 FB 85 jsr mvt1_a ; f*f
9515 F86A66 ACC16
9516 F86A66 C2 20 rep #PMFLAG
9517 .LONGA on
9518 .MNLIST
9519 F86A68 A5 3A lda argexp
9520 F86A6A F0 03 beq ?isz
9521 F86A6C 3A dec a
9522 F86A6D 85 3A sta argexp ; f*f/2
9523 F86A6F ?isz: ACC08
9524 F86A6F E2 20 sep #PMFLAG
9525 .LONGA off
9526 .MNLIST
9527 F86A71 20 7D 45 jsr fpadd
9528 F86A74 20 CE 85 jsr mvt0_a ; arg=f
9529 F86A77 20 7D 45 jsr fpadd
9530 F86A7A 20 66 84 jsr mvf_t0 ; tfr0=y=f + 0.5*f*f + f*f*f*P(f)/Q(f)
9531 F86A7D 20 2E 4E jsr fldp1 ; fac=+1
9532 F86A80 20 B7 48 jsr fscale ; 2^M
9533 F86A83 20 93 84 jsr mvf_t1 ; tfr1=2^M
9534 F86A86 20 CE 85 jsr mvt0_a ; tfr0=y
9535 F86A89 20 DD 49 jsr fpmult ; y*2^M
9536 F86A8C 20 66 84 jsr mvf_t0
Tue Jul 17 11:00:18 2018 Page 124
9537 F86A8F 20 74 85 jsr mvt1_f ; 2^M
9538 F86A92 20 71 45 jsr fsubone ; 2^M - 1
9539 F86A95 20 CE 85 jsr mvt0_a
9540 F86A98 4C 7D 45 jmp fpadd ; y*2^M + 2^M - 1
9541
9542 ; fpown - return the argument x raised to the nth power
9543 ;
9544 ; entry:
9545 ; fac = x
9546 ; C = N (signed integer)
9547 ;
9548 ; exit: N
9549 ; fac = x
9550 ; CF = 1 if invalid result (nan, inf)
9551 ;
9552 ; The routine decomposes N as a sum of powers of two.
9553 ; The desired power is a product of two-to-the-kth powers of x.
9554 ; Max. multiplications number (if N=32767) = 28
9555 ;
9556 ; computation mean time: max. 30ms at 4MHz
9557 ;
9558 ;-----
9559 F86A9B fpown:
9560 ;-----
9561 F86A9B 64 45 stz scsgn ; assume positive N
9562 F86A9D ACC16
9563 F86A9D C2 20 rep #PMFLAG
9564 .LONGA on
9565 .MNLIST
9566 F86A9F 89 00 80 bit #$8000
9567 F86AA2 F0 08 beq ?np ; N>=0
9568 F86AA4 49 FF FF eor #$FFFF ; two's complement
9569 F86AA7 1A inc a
9570 F86AA8 A2 80 ldx #$80
9571 F86AAA 86 45 stx scsgn ; N<0
9572 F86AAC 85 46 ?np: sta scexp ; store N
9573 F86AAE 09 00 00 ora #0
9574 F86AB1 ACC08
9575 F86AB1 E2 20 sep #PMFLAG
9576 .LONGA off
9577 .MNLIST
9578 F86AB3 D0 04 bne ?nz
9579 F86AB5 A9 40 lda #$40
9580 F86AB7 04 45 tsb scsgn ; flag: N=0
9581 F86AB9 24 25 ?nz: bit facst ; fac test
9582 F86ABB 10 1B bpl ?fv ; fac is valid
9583 F86ABD 70 11 bvs ?er ; fac=nan, so return nan
9584 F86ABF 24 45 bit scsgn
9585 F86AC1 70 12 bvs ?p1 ; fac=inf: if N=0 return 1
9586 F86AC3 30 0D bmi ?zz ; fac=inf, N<0, so return zero
9587 F86AC5 24 24 bit facsgn
9588 F86AC7 10 07 bpl ?er ; +inf raised to +n, so return +inf
9589 F86AC9 A5 46 lda scexp ; test if N is odd
9590 F86ACB 4A lsr a
9591 F86ACC B0 02 bcs ?er ; fac=-inf, N is odd, so return -inf
9592 F86ACE 64 24 stz facsgn ; fac=-inf, N is even, so return +inf
9593 F86AD0 38 ?er: sec ; exit with invalid flag (nar or inf)
Tue Jul 17 11:00:18 2018 Page 125
9594 F86AD1 60 ?rts: rts
9595 F86AD2 4C 56 4E ?zz: jmp fldz ; set fac=0 and exit
9596 F86AD5 4C 2E 4E ?p1: jmp fldp1 ; set fac=1 and exit
9597 F86AD8 24 45 ?fv: bit scsgn
9598 F86ADA 70 F9 bvs ?p1 ; fac is valid, N=0, so return 1
9599 F86ADC A5 24 lda facsgn
9600 F86ADE 85 4A sta dsgn ; save fac sign and result sign
9601 F86AE0 64 24 stz facsgn ; fac=|x|
9602 F86AE2 20 66 84 jsr mvf_t0 ; tfr0=w=|x|
9603 F86AE5 A5 46 lda scexp
9604 F86AE7 4A lsr a
9605 F86AE8 B0 05 bcs ?go ; N is odd, set y=|x|
9606 F86AEA 20 2E 4E jsr fldp1 ; N is even so set y=1
9607 F86AED 64 4A stz dsgn ; N is even so result is positive
9608 F86AEF 20 93 84 ?go: jsr mvf_t1 ; tfro=y
9609 F86AF2 ?ll: ACC16
9610 F86AF2 C2 20 rep #PMFLAG
9611 .LONGA on
9612 .MNLIST
9613 F86AF4 46 46 lsr scexp ; shift N
9614 F86AF6 ACC08
9615 F86AF6 E2 20 sep #PMFLAG
9616 .LONGA off
9617 .MNLIST
9618 F86AF8 F0 1D beq ?eol ; end of loop
9619 F86AFA 08 php
9620 F86AFB 20 47 85 jsr mvt0_f ; w
9621 F86AFE 20 CC 49 jsr fsquare ; w=w*w, arg to the 2-to-the-kth power
9622 F86B01 B0 13 bcs ?of ; overflow
9623 F86B03 20 66 84 jsr mvf_t0 ; tfr0=w
9624 F86B06 28 plp
9625 F86B07 90 E9 bcc ?ll ; loop
9626 F86B09 20 FB 85 jsr mvt1_a ; y (include in product if N odd)
9627 F86B0C 20 DD 49 jsr fpmult
9628 F86B0F B0 05 bcs ?of ; overflow
9629 F86B11 20 93 84 jsr mvf_t1 ; tfr1=y
9630 F86B14 80 DC bra ?ll ; loop
9631 F86B16 28 ?of: plp
9632 F86B17 A5 4A ?eol: lda dsgn ; set fac sign
9633 F86B19 85 24 sta facsgn
9634 F86B1B 18 clc
9635 F86B1C 24 25 bit facst
9636 F86B1E 10 01 bpl ?ok
9637 F86B20 38 sec ; fac=inf
9638 F86B21 24 45 ?ok: bit scsgn
9639 F86B23 10 AC bpl ?rts ; done if N>0
9640 F86B25 B0 AB bcs ?zz ; y=inf so return 0
9641 F86B27 20 A6 4E jsr ldaone
9642 F86B2A 4C 10 4A jmp fpdiv ; y=1/y
9643
9644 ; frootn - return the nth root of the argument
9645 ;
9646 ; entry:
9647 ; fac = x
9648 ; C = N (integer, N>0)
9649 ;
9650 ; exit: 1/N
Tue Jul 17 11:00:18 2018 Page 126
9651 ; fac = nthroot(x) = x
9652 ; CF = 1 if invalid result (nan, inf)
9653 ;
9654 ; method:
9655 ;
9656 ; 1/N log2(x)/N
9657 ; x = 2
9658 ;
9659 ; computation mean time: 140ms at 4MHz
9660 ;
9661 ;------
9662 F86B2D frootn:
9663 ;------
9664 F86B2D 64 45 stz scsgn ; assume N even
9665 F86B2F ACC16
9666 F86B2F C2 20 rep #PMFLAG
9667 .LONGA on
9668 .MNLIST
9669 F86B31 89 00 80 bit #$8000
9670 F86B34 F0 06 beq ?pos ; N>=0
9671 F86B36 49 FF FF eor #$FFFF ; two's complement
9672 F86B39 1A inc a
9673 F86B3A A2 FF ldx #$FF ; N<0
9674 F86B3C 85 46 ?pos: sta scexp ; store N
9675 F86B3E 09 00 00 ora #0
9676 F86B41 ACC08
9677 F86B41 E2 20 sep #PMFLAG
9678 .LONGA off
9679 .MNLIST
9680 F86B43 F0 03 beq ?nan ; return nan if N=0
9681 F86B45 E8 inx ; return nan if N<0
9682 F86B46 D0 03 bne ?ok
9683 F86B48 4C 74 4E ?nan: jmp fldnan
9684 F86B4B 4A ?ok: lsr a ; N odd?
9685 F86B4C 90 04 bcc ?ev ; no
9686 F86B4E A9 FF lda #$FF
9687 F86B50 85 45 sta scsgn ; flag N odd
9688 F86B52 24 25 ?ev: bit facst ; fac test
9689 F86B54 10 0C bpl ?fv ; fac is valid
9690 F86B56 70 08 bvs ?er ; fac=nan, so return nan
9691 F86B58 24 24 bit facsgn
9692 F86B5A 10 04 bpl ?er ; fac=+inf so return +inf
9693 F86B5C 24 45 bit scsgn ; if N is even and fac=-inf...
9694 F86B5E 50 E8 bvc ?nan ; ...return nan
9695 F86B60 38 ?er: sec ; exit with invalid flag (nar or inf)
9696 F86B61 60 rts
9697 F86B62 50 03 ?fv: bvc ?nz ; fac <> 0
9698 F86B64 4C 56 4E ?z: jmp fldz ; if fac=0 return 0
9699 F86B67 A5 24 ?nz: lda facsgn
9700 F86B69 10 04 bpl ?gte0
9701 F86B6B 24 45 bit scsgn ; if fac<0 and N is even...
9702 F86B6D 50 D9 bvc ?nan ; ...return nan
9703 F86B6F 85 4A ?gte0: sta dsgn
9704 F86B71 ACC16
9705 F86B71 C2 20 rep #PMFLAG
9706 .LONGA on
9707 .MNLIST
Tue Jul 17 11:00:18 2018 Page 127
9708 F86B73 A5 46 lda scexp
9709 F86B75 C9 01 00 cmp #1
9710 F86B78 ACC08
9711 F86B78 E2 20 sep #PMFLAG
9712 .LONGA off
9713 .MNLIST
9714 F86B7A 18 clc
9715 F86B7B F0 2E beq ?rts
9716 F86B7D 64 24 stz facsgn ; fac=|x|
9717 F86B7F A5 4A lda dsgn
9718 F86B81 48 pha ; save fac sign and result sign
9719 F86B82 A5 47 lda scexp+1
9720 F86B84 48 pha
9721 F86B85 A5 46 lda scexp
9722 F86B87 48 pha
9723 F86B88 20 6B 63 jsr flog2 ; log2(x)
9724 F86B8B 90 06 bcc ?ok2
9725 F86B8D 24 24 bit facsgn
9726 F86B8F 10 1A bpl ?rts
9727 F86B91 30 D1 bmi ?z ; returns zero
9728 F86B93 20 C0 84 ?ok2: jsr mvf_t2
9729 F86B96 68 pla ; scexp low
9730 F86B97 7A ply ; scexp high
9731 F86B98 20 5B 4F jsr fldu16 ; convert N to float
9732 F86B9B 68 pla
9733 F86B9C 85 4A sta dsgn ; sign of the result
9734 F86B9E 20 28 86 jsr mvt2_a ; log2(x)
9735 F86BA1 20 10 4A jsr fpdiv ; log2(x)/N
9736 F86BA4 20 1D 68 jsr fexp2 ; exp2(...)
9737 F86BA7 A5 4A lda dsgn
9738 F86BA9 85 24 sta facsgn
9739 F86BAB 60 ?rts: rts
9740
9741 ; fpowxy - return x raised to the yth power
9742 ;
9743 ; entry:
9744 ; fac = y
9745 ; arg = x
9746 ;
9747 ; exit: y
9748 ; fac = x
9749 ; CF = 1 if invalid result (nan, inf)
9750 ;
9751 ; method:
9752 ; 1) for noninteger y or |y|>32767
9753 ;
9754 ; y y*log2(x)
9755 ; x = 2
9756 ;
9757 ; 2) for integer y, |y|<32768:
9758 ;
9759 ; y
9760 ; x = fpown(x, y)
9761 ;
9762 ; computation mean time: max 200ms at 4MHz
9763 ;
9764 ;------
Tue Jul 17 11:00:18 2018 Page 128
9765 F86BAC fpowxy:
9766 ;------
9767 F86BAC A9 C0 lda #$C0 ; if x=nan or y=nan, return nan
9768 F86BAE C5 3D cmp argst
9769 F86BB0 F0 48 beq ?nan
9770 F86BB2 C5 25 cmp facst
9771 F86BB4 F0 44 beq ?nan
9772 F86BB6 64 4B stz powfg
9773 F86BB8 24 25 bit facst
9774 F86BBA 30 72 bmi ?yinf ; y=+/-inf
9775 F86BBC 70 3F bvs ?1 ; if y=0 return +1
9776 F86BBE
9777 ; here y is valid and not zero
9778 F86BBE 20 D6 6C jsr ?yint ; check if y is integer -- fac=w=floor(y)
9779 F86BC1 D0 63 bne ?rst ; y is not integer, restore arg&fac
9780 F86BC3 A9 80 lda #$80
9781 F86BC5 85 4B sta powfg ; powfg<7>: y is integer
9782 F86BC7 20 78 4F jsr uitrunc ; get w as 128 bit integer
9783 F86BCA ACC16
9784 F86BCA C2 20 rep #PMFLAG
9785 .LONGA on
9786 .MNLIST
9787 F86BCC A5 0E lda tm+14
9788 F86BCE 05 0C ora tm+12
9789 F86BD0 05 0A ora tm+10
9790 F86BD2 05 08 ora tm+8
9791 F86BD4 05 06 ora tm+6
9792 F86BD6 05 04 ora tm+4
9793 F86BD8 05 02 ora tm+2
9794 F86BDA D0 27 bne ?ibig ; y is a big integer
9795 F86BDC A5 00 lda tm
9796 F86BDE C9 00 80 cmp #32768
9797 F86BE1 B0 20 bcs ?ibig ; |w|>=32768, is a big integer
9798 F86BE3 A6 24 ldx facsgn ; w sign
9799 F86BE5 10 04 bpl ?pp ; w>0
9800 F86BE7 49 FF FF eor #$FFFF ; two's complement
9801 F86BEA 1A inc a
9802 F86BEB 85 48 ?pp: sta dexp
9803 F86BED ACC08
9804 F86BED E2 20 sep #PMFLAG
9805 .LONGA off
9806 .MNLIST
9807 F86BEF 20 47 85 jsr mvt0_f ; fac=x
9808 F86BF2 A5 49 lda dexp+1 ; y is integer and |y|<32768...
9809 F86BF4 EB xba
9810 F86BF5 A5 48 lda dexp
9811 F86BF7 4C 9B 6A jmp fpown ; ...so call fpown
9812 F86BFA 4C 74 4E ?nan: jmp fldnan ; return nan
9813 F86BFD 4C 2E 4E ?1: jmp fldp1 ; return +1
9814 F86C00 4C 56 4E ?z: jmp fldz ; return 0
9815 F86C03 ?ibig: ACC08 ; y is a big integer and we check if...
9816 F86C03 E2 20 sep #PMFLAG
9817 .LONGA off
9818 .MNLIST
9819 ; ...is odd or even
9820 F86C05 20 74 85 jsr mvt1_f ; restore fac=y
9821 F86C08 A9 FF lda #$FF
Tue Jul 17 11:00:18 2018 Page 129
9822 F86C0A 85 46 sta scexp
9823 F86C0C 85 47 sta scexp+1 ; scexp=-1
9824 F86C0E 20 B7 48 jsr fscale ; w=y/2
9825 F86C11 20 27 50 jsr floor ; w=floor(y/2)
9826 F86C14 A9 01 lda #1
9827 F86C16 85 46 sta scexp
9828 F86C18 64 47 stz scexp+1 ; scexp=1
9829 F86C1A 20 B7 48 jsr fscale ; w*2 = 2*floor(y/2)
9830 F86C1D
9831 ; if 2*floor(y/2) != y then y is an odd integer
9832 F86C1D 20 DF 6C jsr ?cpy ; compare y vs. 2*floor(y/2)
9833 F86C20 F0 04 beq ?rst ; y is an even integer
9834 F86C22 A9 40 lda #$40
9835 F86C24 04 4B tsb powfg ; powfg<6>: odd integer flag
9836 F86C26 20 CE 85 ?rst: jsr mvt0_a ; restore arg=x
9837 F86C29 20 74 85 jsr mvt1_f ; restore fac=y
9838 F86C2C 80 30 bra ?xtst ; go to check x
9839
9840 ?yinf: ; y=+/-inf so check x
9841 F86C2E 24 3D bit argst
9842 F86C30 10 0D bpl ?xv ; x is valid
9843 F86C32 24 3C bit argsgn
9844 F86C34 30 C4 bmi ?nan ; if x=-inf and y=+-inf return nan
9845 F86C36 24 24 bit facsgn
9846 F86C38 30 C6 bmi ?z ; if x=+inf and y=-inf return 0
9847 ; if x=+inf and y=inf return +inf
9848 F86C3A 64 24 ?pi: stz facsgn ; return +inf
9849 F86C3C 4C 7D 4E jmp fldinf
9850
9851 ?xv: ; y=+/-inf and valid x
9852 F86C3F 50 06 bvc ?nz ; x<>0
9853 F86C41 24 24 bit facsgn
9854 F86C43 10 BB bpl ?z ; if x=0 and y=+inf return zero
9855 F86C45 30 F3 bmi ?pi ; if x=0 and y=-inf return zero
9856
9857 ?nz: ; y=+/-inf and x<>0
9858 F86C47 24 3C bit argsgn
9859 F86C49 30 AF bmi ?nan ; if x<0 and y=+-inf return nan
9860 F86C4B 20 B5 6C jsr ?is1 ; check if |x|=1
9861 F86C4E F0 AA beq ?nan ; if |x|=1 and y=+/-inf return nan
9862 F86C50 90 06 bcc ?xm ; |x|<1
9863 F86C52 24 24 bit facsgn
9864 F86C54 10 E4 bpl ?pi ; if |x|>1 and y=+inf return +inf
9865 F86C56 30 A8 bmi ?z ; if |x|>1 and y=-inf return 0
9866 F86C58 24 24 ?xm: bit facsgn
9867 F86C5A 10 A4 bpl ?z ; if |x|<1 and y=+inf return 0
9868 F86C5C 30 DC bmi ?pi ; if |x|<1 and y=-inf return +inf
9869
9870 ?xtst: ; here y is valid and y <> 0 so we check x
9871 F86C5E 24 3D bit argst
9872 F86C60 10 17 bpl ?xv2 ; x is valid
9873 F86C62 24 3C bit argsgn
9874 F86C64 30 06 bmi ?xmi ; x=-inf
9875 F86C66 24 24 bit facsgn
9876 F86C68 10 D0 bpl ?pi ; if x=+inf and y>0 return +inf
9877 F86C6A 30 94 bmi ?z ; if x=+inf and y<0 return 0
9878
Tue Jul 17 11:00:18 2018 Page 130
9879 ?xmi: ; x=-inf -- check if y is odd integer
9880 F86C6C A5 4B lda powfg
9881 F86C6E C9 C0 cmp #$C0 ; y must be odd integer
9882 F86C70 D0 88 bne ?nan
9883 F86C72 A9 FF lda #$FF ; x=-inf and y is an odd integer...
9884 F86C74 85 24 sta facsgn
9885 F86C76 4C 7D 4E jmp fldinf ; ...so return -inf
9886 F86C79
9887 ?xv2: ; now both x and y are valid
9888 F86C79 50 06 bvc ?xv3 ; x<>0
9889 F86C7B 24 24 bit facsgn
9890 F86C7D 10 81 bpl ?z ; if x=0 and y>0 return 0
9891 F86C7F 30 B9 bmi ?pi ; if x=0 and y<0 return +inf
9892 F86C81 24 3C ?xv3: bit argsgn
9893 F86C83 10 0F bpl ?xv4 ; x>0
9894 F86C85 A5 4B lda powfg
9895 F86C87 C9 C0 cmp #$C0 ; if x<0, y must be odd integer
9896 F86C89 F0 03 beq ?xv30
9897 F86C8B 4C 74 4E jmp fldnan
9898 F86C8E A9 01 ?xv30: lda #1
9899 F86C90 04 4B tsb powfg ; powfg<0>: x change sign
9900 F86C92 64 3C stz argsgn ; |x|
9901 F86C94 20 ED 84 ?xv4: jsr mvf_t3 ; tfr3=y
9902 F86C97 20 0C 84 jsr mvatof ; fac=x
9903 F86C9A 20 6B 63 jsr flog2 ; log2(x)
9904 F86C9D B0 0B bcs ?end
9905 F86C9F 20 55 86 jsr mvt3_a ; arg=y
9906 F86CA2 20 DD 49 jsr fpmult ; y*log2(x)
9907 F86CA5 B0 03 bcs ?end
9908 F86CA7 20 1D 68 jsr fexp2 ; 2^(y*log2(x))
9909 F86CAA 46 4B ?end: lsr powfg
9910 F86CAC 90 06 bcc ?e2
9911 F86CAE A5 24 lda facsgn ; change sign to result
9912 F86CB0 49 FF eor #$FF
9913 F86CB2 85 24 sta facsgn
9914 F86CB4 60 ?e2: rts
9915
9916 ?is1: ; check if |arg|=1
9917 F86CB5 ACC16
9918 F86CB5 C2 20 rep #PMFLAG
9919 .LONGA on
9920 .MNLIST
9921 F86CB7 A5 3A lda argexp
9922 F86CB9 C9 FF 3F cmp #EBIAS
9923 F86CBC D0 15 bne ?is0 ; is not 1 (CF=1 if |arg|>=1)
9924 F86CBE A5 38 lda argm+14
9925 F86CC0 C9 00 80 cmp #$8000
9926 F86CC3 D0 0E bne ?is0 ; is not 1
9927 F86CC5 A5 2A lda argm
9928 F86CC7 05 2C ora argm+2
9929 F86CC9 05 2E ora argm+4
9930 F86CCB 05 30 ora argm+6
9931 F86CCD 05 32 ora argm+8
9932 F86CCF 05 34 ora argm+10
9933 F86CD1 05 36 ora argm+12
9934 F86CD3 ?is0: ACC08
9935 F86CD3 E2 20 sep #PMFLAG
Tue Jul 17 11:00:18 2018 Page 131
9936 .LONGA off
9937 .MNLIST
9938 F86CD5 60 rts ; ZF=1 if |arg|=1, CF=1 if |arg|>=1
9939
9940 F86CD6 20 1A 85 ?yint: jsr mva_t0 ; tfr0=x
9941 F86CD9 20 93 84 jsr mvf_t1 ; tfr1=y
9942 F86CDC 20 27 50 jsr floor ; get the integral part of y
9943 F86CDF
9944 ?cpy: ; compare fac vs. y/tfr1 (just for equality)
9945 F86CDF ACC16
9946 F86CDF C2 20 rep #PMFLAG
9947 .LONGA on
9948 .MNLIST
9949 F86CE1 A5 12 lda facm
9950 F86CE3 C5 64 cmp tfr1
9951 F86CE5 D0 34 bne ?cp0
9952 F86CE7 A5 14 lda facm+2
9953 F86CE9 C5 66 cmp tfr1+2
9954 F86CEB D0 2E bne ?cp0
9955 F86CED A5 16 lda facm+4
9956 F86CEF C5 68 cmp tfr1+4
9957 F86CF1 D0 28 bne ?cp0
9958 F86CF3 A5 18 lda facm+6
9959 F86CF5 C5 6A cmp tfr1+6
9960 F86CF7 D0 22 bne ?cp0
9961 F86CF9 A5 1A lda facm+8
9962 F86CFB C5 6C cmp tfr1+8
9963 F86CFD D0 1C bne ?cp0
9964 F86CFF A5 1C lda facm+10
9965 F86D01 C5 6E cmp tfr1+10
9966 F86D03 D0 16 bne ?cp0
9967 F86D05 A5 1E lda facm+12
9968 F86D07 C5 70 cmp tfr1+12
9969 F86D09 D0 10 bne ?cp0
9970 F86D0B A5 20 lda facm+14
9971 F86D0D C5 72 cmp tfr1+14
9972 F86D0F D0 0A bne ?cp0
9973 F86D11 A5 22 lda facm+16
9974 F86D13 C5 74 cmp tfr1+16
9975 F86D15 D0 04 bne ?cp0
9976 F86D17 A5 24 lda facm+18
9977 F86D19 C5 76 cmp tfr1+18
9978 F86D1B ?cp0: ACC08
9979 F86D1B E2 20 sep #PMFLAG
9980 .LONGA off
9981 .MNLIST
9982 F86D1D 60 rts ; ZF=1 if equal
9983
9984 ; coefficients for exp() evaluation
9985 F86D1E ceep:
9986 ; P[4] = 3.279723985560247033712687707263393506266E-10
9987 F86D1E 44 59 3A 65 81 .DB $44,$59,$3A,$65,$81,$28,$53,$8A,$47
28 53 8A 47
9988 F86D27 FE AA B3 F9 02 .DB $FE,$AA,$B3,$F9,$02,$4E,$B4,$DF,$3F
4E B4 DF 3F
9989 ; P[3] = 6.141506007208645008909088812338454698548E-7
9990 F86D30 B0 71 8E FB B2 .DB $B0,$71,$8E,$FB,$B2,$D2,$28,$E7,$FF
Tue Jul 17 11:00:18 2018 Page 132
D2 28 E7 FF
9991 F86D39 4A 4C 8E A0 1B .DB $4A,$4C,$8E,$A0,$1B,$DC,$A4,$EA,$3F
DC A4 EA 3F
9992 ; P[2] = 2.708775201978218837374512615596512792224E-4
9993 F86D42 B6 9E 58 BA 61 .DB $B6,$9E,$58,$BA,$61,$BA,$82,$D8,$A0
BA 82 D8 A0
9994 F86D4B 31 FA 48 B9 90 .DB $31,$FA,$48,$B9,$90,$04,$8E,$F3,$3F
04 8E F3 3F
9995 ; P[1] = 3.508710990737834361215404761139478627390E-2
9996 F86D54 D4 0F B2 5C 74 .DB $D4,$0F,$B2,$5C,$74,$7D,$79,$81,$28
7D 79 81 28
9997 F86D5D BF 78 03 59 80 .DB $BF,$78,$03,$59,$80,$B7,$8F,$FA,$3F
B7 8F FA 3F
9998 ; P[0] = 1
9999 F86D66 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
10000 F86D6F 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$80,$FF,$3F
00 80 FF 3F
10001
10002 F86D78 ceeq:
10003 ; Q[5] = 2.980756652081995192255342779918052538681E-12
10004 F86D78 AA EB 58 3C C8 .DB $AA,$EB,$58,$3C,$C8,$65,$82,$7C,$65
65 82 7C 65
10005 F86D81 FB 7E D8 C6 89 .DB $FB,$7E,$D8,$C6,$89,$C0,$D1,$D8,$3F
C0 D1 D8 3F
10006 ; Q[4] = 1.771372078166251484503904874657985291164E-8
10007 F86D8A F5 58 96 76 83 .DB $F5,$58,$96,$76,$83,$9C,$A6,$21,$0D
9C A6 21 0D
10008 F86D93 1B F5 F8 49 E2 .DB $1B,$F5,$F8,$49,$E2,$28,$98,$E5,$3F
28 98 E5 3F
10009 ; Q[3] = 1.504792651814944826817779302637284053660E-5
10010 F86D9C AE 5F 82 3D 77 .DB $AE,$5F,$82,$3D,$77,$DC,$F3,$E4,$70
DC F3 E4 70
10011 F86DA5 24 62 3D 2E 5A .DB $24,$62,$3D,$2E,$5A,$76,$FC,$EE,$3F
76 FC EE 3F
10012 ; Q[2] = 3.611828913847589925056132680618007270344E-3
10013 F86DAE 68 61 9E E9 6E .DB $68,$61,$9E,$E9,$6E,$9C,$AE,$2E,$1E
9C AE 2E 1E
10014 F86DB7 D4 1F 50 10 6F .DB $D4,$1F,$50,$10,$6F,$B4,$EC,$F6,$3F
B4 EC F6 3F
10015 ; Q[1] = 2.368408864814233538909747618894558968880E-1
10016 F86DC0 76 96 FC D8 64 .DB $76,$96,$FC,$D8,$64,$69,$67,$EB,$3E
69 67 EB 3E
10017 F86DC9 0A 67 2C D7 6A .DB $0A,$67,$2C,$D7,$6A,$86,$F2,$FC,$3F
86 F2 FC 3F
10018 ; Q[0] = 2
10019 F86DD2 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
10020 F86DDB 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$80,$00,$40
00 80 00 40
10021
10022 ; coefficients for expm1() evaluation
10023 F86DE4 cem1p:
10024 ; MP[7] = -4.888737542888633647784737721812546636240E-1
10025 F86DE4 52 E5 66 71 85 .DB $52,$E5,$66,$71,$85,$3C,$04,$05,$0D
3C 04 05 0D
10026 F86DED 8F 39 16 25 A9 .DB $8F,$39,$16,$25,$A9,$4D,$FA,$FD,$BF
Tue Jul 17 11:00:18 2018 Page 133
4D FA FD BF
10027 ; MP[6] = 4.401308817383362136048032038528753151144E1
10028 F86DF6 84 22 38 E7 E0 .DB $84,$22,$38,$E7,$E0,$BC,$D7,$D9,$5B
BC D7 D9 5B
10029 F86DFF AE 51 7A FC 66 .DB $AE,$51,$7A,$FC,$66,$0D,$B0,$04,$40
0D B0 04 40
10030 ; MP[5] = -1.716772506388927649032068540558788106762E3
10031 F86E08 44 3A 92 A3 59 .DB $44,$3A,$92,$A3,$59,$97,$98,$46,$5F
97 98 46 5F
10032 F86E11 A6 8C 51 5F B8 .DB $A6,$8C,$51,$5F,$B8,$98,$D6,$09,$C0
98 D6 09 C0
10033 ; MP[4] = 4.578962475841642634225390068461943438441E4
10034 F86E1A C3 21 E0 44 63 .DB $C3,$21,$E0,$44,$63,$32,$45,$02,$AF
32 45 02 AF
10035 F86E23 73 E6 2A F0 9F .DB $73,$E6,$2A,$F0,$9F,$DD,$B2,$0E,$40
DD B2 0E 40
10036 ; MP[3] = -7.212432713558031519943281748462837065308E5
10037 F86E2C 12 EA 50 4A 6C .DB $12,$EA,$50,$4A,$6C,$00,$52,$CF,$E1
00 52 CF E1
10038 F86E35 C1 2E 79 57 B4 .DB $C1,$2E,$79,$57,$B4,$15,$B0,$12,$C0
15 B0 12 C0
10039 ; MP[2] = 8.944630806357575461578107295909719817253E6
10040 F86E3E 20 48 52 E0 BA .DB $20,$48,$52,$E0,$BA,$5E,$BC,$44,$7D
5E BC 44 7D
10041 F86E47 37 73 6D CE F6 .DB $37,$73,$6D,$CE,$F6,$7B,$88,$16,$40
7B 88 16 40
10042 ; MP[1] = -5.722847283900608941516165725053359168840E7
10043 F86E50 7C BD E1 4B F3 .DB $7C,$BD,$E1,$4B,$F3,$59,$CC,$B5,$CB
59 CC B5 CB
10044 F86E59 98 46 B2 35 2E .DB $98,$46,$B2,$35,$2E,$4F,$DA,$18,$C0
4F DA 18 C0
10045 ; MP[0] = 2.943520915569954073888921213330863757240E8
10046 F86E62 12 F3 2E 3D 05 .DB $12,$F3,$2E,$3D,$05,$16,$56,$0F,$16
16 56 0F 16
10047 F86E6B 02 BA 74 DC A6 .DB $02,$BA,$74,$DC,$A6,$5B,$8C,$1B,$40
5B 8C 1B 40
10048
10049 F86E74 cem1q:
10050 ; MQ[7] = -8.802340681794263968892934703309274564037E1
10051 F86E74 5B 7E 65 0F E1 .DB $5B,$7E,$65,$0F,$E1,$0C,$75,$92,$24
0C 75 92 24
10052 F86E7D 56 22 7B FA FB .DB $56,$22,$7B,$FA,$FB,$0B,$B0,$05,$C0
0B B0 05 C0
10053 ; MQ[6] = 3.697714952261803935521187272204485251835E3
10054 F86E86 FE 14 1F B8 5A .DB $FE,$14,$1F,$B8,$5A,$2E,$44,$50,$D9
2E 44 50 D9
10055 F86E8F 62 6A C8 71 70 .DB $62,$6A,$C8,$71,$70,$1B,$E7,$0A,$40
1B E7 0A 40
10056 ; MQ[5] = -9.615511549171441430850103489315371768998E4
10057 F86E98 D6 13 D7 2D 65 .DB $D6,$13,$D7,$2D,$65,$3A,$0E,$9C,$28
3A 0E 9C 28
10058 F86EA1 2F B8 6E C8 8E .DB $2F,$B8,$6E,$C8,$8E,$CD,$BB,$0F,$C0
CD BB 0F C0
10059 ; MQ[4] = 1.682912729190313538934190635536631941751E6
10060 F86EAA 02 77 B9 68 7D .DB $02,$77,$B9,$68,$7D,$29,$95,$7B,$AD
29 95 7B AD
10061 F86EB3 29 BB 61 D5 05 .DB $29,$BB,$61,$D5,$05,$6F,$CD,$13,$40
Tue Jul 17 11:00:18 2018 Page 134
6F CD 13 40
10062 ; MQ[3] = -2.019684072836541751428967854947019415698E7
10063 F86EBC CB B8 14 C8 CF .DB $CB,$B8,$14,$C8,$CF,$E5,$F5,$70,$E1
E5 F5 70 E1
10064 F86EC5 F7 13 3B 5D F4 .DB $F7,$13,$3B,$5D,$F4,$16,$9A,$17,$C0
16 9A 17 C0
10065 ; MQ[2] = 1.615869009634292424463780387327037251069E8
10066 F86ECE 1C 14 94 07 23 .DB $1C,$14,$94,$07,$23,$62,$73,$13,$05
62 73 13 05
10067 F86ED7 C8 34 6A 4F ED .DB $C8,$34,$6A,$4F,$ED,$19,$9A,$1A,$40
19 9A 1A 40
10068 ; MQ[1] = -7.848989743695296475743081255027098295771E8
10069 F86EE0 DC 5E 0D 28 3F .DB $DC,$5E,$0D,$28,$3F,$32,$AD,$EF,$DC
32 AD EF DC
10070 F86EE9 FA 65 7A 79 6E .DB $FA,$65,$7A,$79,$6E,$22,$BB,$1C,$C0
22 BB 1C C0
10071 ; MQ[0] = 1.766112549341972444333352727998584753865E9
10072 F86EF2 D0 35 67 DC 07 .DB $D0,$35,$67,$DC,$07,$21,$01,$17,$21
21 01 17 21
10073 F86EFB 03 17 AF 4A 7A .DB $03,$17,$AF,$4A,$7A,$89,$D2,$1D,$40
89 D2 1D 40
10074
10075 ; maxln = 11356.523406294143949491931077970764
10076 ; above this value, exp(x) overflow
10077 F86F04 00 80 F2 03 98 maxln: .DB $00,$80,$F2,$03,$98,$B3,$E3,$C9,$AB
B3 E3 C9 AB
10078 F86F0D 79 CF D1 F7 17 .DB $79,$CF,$D1,$F7,$17,$72,$B1,$0C,$40
72 B1 0C 40
10079
10080 ; minln = -1.143276959615573793352782661133116431383730e4
10081 ; below this value, exp(x) underflow
10082 F86F16 45 C0 39 B1 F4 minln: .DB $45,$C0,$39,$B1,$F4,$B2,$26,$E9,$44
B2 26 E9 44
10083 F86F1F 16 C0 03 11 14 .DB $16,$C0,$03,$11,$14,$A3,$B2,$0C,$C0
A3 B2 0C C0
10084
10085 ; min. argument for expm1() -- below this value expm1() = -1
10086 ; mxm1 = loge(2^-114) = -7.9018778583833765273564461846232128760607E1
10087 F86F28 00 80 84 63 F3 mxm1: .DB $00,$80,$84,$63,$F3,$CB,$CE,$FF,$5C
CB CE FF 5C
10088 F86F31 C8 DC B6 58 9D .DB $C8,$DC,$B6,$58,$9D,$09,$9E,$05,$C0
09 9E 05 C0
10089
10090 ; e = 2.7182818284590452353602874713526623 (35 digits)
10091 F86F3A 00 00 3D 27 20 ceul: .DB $00,$00,$3D,$27,$20,$56,$DC,$AF,$9A
56 DC AF 9A
10092 F86F43 4A BB A2 58 54 .DB $4A,$BB,$A2,$58,$54,$F8,$AD,$00,$40
F8 AD 00 40
10093
10094 ; coefficients for exp10() evaluation
10095 F86F4C ce10p:
10096 ; P[5] = 6.781965388610215141646963666801877147888E1
10097 F86F4C 45 E4 3F 51 CF .DB $45,$E4,$3F,$51,$CF,$31,$82,$DB,$82
31 82 DB 82
10098 F86F55 33 B2 95 AC A9 .DB $33,$B2,$95,$AC,$A9,$A3,$87,$05,$40
A3 87 05 40
10099 ; P[4] = 4.930988843306627886355612005613845141123E4
Tue Jul 17 11:00:18 2018 Page 135
10100 F86F5E D5 25 84 99 5A .DB $D5,$25,$84,$99,$5A,$EB,$62,$D1,$4B
EB 62 D1 4B
10101 F86F67 5A 74 59 70 E3 .DB $5A,$74,$59,$70,$E3,$9D,$C0,$0E,$40
9D C0 0E 40
10102 ; P[3] = 9.112966716416345527154611203937593471620E6
10103 F86F70 36 62 7E 7C 7A .DB $36,$62,$7E,$7C,$7A,$40,$20,$E5,$5B
40 20 E5 5B
10104 F86F79 C6 0F 67 B7 86 .DB $C6,$0F,$67,$B7,$86,$0D,$8B,$16,$40
0D 8B 16 40
10105 ; P[2] = 5.880306836049276068401249115246879608067E8
10106 F86F82 2E 0E F8 F9 5C .DB $2E,$0E,$F8,$F9,$5C,$1D,$B4,$4D,$7F
1D B4 4D 7F
10107 F86F8B 24 72 6B 6E 8B .DB $24,$72,$6B,$6E,$8B,$32,$8C,$1C,$40
32 8C 1C 40
10108 ; P[1] = 1.294143447497151402129871056524193102276E10
10109 F86F94 63 CA AF 6C 10 .DB $63,$CA,$AF,$6C,$10,$94,$56,$45,$25
94 56 45 25
10110 F86F9D 49 2D BE 9A A7 .DB $49,$2D,$BE,$9A,$A7,$D7,$C0,$20,$40
D7 C0 20 40
10111 ; P[0] = 6.737236378815985929063482575381049393067E10
10112 F86FA6 DC 96 E7 F7 15 .DB $DC,$96,$E7,$F7,$15,$39,$D0,$93,$9D
39 D0 93 9D
10113 F86FAF C8 8E C2 00 4B .DB $C8,$8E,$C2,$00,$4B,$FB,$FA,$22,$40
FB FA 22 40
10114
10115 F86FB8 ce10q:
10116 ; Q[5] = 2.269602544366008200564158516293459788943E3
10117 F86FB8 58 5C 11 75 0B .DB $58,$5C,$11,$75,$0B,$63,$2E,$D1,$F3
63 2E D1 F3
10118 F86FC1 4E A6 8F 05 A4 .DB $4E,$A6,$8F,$05,$A4,$D9,$8D,$0A,$40
D9 8D 0A 40
10119 ; Q[4] = 7.712352920905011963059413773034169405418E5
10120 F86FCA 18 FC B0 15 D1 .DB $18,$FC,$B0,$15,$D1,$8B,$DA,$20,$C4
8B DA 20 C4
10121 F86FD3 E1 16 67 AC 34 .DB $E1,$16,$67,$AC,$34,$4A,$BC,$12,$40
4A BC 12 40
10122 ; Q[3] = 8.312829542416079818945631366865677745737E7
10123 F86FDC 22 3B 86 E2 A1 .DB $22,$3B,$86,$E2,$A1,$37,$CF,$01,$8F
37 CF 01 8F
10124 F86FE5 AA B9 92 ED FC .DB $AA,$B9,$92,$ED,$FC,$8D,$9E,$19,$40
8D 9E 19 40
10125 ; Q[2] = 3.192530874297321568824835872165913128965E9
10126 F86FEE 58 36 A6 B4 D3 .DB $58,$36,$A6,$B4,$D3,$61,$82,$7F,$2E
61 82 7F 2E
10127 F86FF7 44 1D 4C BA 27 .DB $44,$1D,$4C,$BA,$27,$4A,$BE,$1E,$40
4A BE 1E 40
10128 ; Q[1] = 3.709588725051672862074295071447979432510E10
10129 F87000 D8 CE E2 0B 30 .DB $D8,$CE,$E2,$0B,$30,$77,$F8,$EF,$3A
77 F8 EF 3A
10130 F87009 85 44 28 19 65 .DB $85,$44,$28,$19,$65,$31,$8A,$22,$40
31 8A 22 40
10131 ; Q[0] = 5.851889165195258152098281616369230806944E10
10132 F87012 58 7C 65 00 31 .DB $58,$7C,$65,$00,$31,$77,$52,$F6,$1E
77 52 F6 1E
10133 F8701B C6 3D 3F C8 F6 .DB $C6,$3D,$3F,$C8,$F6,$FF,$D9,$22,$40
FF D9 22 40
10134
Tue Jul 17 11:00:18 2018 Page 136
10135 ; log10(2) = lg102a + lg102b = 3.0102999566398119521373889e-1
10136 ; lg102a = 3.01025390625e-1
10137 F87024 00 00 00 00 00 lg102a: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
10138 F8702D 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$20,$9A,$FD,$3F
20 9A FD 3F
10139 ; lg102b = 4.6050389811952137388947244930267681898814621E-6
10140 F87036 AC 26 78 91 7C lg102b: .DB $AC,$26,$78,$91,$7C,$0B,$AC,$59,$89
0B AC 59 89
10141 F8703F 8F 98 F7 CF FB .DB $8F,$98,$F7,$CF,$FB,$84,$9A,$ED,$3F
84 9A ED 3F
10142
10143 ; log2(10) = 3.321928094887362347870319429489390175864831
10144 F87048 4C DB AF 4D FF lg210: .DB $4C,$DB,$AF,$4D,$FF,$F6,$2B,$49,$FE
F6 2B 49 FE
10145 F87051 8A 1B CD 4B 78 .DB $8A,$1B,$CD,$4B,$78,$9A,$D4,$00,$40
9A D4 00 40
10146
10147 ; maxl10 = 4.9320754489586679023818980511660936429E3
10148 F8705A 00 80 7C 0B AC maxl10: .DB $00,$80,$7C,$0B,$AC,$59,$89,$8F,$98
59 89 8F 98
10149 F87063 F7 CF FB 84 9A .DB $F7,$CF,$FB,$84,$9A,$20,$9A,$0B,$40
20 9A 0B 40
10150 ; minl10 = -4.932075448958667902381898051166093750570023E3
10151 F8706C 77 91 7C 0B AC minl10: .DB $77,$91,$7C,$0B,$AC,$59,$89,$8F,$98
59 89 8F 98
10152 F87075 F7 CF FB 84 9A .DB $F7,$CF,$FB,$84,$9A,$20,$9A,$0B,$C0
20 9A 0B C0
10153
10154 ; coefficients for exp2() evaluation
10155 F8707E ce2p:
10156 ; P[4] = 1.587171580015525194694938306936721666031E2
10157 F8707E 72 92 38 9A 50 .DB $72,$92,$38,$9A,$50,$06,$08,$65,$04
06 08 65 04
10158 F87087 98 BB B2 AA 97 .DB $98,$BB,$B2,$AA,$97,$B7,$9E,$06,$40
B7 9E 06 40
10159 ; P[3] = 6.185032670011643762127954396427045467506E5
10160 F87090 D2 BC B4 93 EB .DB $D2,$BC,$B4,$93,$EB,$21,$7F,$08,$D6
21 7F 08 D6
10161 F87099 4F 03 A3 45 74 .DB $4F,$03,$A3,$45,$74,$00,$97,$12,$40
00 97 12 40
10162 ; P[2] = 5.677513871931844661829755443994214173883E8
10163 F870A2 42 4D E3 47 3D .DB $42,$4D,$E3,$47,$3D,$36,$86,$67,$11
36 86 67 11
10164 F870AB 26 D2 C5 6C CB .DB $26,$D2,$C5,$6C,$CB,$5C,$87,$1C,$40
5C 87 1C 40
10165 ; P[1] = 1.530625323728429161131811299626419117557E11
10166 F870B4 7D 20 45 D0 EE .DB $7D,$20,$45,$D0,$EE,$9C,$89,$CD,$66
9C 89 CD 66
10167 F870BD 25 5F 53 94 F3 .DB $25,$5F,$53,$94,$F3,$8C,$8E,$24,$40
8C 8E 24 40
10168 ; P[0] = 9.079594442980146270952372234833529694788E12
10169 F870C6 FF EB 3C 5D 44 .DB $FF,$EB,$3C,$5D,$44,$B2,$CC,$35,$20
B2 CC 35 20
10170 F870CF 57 42 0E 06 20 .DB $57,$42,$0E,$06,$20,$20,$84,$2A,$40
20 84 2A 40
10171
Tue Jul 17 11:00:18 2018 Page 137
10172 F870D8 ce2q:
10173 ; Q[4] = 1.236602014442099053716561665053645270207E4
10174 F870D8 5F 7D C4 10 CE .DB $5F,$7D,$C4,$10,$CE,$91,$ED,$64,$A4
91 ED 64 A4
10175 F870E1 67 35 BD A0 14 .DB $67,$35,$BD,$A0,$14,$38,$C1,$0C,$40
38 C1 0C 40
10176 ; Q[3] = 2.186249607051644894762167991800811827835E7
10177 F870EA 15 9B 5C BC E3 .DB $15,$9B,$5C,$BC,$E3,$D1,$FC,$B0,$07
D1 FC B0 07
10178 F870F3 D9 AE 06 09 30 .DB $D9,$AE,$06,$09,$30,$CC,$A6,$17,$40
CC A6 17 40
10179 ; Q[2] = 1.092141473886177435056423606755843616331E10
10180 F870FC C8 3E E7 04 F9 .DB $C8,$3E,$E7,$04,$F9,$42,$1F,$0D,$9B
42 1F 0D 9B
10181 F87105 4F 27 B7 14 E4 .DB $4F,$27,$B7,$14,$E4,$BD,$A2,$20,$40
BD A2 20 40
10182 ; Q[1] = 1.490560994263653042761789432690793026977E12
10183 F8710E 64 87 EE 32 85 .DB $64,$87,$EE,$32,$85,$37,$63,$BC,$E7
37 63 BC E7
10184 F87117 96 D3 EB E5 2D .DB $96,$D3,$EB,$E5,$2D,$86,$AD,$27,$40
86 AD 27 40
10185 ; Q[0] = 2.619817175234089411411070339065679229869E13
10186 F87120 68 99 1A 49 CE .DB $68,$99,$1A,$49,$CE,$E7,$82,$4C,$25
E7 82 4C 25
10187 F87129 27 A7 BC C4 E5 .DB $27,$A7,$BC,$C4,$E5,$9D,$BE,$2B,$40
9D BE 2B 40
10188
10189 ; maxl2 = 16384
10190 F87132 00 00 00 00 00 maxl2: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
10191 F8713B 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$80,$0D,$40
00 80 0D 40
10192 ; minl2 = -16494
10193 F87144 00 00 00 00 00 minl2: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
10194 F8714D 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$DC,$80,$0D,$C0
DC 80 0D C0
10195
10196
10197 ;---------------------------------------------------------------------------
10198 ; circular functions & inverse circular functions
10199 ;---------------------------------------------------------------------------
10200
10201 ; fcos - returns the circular cosine of the radian argument x
10202 ;
10203 ; entry:
10204 ; fac = x (|x| < 2^56)
10205 ;
10206 ; exit:
10207 ; fac = cos(x)
10208 ; CF = 1 if invalid result (nan, if x is too large)
10209 ;
10210 ; computation mean time: 70ms at 4MHz
10211 ;
10212 ;----
10213 F87156 fcos:
10214 ;----
Tue Jul 17 11:00:18 2018 Page 138
10215 F87156 64 CF stz fpcsgn ; positive sign
10216 F87158 64 24 stz facsgn ; make argument positive
10217 F8715A 20 05 72 jsr modpi4 ; reduce argument: z = x - k*(pi/4)
10218 F8715D A5 CE lda fpoct ; octant
10219 F8715F C9 04 cmp #4
10220 F87161 90 0A bcc ?ok ; no change
10221 F87163 AA tax
10222 F87164 A5 CF lda fpcsgn ; invert sign
10223 F87166 49 FF eor #$FF
10224 F87168 85 CF sta fpcsgn
10225 F8716A 8A txa
10226 F8716B E9 04 sbc #4 ; reflect in x axis
10227 F8716D C9 02 ?ok: cmp #2
10228 F8716F 90 0A bcc ?ok2
10229 F87171 AA tax
10230 F87172 A5 CF lda fpcsgn ; invert sign
10231 F87174 49 FF eor #$FF
10232 F87176 85 CF sta fpcsgn
10233 F87178 8A txa
10234 F87179 C9 02 cmp #2
10235 F8717B F0 04 ?ok2: beq ?s0 ; octant = 2
10236 F8717D C9 01 cmp #1
10237 F8717F D0 05 bne ?s1
10238 F87181 20 C0 71 ?s0: jsr sinz ; 1 & 2nd octant: sinz
10239 F87184 80 2E bra sincos
10240 F87186 20 DB 71 ?s1: jsr cosz ; 0 & 3nd octant: cosz
10241 F87189 80 29 bra sincos
10242
10243 ; fsin - returns the circular sine of the radian argument x
10244 ;
10245 ; entry:
10246 ; fac = x (|x| < 2^56)
10247 ;
10248 ; exit:
10249 ; fac = sin(x)
10250 ; CF = 1 if invalid result (nan, if x is too large)
10251 ;
10252 ; computation mean time: 70ms at 4MHz
10253 ;
10254 ;----
10255 F8718B fsin:
10256 ;----
10257 F8718B A5 24 lda facsgn ; save sign...
10258 F8718D 85 CF sta fpcsgn
10259 F8718F 64 24 stz facsgn ; ...and make argument positive
10260 F87191 20 05 72 jsr modpi4 ; reduce argument: z = x - k*(pi/4)
10261 F87194 A5 CE lda fpoct ; octant
10262 F87196 C9 04 cmp #4
10263 F87198 90 0A bcc ?ok ; no change
10264 F8719A AA tax
10265 F8719B A5 CF lda fpcsgn ; invert sign
10266 F8719D 49 FF eor #$FF
10267 F8719F 85 CF sta fpcsgn
10268 F871A1 8A txa
10269 F871A2 E9 04 sbc #4 ; reflect in x axis
10270 F871A4 C9 01 ?ok: cmp #1
10271 F871A6 F0 04 beq ?s0
Tue Jul 17 11:00:18 2018 Page 139
10272 F871A8 C9 02 cmp #2
10273 F871AA D0 05 bne ?s1
10274 F871AC 20 DB 71 ?s0: jsr cosz ; 1 & 2nd octant: cosz
10275 F871AF 80 03 bra sincos
10276 F871B1 20 C0 71 ?s1: jsr sinz ; 0 & 3nd octant: sinz
10277
10278 F871B4 sincos:
10279 F871B4 24 CF bit fpcsgn
10280 F871B6 10 06 bpl ?end
10281 F871B8 A5 24 lda facsgn ; sign inversion
10282 F871BA 49 FF eor #$FF
10283 F871BC 85 24 sta facsgn
10284 F871BE 18 ?end: clc
10285 F871BF 60 rts
10286
10287 ; sinz - evaluates the sine of the reduced argument
10288 ;
10289 ; 3 2
10290 ; sin(z) = z + z * P(z )
10291 ;
10292 ;----
10293 F871C0 sinz:
10294 ;----
10295 F871C0 A9 AD lda #<psin
10296 F871C2 A0 75 ldy #>psin
10297 F871C4 A2 0B ldx #11
10298 F871C6 20 1C 87 jsr peval ; fac=P(z*z)
10299 F871C9 20 CE 85 jsr mvt0_a ; z*z
10300 F871CC 20 DD 49 jsr fpmult
10301 F871CF 20 FB 85 jsr mvt1_a ; z
10302 F871D2 20 DD 49 jsr fpmult ; (z^3) * P(z*z)
10303 F871D5 20 FB 85 jsr mvt1_a ; z
10304 F871D8 4C 7D 45 jmp fpadd ; z + (z^3) * P(z*z)
10305
10306 ; cosz - evaluates cosine of reduced argument
10307 ;
10308 ; 1 2 4 2
10309 ; cos(z) = 1 - --- * z + z * P(z )
10310 ; 2
10311 ;
10312 ;----
10313 F871DB cosz:
10314 ;----
10315 F871DB A9 85 lda #<pcos
10316 F871DD A0 76 ldy #>pcos
10317 F871DF A2 0A ldx #10
10318 F871E1 20 1C 87 jsr peval ; fac=P(z*z)
10319 F871E4 20 CE 85 jsr mvt0_a ; z*z
10320 F871E7 20 DD 49 jsr fpmult
10321 F871EA 20 CE 85 jsr mvt0_a ; z*z
10322 F871ED 20 DD 49 jsr fpmult
10323 F871F0 20 6C 45 jsr faddone ; 1 + (z^4) * P(z*z)
10324 F871F3 20 39 84 jsr mvftoa ; move to arg
10325 F871F6 20 47 85 jsr mvt0_f ; z*z
10326 F871F9 A9 FF lda #$FF
10327 F871FB 85 46 sta scexp
10328 F871FD 85 47 sta scexp+1
Tue Jul 17 11:00:18 2018 Page 140
10329 F871FF 20 B7 48 jsr fscale ; z*z/2
10330 F87202 4C 5F 45 jmp fpsub ; 1 - (z*z/2) + (z^4) * P(z*z)
10331
10332 ; modpi4 - argument reduction modulo pi/4
10333 ;
10334 ; entry:
10335 ; fac = x
10336 ;
10337 ; exit:
10338 ; tfr1 = z, reduced argument in interval [0, pi/4]
10339 ; fac = tfr0 = z*z
10340 ; fpoct = octant modulo 360 degrees (0..7)
10341 ;
10342 ; If argument is invalid this function return CF=1 and skip the
10343 ; return address.
10344 ;
10345 ; If |x| >= 2^56 the reduction fail due to a large precision loss
10346 ; computing the modulo pi/4 of the argument (returns nan)
10347 ;
10348 ; The reduction error is nearly eliminated by contriving an extended
10349 ; precision modular arithmetic
10350 ;
10351 ;------
10352 F87205 modpi4:
10353 ;------
10354 F87205 24 25 bit facst
10355 F87207 30 0B bmi ?er ; fac=nan or inf
10356 F87209 ACC16
10357 F87209 C2 20 rep #PMFLAG
10358 .LONGA on
10359 .MNLIST
10360 F8720B A5 22 lda facexp
10361 F8720D C9 37 40 cmp #BIAS56 ; compare vs. 2^56
10362 F87210 ACC08
10363 F87210 E2 20 sep #PMFLAG
10364 .LONGA off
10365 .MNLIST
10366 F87212 90 0B bcc ?ok ; if too large returns nan
10367 F87214 20 74 4E ?er: jsr fldnan
10368 F87217 A5 CF lda fpcsgn
10369 F87219 85 24 sta facsgn
10370 F8721B 68 pla ; skip return address
10371 F8721C 68 pla
10372 F8721D 38 sec
10373 F8721E 60 rts
10374 F8721F 20 93 84 ?ok: jsr mvf_t1 ; tfr1=x
10375 F87222 A9 81 lda #<cpio4
10376 F87224 A0 77 ldy #>cpio4
10377 F87226 20 0A 4A jsr fcrdiv ; y=x/(pi/4)
10378 F87229 20 27 50 jsr floor ; integral part
10379 F8722C 20 78 4F jsr uitrunc ; convert to integer in tm
10380 ; just 8 bit value we need here
10381 F8722F A5 00 lda tm ; map zeros to origin
10382 F87231 4A lsr a
10383 F87232 90 05 bcc ?no
10384 F87234 E6 00 inc tm
10385 F87236 20 6C 45 jsr faddone ; y=y+1
Tue Jul 17 11:00:18 2018 Page 141
10386 F87239 A5 00 ?no: lda tm
10387 F8723B 29 07 and #$07 ; octant modulo 360 degrees...
10388 F8723D 85 CE sta fpoct ; ...for tests on the phase angle
10389 F8723F 20 C0 84 jsr mvf_t2 ; tfr2=y
10390 F87242
10391 ; computes z = x - y*(pi/4) with extended precision modular arithmetic
10392 F87242 A9 4B lda #<cdp1
10393 F87244 A0 77 ldy #>cdp1
10394 F87246 20 D5 49 jsr fcmult ; y*cdp1
10395 F87249 20 FB 85 jsr mvt1_a ; arg=x
10396 F8724C 20 5F 45 jsr fpsub ; x=x-y*cdp1
10397 F8724F 20 93 84 jsr mvf_t1 ; tfr1=x
10398 F87252 20 A1 85 jsr mvt2_f ; fac=y
10399 F87255 A9 5D lda #<cdp2
10400 F87257 A0 77 ldy #>cdp2
10401 F87259 20 D5 49 jsr fcmult ; y*cdp2
10402 F8725C 20 FB 85 jsr mvt1_a ; arg=x
10403 F8725F 20 5F 45 jsr fpsub ; x=x-y*cdp1-y*cdp2
10404 F87262 20 93 84 jsr mvf_t1 ; tfr1=x
10405 F87265 20 A1 85 jsr mvt2_f ; fac=y
10406 F87268 A9 6F lda #<cdp3
10407 F8726A A0 77 ldy #>cdp3
10408 F8726C 20 D5 49 jsr fcmult ; y*cdp3
10409 F8726F 20 FB 85 jsr mvt1_a ; arg=x
10410 F87272 20 5F 45 jsr fpsub ; z=x-y*cdp3-y*cdp2-y*cdp1
10411 F87275 20 93 84 jsr mvf_t1 ; tfr1=z=x-k*(pi/4)
10412 F87278 20 CC 49 jsr fsquare ; z*z
10413 F8727B 4C 66 84 jmp mvf_t0 ; tfr0=z*z
10414
10415 ; ftan - returns the circular tangent of the radian argument x
10416 ;
10417 ; entry:
10418 ; fac = x
10419 ;
10420 ; exit:
10421 ; fac = tan(x)
10422 ; CF = 1 if invalid result (nan or inf)
10423 ;
10424 ; strategy
10425 ;
10426 ; Range reduction is modulo pi/4. A rational function
10427 ; x + x^3 P(x^2)/Q(x^2)
10428 ; is employed in the basic interval [0, pi/4].
10429 ;
10430 ; computation mean time: 70/80ms at 4MHz
10431 ;
10432 ;----
10433 F8727E ftan:
10434 ;----
10435 F8727E A9 00 lda #0
10436 F87280 20 A0 72 jsr tancot ; computes tan(x)
10437 F87283 B0 03 bcs ?end ; returns nan
10438 F87285 10 01 bpl ?end ; returns finite value (CF=0)
10439 F87287 38 sec
10440 F87288 60 ?end: rts
10441
10442 ; fcotan - returns the circular cotangent of the radian argument x
Tue Jul 17 11:00:18 2018 Page 142
10443 ;
10444 ; entry:
10445 ; fac = x
10446 ;
10447 ; exit:
10448 ; fac = cotan(x)
10449 ; CF = 1 if invalid result (nan or inf)
10450 ;
10451 ; strategy
10452 ;
10453 ; Range reduction is modulo pi/4. A rational function
10454 ; x + x^3 P(x^2)/Q(x^2)
10455 ; is employed in the basic interval [0, pi/4].
10456 ;
10457 ; computation mean time: 70/80ms at 4MHz
10458 ;
10459 ;------
10460 F87289 fcotan:
10461 ;------
10462 F87289 24 25 bit facst
10463 F8728B 30 0D bmi ?nan
10464 F8728D 70 0E bvs ?inf ; x = 0
10465 F8728F A9 FF lda #$FF
10466 F87291 20 A0 72 jsr tancot ; computes cotan(x)
10467 F87294 B0 03 bcs ?end ; return nan
10468 F87296 10 01 bpl ?end ; returns finite value (CF=0)
10469 F87298 38 sec
10470 F87299 60 ?end: rts
10471 F8729A 4C 74 4E ?nan: jmp fldnan ; returns nan
10472 F8729D 4C 7D 4E ?inf: jmp fldinf ; returns inf
10473 F872A0
10474 ; tancot - common routine used computing tan(x) & cotan(x)
10475 ;
10476 ; entry:
10477 ; fac = x
10478 ; A = cotangent flag
10479 ;
10480 ; exit:
10481 ; fac = tan(x) or cotan(x)
10482 ; CF = 1 if returns nan
10483 ; NF = 1 if returns inf
10484 ;
10485 ;------
10486 F872A0 tancot:
10487 ;------
10488 F872A0 85 D0 sta fpcot ; cotangent flag
10489 F872A2 A5 24 lda facsgn ; save sign...
10490 F872A4 85 CF sta fpcsgn
10491 F872A6 64 24 stz facsgn ; ...and make argument positive
10492 F872A8 20 05 72 jsr modpi4 ; argument reduction: z = x - k*(pi/4)
10493 ; fac=tfr0=z*z=w
10494 F872AB A9 DB lda #<ptan
10495 F872AD A0 77 ldy #>ptan
10496 F872AF A2 05 ldx #5
10497 F872B1 20 1C 87 jsr peval ; evaluate P(w)
10498 F872B4 20 CE 85 jsr mvt0_a
10499 F872B7 20 DD 49 jsr fpmult ; w*P(w)
Tue Jul 17 11:00:18 2018 Page 143
10500 F872BA 20 C0 84 jsr mvf_t2 ; tfr2=w*P(w)
10501 F872BD A9 47 lda #<qtan
10502 F872BF A0 78 ldy #>qtan
10503 F872C1 A2 05 ldx #5
10504 F872C3 20 3A 87 jsr pevalp1 ; evaluate Q(w)
10505 F872C6 20 28 86 jsr mvt2_a ; arg=w*P(w)
10506 F872C9 20 10 4A jsr fpdiv ; w*P(w)/Q(w)
10507 F872CC 20 FB 85 jsr mvt1_a ; arg=z
10508 F872CF 20 DD 49 jsr fpmult ; z*w*R(w)
10509 F872D2 20 FB 85 jsr mvt1_a ; arg=z
10510 F872D5 20 7D 45 jsr fpadd ; z + z*w*R(w)
10511 F872D8 A5 CE ?done: lda fpoct ; octant
10512 F872DA 29 02 and #$02
10513 F872DC F0 0C beq ?cot
10514 F872DE A5 24 lda facsgn
10515 F872E0 49 FF eor #$FF
10516 F872E2 85 24 sta facsgn ; sign inversion
10517 F872E4 24 D0 bit fpcot
10518 F872E6 30 09 bmi ?end ; cotan(x)
10519 F872E8 80 04 bra ?rec ; tan(x)
10520 F872EA 24 D0 ?cot: bit fpcot
10521 F872EC 10 03 bpl ?end ; tan(x)
10522 F872EE 20 FD 49 ?rec: jsr frecip
10523 F872F1 24 CF ?end: bit fpcsgn
10524 F872F3 10 06 bpl ?end2
10525 F872F5 A5 24 lda facsgn ; sign inversion
10526 F872F7 49 FF eor #$FF
10527 F872F9 85 24 sta facsgn
10528 F872FB 18 ?end2: clc
10529 F872FC 24 25 bit facst ; return N=1 if invalid
10530 F872FE 60 rts
10531
10532 ; fasin - inverse circular sine: returns radian angle
10533 ; between -pi/2 and +pi/2 whose sine is x
10534 ;
10535 ; entry:
10536 ; fac = x
10537 ;
10538 ; exit:
10539 ; fac = asin(x) in domain [-p1/2,+pi/2]
10540 ; CF = 1 if returns nan (|x| > 1)
10541 ;
10542 ; strategy
10543 ;
10544 ; A rational function of the form x + x^3 P(x^2)/Q(x^2)
10545 ; is used for |x| in the interval [0, 0.5]. If |x| > 0.5 it is
10546 ; transformed by the identity
10547 ;
10548 ; asin(x) = pi/2 - 2*asin(sqrt((1-x)/2))
10549 ;
10550 ; computation mean time: 100/130ms at 4MHz
10551 ;
10552 ;-----
10553 F872FF fasin:
10554 ;-----
10555 F872FF 24 25 bit facst
10556 F87301 30 1C bmi ?nan ; if argument is invalid return nan
Tue Jul 17 11:00:18 2018 Page 144
10557 F87303 70 18 bvs ?ok ; if x=0 return 0
10558 F87305 20 24 74 jsr cmpx1 ; compare |x| vs. 1
10559 F87308 B0 15 bcs ?nan ; if |x|>1 return nan
10560 F8730A 08 php
10561 F8730B A5 24 lda facsgn
10562 F8730D 85 CF sta fpcsgn ; save sign(x)
10563 F8730F 28 plp
10564 F87310 D0 10 bne ?do ; |x|<1
10565 F87312 A9 93 lda #<cpio2 ; |x|=1 so return sgn(x)*pi/2
10566 F87314 A0 77 ldy #>cpio2
10567 F87316 20 82 86 jsr ldfac ; x=pi/2
10568 F87319 A5 CF lda fpcsgn
10569 F8731B 85 24 sta facsgn
10570 F8731D 18 ?ok: clc
10571 F8731E 60 rts
10572 F8731F 4C 74 4E ?nan: jmp fldnan
10573 F87322 64 24 ?do: stz facsgn ; |x|
10574 F87324 64 D0 stz fpasin ; asin flag
10575 F87326 20 1B 74 jsr cmpxh ; compare |x| vs. 0.5
10576 F87329 B0 08 bcs ?gt ; |x|>0.5
10577 F8732B 20 93 84 jsr mvf_t1 ; tfr1=z=|x|
10578 F8732E 20 CC 49 jsr fsquare ; w=z*z
10579 F87331 80 22 bra ?pp
10580 F87333 A9 FF ?gt: lda #$FF
10581 F87335 85 D0 sta fpasin ; |x| > 0.5 flag
10582 F87337 20 9F 4E jsr ldahalf ; arg=0.5
10583 F8733A 20 5F 45 jsr fpsub ; w=0.5-|x|
10584 F8733D 20 67 45 jsr faddhalf ; w=1-|x|
10585 F87340 A9 FF lda #$FF
10586 F87342 85 46 sta scexp
10587 F87344 85 47 sta scexp+1 ; divive dy 2
10588 F87346 20 B7 48 jsr fscale ; w=0.5*(1-|x|)
10589 F87349 20 C0 84 jsr mvf_t2 ; tfr2=w
10590 F8734C 20 53 60 jsr fsqrt ; z=sqrt(w)
10591 F8734F 20 93 84 jsr mvf_t1 ; tfr1=z
10592 F87352 20 A1 85 jsr mvt2_f ; fac=w
10593 F87355 20 66 84 ?pp: jsr mvf_t0 ; tfr0=w
10594 F87358 A9 B3 lda #<casp
10595 F8735A A0 78 ldy #>casp
10596 F8735C A2 09 ldx #9
10597 F8735E 20 1C 87 jsr peval ; P(w)
10598 F87361 20 CE 85 jsr mvt0_a ; w
10599 F87364 20 DD 49 jsr fpmult ; w*P(w)
10600 F87367 20 C0 84 jsr mvf_t2 ; tfr2=w*P(w)
10601 F8736A A9 67 lda #<casq
10602 F8736C A0 79 ldy #>casq
10603 F8736E A2 09 ldx #9
10604 F87370 20 3A 87 jsr pevalp1 ; Q(w)
10605 F87373 20 28 86 jsr mvt2_a ; arg=w*P(w)
10606 F87376 20 10 4A jsr fpdiv ; w*P(w)/Q(w)=w*R(w)
10607 F87379 20 FB 85 jsr mvt1_a ; arg=z
10608 F8737C 20 DD 49 jsr fpmult ; z*w*R(w)
10609 F8737F 20 FB 85 jsr mvt1_a ; arg=z
10610 F87382 20 7D 45 jsr fpadd ; y=z+z*w*R(w)
10611 F87385 24 D0 bit fpasin
10612 F87387 10 10 bpl ?done ; |x| <= 0.5
10613 F87389 20 39 84 jsr mvftoa
Tue Jul 17 11:00:18 2018 Page 145
10614 F8738C 20 7D 45 jsr fpadd ; y+y
10615 F8738F A9 93 lda #<cpio2
10616 F87391 A0 77 ldy #>cpio2
10617 F87393 20 CF 86 jsr ldarg ; arg=pi/2
10618 F87396 20 5F 45 jsr fpsub ; pi/2-2*asin(z)
10619 F87399 24 CF ?done: bit fpcsgn
10620 F8739B 10 06 bpl ?end
10621 F8739D A5 24 lda facsgn ; sign inversion
10622 F8739F 49 FF eor #$FF
10623 F873A1 85 24 sta facsgn
10624 F873A3 18 ?end: clc
10625 F873A4 60 rts
10626
10627 ; facos - inverse circular cosine: returns radian angle
10628 ; between 0 and +pi whose cosine is x
10629 ;
10630 ; entry:
10631 ; fac = x
10632 ;
10633 ; exit:
10634 ; fac = acos(x) in domain [0,pi]
10635 ; CF = 1 if returns nan (|x| > 1)
10636 ;
10637 ; strategy
10638 ;
10639 ; Analytically, acos(x) = pi/2 - asin(x). However if |x| is
10640 ; near 1, there is cancellation error in subtracting asin(x)
10641 ; from pi/2. Hence if x < -0.5,
10642 ;
10643 ; acos(x) = pi - 2.0 * asin(sqrt((1+x)/2))
10644 ;
10645 ; or if x > +0.5,
10646 ;
10647 ; acos(x) = 2.0 * asin(sqrt((1-x)/2))
10648 ;
10649 ; computation mean time: 100/140ms at 4MHz
10650 ;
10651 ;-----
10652 F873A5 facos:
10653 ;-----
10654 F873A5 24 25 bit facst
10655 F873A7 30 21 bmi ?nan ; if argument is invalid return nan
10656 F873A9 70 22 bvs ?pi2 ; if x=0 return pi/2
10657 F873AB 20 24 74 jsr cmpx1 ; compare |x| vs. 1
10658 F873AE B0 1A bcs ?nan ; if |x|>1 return nan
10659 F873B0 08 php
10660 F873B1 A5 24 lda facsgn
10661 F873B3 85 CF sta fpcsgn ; save sign(x)
10662 F873B5 28 plp
10663 F873B6 D0 20 bne ?do ; |x|<1
10664 F873B8 64 24 stz facsgn ; |x|=1
10665 F873BA 24 CF bit fpcsgn
10666 F873BC 10 09 bpl ?z ; x=1 so return 0
10667 F873BE A9 A5 lda #<cpi ; x=-1 so return pi
10668 F873C0 A0 77 ldy #>cpi
10669 F873C2 20 82 86 jsr ldfac ; x=pi
10670 F873C5 18 clc
Tue Jul 17 11:00:18 2018 Page 146
10671 F873C6 60 rts
10672 F873C7 4C 56 4E ?z: jmp fldz
10673 F873CA 4C 74 4E ?nan: jmp fldnan
10674 F873CD A9 93 ?pi2: lda #<cpio2 ; |x|=0 so return pi/2
10675 F873CF A0 77 ldy #>cpio2
10676 F873D1 20 82 86 jsr ldfac ; x=pi/2
10677 F873D4 64 24 stz facsgn
10678 F873D6 18 ?ok: clc
10679 F873D7 60 rts
10680 F873D8 20 1B 74 ?do: jsr cmpxh ; compare |x| vs. 0.5
10681 F873DB B0 0D bcs ?gt ; |x|>0.5
10682 F873DD 20 FF 72 jsr fasin ; |x|<=0.5
10683 F873E0 A9 93 lda #<cpio2
10684 F873E2 A0 77 ldy #>cpio2
10685 F873E4 20 CF 86 jsr ldarg ; arg=pi/2
10686 F873E7 4C 5F 45 jmp fpsub ; pi/2-asin(x) if |x|<=0.5
10687 F873EA A5 CF ?gt: lda fpcsgn
10688 F873EC 30 04 bmi ?neg
10689 F873EE A2 FF ldx #$FF
10690 F873F0 86 24 stx facsgn ; x<-0.5 or x>0.5
10691 F873F2 48 ?neg: pha ; save sign
10692 F873F3 20 6C 45 jsr faddone ; y=1+x or y=1-x
10693 F873F6 A9 FF lda #$FF
10694 F873F8 85 46 sta scexp
10695 F873FA 85 47 sta scexp+1
10696 F873FC 20 B7 48 jsr fscale ; divide by 2
10697 F873FF 20 53 60 jsr fsqrt ; w=sqrt(y/2)
10698 F87402 20 FF 72 jsr fasin
10699 F87405 A9 01 lda #1
10700 F87407 85 46 sta scexp
10701 F87409 64 47 stz scexp+1
10702 F8740B 20 B7 48 jsr fscale ; multiplies by 2
10703 F8740E 68 pla ; original sign
10704 F8740F 10 C5 bpl ?ok ; done: acos(x)=2*asin(w)
10705 F87411 A9 A5 lda #<cpi
10706 F87413 A0 77 ldy #>cpi
10707 F87415 20 CF 86 jsr ldarg ; arg=pi
10708 F87418 4C 5F 45 jmp fpsub ; acos(x)=pi-2*asin(w)
10709 F8741B
10710
10711 ; compare |x| vs. 0.5 - flag's affected
10712 ;
10713 ; CF=0, ZF=0 if |x| < 0.5
10714 ; CF=0, ZF=1 if |x| = 0.5
10715 ; CF=1, ZF=0 if |x| > 0.5
10716 F8741B cmpxh:
10717 F8741B ACC16
10718 F8741B C2 20 rep #PMFLAG
10719 .LONGA on
10720 .MNLIST
10721 F8741D A5 22 lda facexp
10722 F8741F C9 FE 3F cmp #EBIAS-1
10723 F87422 80 07 bra cmpx1h
10724 F87424
10725 ; compare |x| vs. 1 - flag's affected
10726 ;
10727 ; CF=0, ZF=0 if |x| < 1
Tue Jul 17 11:00:18 2018 Page 147
10728 ; CF=0, ZF=1 if |x| = 1
10729 ; CF=1, ZF=0 if |x| > 1
10730 F87424 cmpx1:
10731 F87424 ACC16
10732 F87424 C2 20 rep #PMFLAG
10733 .LONGA on
10734 .MNLIST
10735 F87426 A5 22 lda facexp
10736 F87428 C9 FF 3F cmp #EBIAS
10737 F8742B cmpx1h:
10738 F8742B 90 1C bcc ?done ; |x|<1, CF=0, ZF=0
10739 F8742D F0 02 beq ?tst
10740 F8742F B0 18 bcs ?done ; |x|>1, CF=1, ZF=0
10741 F87431 A5 20 ?tst: lda facm+14 ; should be $8000
10742 F87433 C9 00 80 cmp #$8000 ; here always CF=1
10743 F87436 D0 11 bne ?done ; |x|>1, CF=1, ZF=0
10744 F87438 A5 1E lda facm+12
10745 F8743A 05 1C ora facm+10
10746 F8743C 05 1A ora facm+8
10747 F8743E 05 18 ora facm+6
10748 F87440 05 16 ora facm+4
10749 F87442 05 14 ora facm+2
10750 F87444 05 12 ora facm
10751 F87446 D0 01 bne ?done ; |x|>1, CF=1, ZF=0
10752 F87448 18 clc ; |x|=1, CF=0, ZF=1
10753 F87449 ?done: ACC08
10754 F87449 E2 20 sep #PMFLAG
10755 .LONGA off
10756 .MNLIST
10757 F8744B 60 rts
10758
10759 ; fatan - inverse circular tangent, returns radian angle
10760 ; between -pi/2 and +pi/2 whose tangent is x
10761 ;
10762 ; entry:
10763 ; fac = x
10764 ;
10765 ; exit:
10766 ; fac = atan(x) in domain [-pi/2,pi/2]
10767 ; CF = 1 if returns nan
10768 ;
10769 ; strategy
10770 ;
10771 ; Range reduction is from four intervals into the interval
10772 ; from zero to tan(pi/8). The approximant uses a rational
10773 ; function of the form x + x^3 P(x)/Q(x).
10774 ;
10775 ; computation mean time: 100ms at 4MHz
10776 ;
10777 ;-----
10778 F8744C fatan:
10779 ;-----
10780 F8744C 24 25 bit facst
10781 F8744E 10 13 bpl ?fv ; valid fac
10782 F87450 50 0F bvc ?er ; fac=nan so return nan
10783 F87452 A5 24 lda facsgn
10784 F87454 48 pha
Tue Jul 17 11:00:18 2018 Page 148
10785 F87455 A9 93 lda #<cpio2
10786 F87457 A0 77 ldy #>cpio2
10787 F87459 20 82 86 jsr ldfac ; x=pi/2
10788 F8745C 68 pla
10789 F8745D 85 24 sta facsgn ; return +/-pi/2
10790 F8745F 18 ?ok: clc
10791 F87460 60 rts
10792 F87461 38 ?er: sec
10793 F87462 60 rts
10794 F87463 70 FA ?fv: bvs ?ok ; if fac=0 return 0
10795 F87465 A5 24 lda facsgn ; save sign...
10796 F87467 85 CF sta fpcsgn
10797 F87469 64 24 stz facsgn ; ...and make argument positive
10798 F8746B A9 B7 lda #<ct3p8
10799 F8746D A0 77 ldy #>ct3p8
10800 F8746F 20 5E 87 jsr fccmp ; cmpare x vs. tan(3*pi/8)
10801 F87472 10 3E bpl ?gt38 ; fac > tan(3*pi/8)
10802 F87474 A9 C9 lda #<ctp8
10803 F87476 A0 77 ldy #>ctp8
10804 F87478 20 5E 87 jsr fccmp ; cmpare x vs. tan(pi/8)
10805 F8747B 10 0B bpl ?gt8 ; fac > tan(pi/8)
10806 F8747D 20 93 84 jsr mvf_t1 ; tfr1=w=x
10807 F87480 20 56 4E jsr fldz
10808 F87483 20 C0 84 jsr mvf_t2 ; tfr2=y=0
10809 F87486 80 3E bra ?do
10810 F87488 20 66 84 ?gt8: jsr mvf_t0 ; tfr0=x
10811 F8748B 20 39 84 jsr mvftoa ; arg=x
10812 F8748E 20 32 4E jsr fldm1 ; fac=-1
10813 F87491 20 7D 45 jsr fpadd ; x-1
10814 F87494 20 93 84 jsr mvf_t1 ; tfr1=x-1
10815 F87497 20 47 85 jsr mvt0_f ; fac=x
10816 F8749A 20 6C 45 jsr faddone ; x+1
10817 F8749D 20 FB 85 jsr mvt1_a ; arg=x-1
10818 F874A0 20 10 4A jsr fpdiv ; w=(x-1)/(x+1)
10819 F874A3 20 93 84 jsr mvf_t1 ; tfr1=w
10820 F874A6 A9 81 lda #<cpio4
10821 F874A8 A0 77 ldy #>cpio4
10822 F874AA 20 82 86 jsr ldfac ; pi/4
10823 F874AD 20 C0 84 jsr mvf_t2 ; tfr2=y=pi/4
10824 F874B0 80 14 bra ?do
10825 F874B2 20 FD 49 ?gt38: jsr frecip
10826 F874B5 A9 FF lda #$FF
10827 F874B7 85 24 sta facsgn ; w=-1/x
10828 F874B9 20 93 84 jsr mvf_t1 ; tfr1=w=-1/x
10829 F874BC A9 93 lda #<cpio2
10830 F874BE A0 77 ldy #>cpio2
10831 F874C0 20 82 86 jsr ldfac ; pi/2
10832 F874C3 20 C0 84 jsr mvf_t2 ; tfr2=y=pi/2
10833 F874C6 20 74 85 ?do: jsr mvt1_f ; fac=w
10834 F874C9 20 CC 49 jsr fsquare ; z=w*w
10835 F874CC 20 66 84 jsr mvf_t0 ; tfr0=z
10836 F874CF A9 1B lda #<catp
10837 F874D1 A0 7A ldy #>catp
10838 F874D3 A2 08 ldx #8
10839 F874D5 20 1C 87 jsr peval ; P(z)
10840 F874D8 20 ED 84 jsr mvf_t3 ; tfr3=P(z)
10841 F874DB A9 BD lda #<catq
Tue Jul 17 11:00:18 2018 Page 149
10842 F874DD A0 7A ldy #>catq
10843 F874DF A2 07 ldx #7
10844 F874E1 20 3A 87 jsr pevalp1 ; Q(z)
10845 F874E4 20 55 86 jsr mvt3_a ; arg=P(z)
10846 F874E7 20 10 4A jsr fpdiv ; R(z)=P(z)/Q(z)
10847 F874EA 20 CE 85 jsr mvt0_a ; arg=z
10848 F874ED 20 DD 49 jsr fpmult ; z*R(z)
10849 F874F0 20 FB 85 jsr mvt1_a ; arg=w
10850 F874F3 20 DD 49 jsr fpmult ; z*w*R(z)
10851 F874F6 20 FB 85 jsr mvt1_a ; arg=w
10852 F874F9 20 7D 45 jsr fpadd ; w+z*w*R(z)
10853 F874FC 20 28 86 jsr mvt2_a ; arg=y
10854 F874FF 20 7D 45 jsr fpadd ; y+w+z*w*R(z)
10855 F87502 24 CF bit fpcsgn
10856 F87504 10 06 bpl ?end
10857 F87506 A5 24 lda facsgn
10858 F87508 49 FF eor #$FF
10859 F8750A 85 24 sta facsgn
10860 F8750C 18 ?end: clc
10861 F8750D 60 rts
10862
10863 ; fatanyx - inverse circular tangent, returns radian angle
10864 ; between 0 and 2*pi whose tangent is y/x (computes the phase angle)
10865 ;
10866 ; entry:
10867 ; fac = x
10868 ; arg = y
10869 ;
10870 ; exit:
10871 ; fac = z = atan(y/x) in domain [0, 2pi]
10872 ; CF = 1 if returns nan
10873 ;
10874 ; computation mean time: 100ms at 4MHz
10875 ;
10876 ;-------
10877 F8750E fatanyx:
10878 ;-------
10879 F8750E A2 00 ldx #0
10880 F87510 24 24 bit facsgn
10881 F87512 10 02 bpl ?xp ; x >= 0
10882 F87514 A2 02 ldx #2
10883 F87516 24 3C ?xp: bit argsgn
10884 F87518 10 01 bpl ?yp ; y >= 0
10885 F8751A E8 inx
10886 F8751B 86 10 ?yp: stx atncode
10887 F8751D A5 25 lda facst
10888 F8751F 29 C0 and #$C0
10889 F87521 C9 80 cmp #$80
10890 F87523 F0 10 beq ?nan ; if x=nan return nan
10891 F87525 AA tax
10892 F87526 A5 3D lda argst
10893 F87528 29 C0 and #$C0
10894 F8752A C9 80 cmp #$80
10895 F8752C F0 07 beq ?nan ; if y=nan return nan
10896 F8752E A8 tay
10897 F8752F 25 25 and facst
10898 F87531 C9 C0 cmp #$C0 ; if x=inf and y=inf return nan
Tue Jul 17 11:00:18 2018 Page 150
10899 F87533 D0 03 bne ?x0
10900 F87535 4C 74 4E ?nan: jmp fldnan
10901 F87538 E0 40 ?x0: cpx #$40
10902 F8753A D0 25 bne ?xx ; x != 0
10903 F8753C C0 40 cpy #$40 ; y = 0?
10904 F8753E F0 1E beq ?zz ; yes, return zero (x = 0, y = 0)
10905 F87540 A9 93 ?pi2: lda #<cpio2
10906 F87542 A0 77 ldy #>cpio2
10907 F87544 20 82 86 jsr ldfac ; z = pi/2
10908 F87547 46 10 lsr atncode
10909 F87549 90 31 bcc ?ret ; return z = pi/2
10910 F8754B 20 A6 4E jsr ldaone
10911 F8754E ACC16
10912 F8754E C2 20 rep #PMFLAG
10913 .LONGA on
10914 .MNLIST
10915 F87550 E6 3A inc argexp
10916 F87552 A9 00 C0 lda #$C000
10917 F87555 85 38 sta argm+14 ; arg = 3
10918 F87557 ACC08
10919 F87557 E2 20 sep #PMFLAG
10920 .LONGA off
10921 .MNLIST
10922 F87559 64 3C stz argsgn
10923 F8755B 4C DD 49 jmp fpmult ; return z = 3*pi/2
10924 F8755E 4C 56 4E ?zz: jmp fldz ; z = 0
10925 F87561 C0 40 ?xx: cpy #$40
10926 F87563 D0 19 bne ?yy ; y != 0
10927 F87565 A5 10 ?pi: lda atncode
10928 F87567 F0 F5 beq ?zz ; return z = 0
10929 F87569 A9 A5 lda #<cpi
10930 F8756B A0 77 ldy #>cpi
10931 F8756D 20 82 86 jsr ldfac ; z = pi
10932 F87570 A9 02 lda #$02
10933 F87572 24 10 bit atncode
10934 F87574 D0 06 bne ?ret ; return z = pi
10935 F87576 ACC16
10936 F87576 C2 20 rep #PMFLAG
10937 .LONGA on
10938 .MNLIST
10939 F87578 E6 22 inc facexp ; return z = 2*pi
10940 F8757A ACC08
10941 F8757A E2 20 sep #PMFLAG
10942 .LONGA off
10943 .MNLIST
10944 F8757C 18 ?ret: clc
10945 F8757D 60 rts
10946 F8757E C0 C0 ?yy: cpy #$C0
10947 F87580 F0 BE beq ?pi2 ; if y = inf, x != 0, is like x = 0
10948 F87582 E0 C0 cpx #$C0
10949 F87584 F0 DF beq ?pi ; if x = inf, y != 0, is like y = 0
10950 F87586 20 10 4A jsr fpdiv ; w = y/x (both x and y finite and not null)
10951 F87589 20 4C 74 jsr fatan ; z = atan(y/x)
10952 F8758C A5 10 lda atncode
10953 F8758E F0 EC beq ?ret ; return z = atan(y/x) (first quadrant)
10954 F87590 20 39 84 jsr mvftoa ; arg = z
10955 F87593 A9 A5 lda #<cpi
Tue Jul 17 11:00:18 2018 Page 151
10956 F87595 A0 77 ldy #>cpi
10957 F87597 20 82 86 jsr ldfac ; fac = pi
10958 F8759A A5 10 lda atncode
10959 F8759C C9 02 cmp #$02
10960 F8759E F0 0A beq ?done ; 2nd quadrant: add pi (atan < 0)
10961 F875A0 C9 03 cmp #$03
10962 F875A2 F0 06 beq ?done ; 3th quadrant: add pi (atan > 0)
10963 F875A4 ACC16
10964 F875A4 C2 20 rep #PMFLAG
10965 .LONGA on
10966 .MNLIST
10967 F875A6 E6 22 inc facexp ; 4th quadrant: add 2*pi (atan < 0)
10968 F875A8 ACC08
10969 F875A8 E2 20 sep #PMFLAG
10970 .LONGA off
10971 .MNLIST
10972 F875AA 4C 7D 45 ?done: jmp fpadd
10973 F875AD
10974
10975 ; sin(x) coefficients
10976 F875AD psin:
10977 ; PSIN[11] = 6.410290407010279602425714995528976754871E-26
10978 F875AD 35 40 EA 6E 20 .DB $35,$40,$EA,$6E,$20,$61,$06,$26,$A1
61 06 26 A1
10979 F875B6 83 C3 68 DB 0A .DB $83,$C3,$68,$DB,$0A,$B6,$9E,$AB,$3F
B6 9E AB 3F
10980
10981 ; PSIN[10] = -3.868105354403065333804959405965295962871E-23
10982 F875BF D1 C3 E7 80 C9 .DB $D1,$C3,$E7,$80,$C9,$32,$07,$3B,$A4
32 07 3B A4
10983 F875C8 87 F3 85 2F D3 .DB $87,$F3,$85,$2F,$D3,$0C,$BB,$B4,$BF
0C BB B4 BF
10984
10985 ; PSIN[09] = 1.957294039628045847156851410307133941611E-20
10986 F875D1 44 DE C1 98 E0 .DB $44,$DE,$C1,$98,$E0,$53,$C7,$8F,$BC
53 C7 8F BC
10987 F875DA E5 70 32 4D 77 .DB $E5,$70,$32,$4D,$77,$DC,$B8,$BD,$3F
DC B8 BD 3F
10988
10989 ; PSIN[08] = -8.220635246181818130416407184286068307901E-18
10990 F875E3 88 ED DD EC 5C .DB $88,$ED,$DD,$EC,$5C,$DF,$55,$07,$A1
DF 55 07 A1
10991 F875EC 85 FB E6 33 DA .DB $85,$FB,$E6,$33,$DA,$A4,$97,$C6,$BF
A4 97 C6 BF
10992
10993 ; PSIN[07] = 2.811457254345322887443598804951004537784E-15
10994 F875F5 22 B2 7C 77 2A .DB $22,$B2,$7C,$77,$2A,$20,$77,$86,$F3
20 77 86 F3
10995 F875FE A5 5A 85 81 3B .DB $A5,$5A,$85,$81,$3B,$96,$CA,$CE,$3F
96 CA CE 3F
10996
10997 ; PSIN[06] = -7.647163731819815869711749952353081768709E-13
10998 F87607 72 92 40 E9 65 .DB $72,$92,$40,$E9,$65,$9C,$A5,$43,$C1
9C A5 43 C1
10999 F87610 F3 C0 9D 39 9F .DB $F3,$C0,$9D,$39,$9F,$3F,$D7,$D6,$BF
3F D7 D6 BF
11000
Tue Jul 17 11:00:18 2018 Page 152
11001 ; PSIN[05] = 1.605904383682161459812515654720205050216E-10
11002 F87619 80 06 BE F2 47 .DB $80,$06,$BE,$F2,$47,$B3,$13,$1B,$E4
B3 13 1B E4
11003 F87622 4B 68 43 9D 30 .DB $4B,$68,$43,$9D,$30,$92,$B0,$DE,$3F
92 B0 DE 3F
11004
11005 ; PSIN[04] = -2.505210838544171877505034150892770940116E-8
11006 F8762B EC 90 66 4A 76 .DB $EC,$90,$66,$4A,$76,$79,$F7,$39,$7F
79 F7 39 7F
11007 F87634 1C 27 AA 3F 2B .DB $1C,$27,$AA,$3F,$2B,$32,$D7,$E5,$BF
32 D7 E5 BF
11008
11009 ; PSIN[03] = 2.755731922398589065255731765498970284004E-6
11010 F8763D 84 F7 94 D2 B7 .DB $84,$F7,$94,$D2,$B7,$37,$0E,$56,$7D
37 0E 56 7D
11011 F87646 9C 39 B6 2A 1D .DB $9C,$39,$B6,$2A,$1D,$EF,$B8,$EC,$3F
EF B8 EC 3F
11012
11013 ; PSIN[02] = -1.984126984126984126984126984045294307281E-4
11014 F8764F 7D F8 65 29 FE .DB $7D,$F8,$65,$29,$FE,$0C,$D0,$00,$0D
0C D0 00 0D
11015 F87658 D0 00 0D D0 00 .DB $D0,$00,$0D,$D0,$00,$0D,$D0,$F2,$BF
0D D0 F2 BF
11016
11017 ; PSIN[01] = 8.333333333333333333333333333333119885283E-3
11018 F87661 62 9A 41 88 88 .DB $62,$9A,$41,$88,$88,$88,$88,$88,$88
88 88 88 88
11019 F8766A 88 88 88 88 88 .DB $88,$88,$88,$88,$88,$88,$88,$F8,$3F
88 88 F8 3F
11020
11021 ; PSIN[00] = -1.666666666666666666666666666666666647199E-1
11022 F87673 51 A0 AA AA AA .DB $51,$A0,$AA,$AA,$AA,$AA,$AA,$AA,$AA
AA AA AA AA
11023 F8767C AA AA AA AA AA .DB $AA,$AA,$AA,$AA,$AA,$AA,$AA,$FC,$BF
AA AA FC BF
11024
11025 ; cos(x) coefficients
11026 F87685 pcos:
11027 ; PCOS[10] = 1.601961934248327059668321782499768648351E-24
11028 F87685 6F 42 59 D2 8A .DB $6F,$42,$59,$D2,$8A,$EF,$37,$CD,$48
EF 37 CD 48
11029 F8768E C3 50 58 0F 40 .DB $C3,$50,$58,$0F,$40,$E4,$F7,$AF,$3F
E4 F7 AF 3F
11030
11031 ; PCOS[09] = -8.896621117922334603659240022184527001401E-22
11032 F87697 EF E7 87 4A 0E .DB $EF,$E7,$87,$4A,$0E,$94,$D9,$B3,$11
94 D9 B3 11
11033 F876A0 C8 08 07 CC 22 .DB $C8,$08,$07,$CC,$22,$71,$86,$B9,$BF
71 86 B9 BF
11034
11035 ; PCOS[08] = 4.110317451243694098169570731967589555498E-19
11036 F876A9 94 20 CD 9C D6 .DB $94,$20,$CD,$9C,$D6,$21,$68,$81,$A8
21 68 81 A8
11037 F876B2 E7 86 A7 75 5C .DB $E7,$86,$A7,$75,$5C,$A1,$F2,$C1,$3F
A1 F2 C1 3F
11038
11039 ; PCOS[07] = -1.561920696747074515985647487260202922160E-16
Tue Jul 17 11:00:18 2018 Page 153
11040 F876BB 4C 88 FF 5A 9D .DB $4C,$88,$FF,$5A,$9D,$63,$B8,$94,$13
63 B8 94 13
11041 F876C4 54 B0 94 1D C3 .DB $54,$B0,$94,$1D,$C3,$13,$B4,$CA,$BF
13 B4 CA BF
11042
11043 ; PCOS[06] = 4.779477332386900932514186378501779328195E-14
11044 F876CD 2B 3C A9 FD E8 .DB $2B,$3C,$A9,$FD,$E8,$BA,$6D,$B7,$80
BA 6D B7 80
11045 F876D6 FC A8 9D 39 9F .DB $FC,$A8,$9D,$39,$9F,$3F,$D7,$D2,$3F
3F D7 D2 3F
11046
11047 ; PCOS[05] = -1.147074559772972328629102981460088437917E-11
11048 F876DF C1 7C 8A 0F 0E .DB $C1,$7C,$8A,$0F,$0E,$46,$0C,$31,$F4
46 0C 31 F4
11049 F876E8 E1 E4 03 46 A5 .DB $E1,$E4,$03,$46,$A5,$CB,$C9,$DA,$BF
CB C9 DA BF
11050
11051 ; PCOS[04] = 2.087675698786809897637922200570559726116E-9
11052 F876F1 93 84 CC C1 FA .DB $93,$84,$CC,$C1,$FA,$D5,$F9,$BF,$A8
D5 F9 BF A8
11053 F876FA BD C4 C6 7F C7 .DB $BD,$C4,$C6,$7F,$C7,$76,$8F,$E2,$3F
76 8F E2 3F
11054
11055 ; PCOS[03] = -2.755731922398589065255365968070684102298E-7
11056 F87703 0E 2B 2E FA 29 .DB $0E,$2B,$2E,$FA,$29,$A2,$AE,$77,$97
A2 AE 77 97
11057 F8770C E3 FA C4 BB 7D .DB $E3,$FA,$C4,$BB,$7D,$F2,$93,$E9,$BF
F2 93 E9 BF
11058
11059 ; PCOS[02] = 2.480158730158730158730158440896461945271E-5
11060 F87715 69 8F 86 22 AB .DB $69,$8F,$86,$22,$AB,$EF,$CF,$00,$0D
EF CF 00 0D
11061 F8771E D0 00 0D D0 00 .DB $D0,$00,$0D,$D0,$00,$0D,$D0,$EF,$3F
0D D0 EF 3F
11062
11063 ; PCOS[01] = -1.388888888888888888888888888765724370132E-3
11064 F87727 C8 EC 07 B7 5B .DB $C8,$EC,$07,$B7,$5B,$0B,$B6,$60,$0B
0B B6 60 0B
11065 F87730 B6 60 0B B6 60 .DB $B6,$60,$0B,$B6,$60,$0B,$B6,$F5,$BF
0B B6 F5 BF
11066
11067 ; PCOS[00] = 4.166666666666666666666666666666459301466E-2
11068 F87739 F7 64 FE A9 AA .DB $F7,$64,$FE,$A9,$AA,$AA,$AA,$AA,$AA
AA AA AA AA
11069 F87742 AA AA AA AA AA .DB $AA,$AA,$AA,$AA,$AA,$AA,$AA,$FA,$3F
AA AA FA 3F
11070
11071 ; DP1 + DP2 + DP3 = PI/4
11072 ; DP1 = 7.853981633974483067550664827649598009884357452392578125E-1
11073 F8774B 00 00 00 00 00 cdp1: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
11074 F87754 C2 68 21 A2 DA .DB $C2,$68,$21,$A2,$DA,$0F,$C9,$FE,$3F
0F C9 FE 3F
11075
11076 ; DP2 = 2.8605943630549158983813312792950660807511260829685741796657E-18
11077 F8775D 00 00 00 00 00 cdp2: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
Tue Jul 17 11:00:18 2018 Page 154
11078 F87766 70 03 2E 8A 19 .DB $70,$03,$2E,$8A,$19,$13,$D3,$C4,$3F
13 D3 C4 3F
11079
11080 ; DP3 = 2.1679525325309452561992610065108379921905808E-35
11081 F8776F 00 00 32 F5 5D cdp3: .DB $00,$00,$32,$F5,$5D,$10,$A0,$63,$3E
10 A0 63 3E
11082 F87778 53 44 70 12 48 .DB $53,$44,$70,$12,$48,$89,$E6,$8B,$3F
89 E6 8B 3F
11083
11084 ; PI/4 = 0.7853981633974483096156608458198757210492923
11085 F87781 D1 1C DC 80 8B cpio4: .DB $D1,$1C,$DC,$80,$8B,$62,$C6,$C4,$34
62 C6 C4 34
11086 F8778A C2 68 21 A2 DA .DB $C2,$68,$21,$A2,$DA,$0F,$C9,$FE,$3F
0F C9 FE 3F
11087
11088 ; PI/2
11089 F87793 D1 1C DC 80 8B cpio2: .DB $D1,$1C,$DC,$80,$8B,$62,$C6,$C4,$34
62 C6 C4 34
11090 F8779C C2 68 21 A2 DA .DB $C2,$68,$21,$A2,$DA,$0F,$C9,$FF,$3F
0F C9 FF 3F
11091
11092 ; PI
11093 F877A5 D1 1C DC 80 8B cpi: .DB $D1,$1C,$DC,$80,$8B,$62,$C6,$C4,$34
62 C6 C4 34
11094 F877AE C2 68 21 A2 DA .DB $C2,$68,$21,$A2,$DA,$0F,$C9,$00,$40
0F C9 00 40
11095
11096 ; tan(3*pi/8) = sqrt(2)+1
11097 F877B7 4F 5F A5 BA D9 ct3p8: .DB $4F,$5F,$A5,$BA,$D9,$C4,$BE,$2C,$42
C4 BE 2C 42
11098 F877C0 32 EF FC 99 79 .DB $32,$EF,$FC,$99,$79,$82,$9A,$00,$40
82 9A 00 40
11099 F877C9
11100 ; tan(pi/8) = sqrt(2)-1
11101 F877C9 7C FA 2A D5 CD ctp8: .DB $7C,$FA,$2A,$D5,$CD,$26,$F6,$65,$11
26 F6 65 11
11102 F877D2 92 79 E7 CF CC .DB $92,$79,$E7,$CF,$CC,$13,$D4,$FD,$3F
13 D4 FD 3F
11103
11104
11105 ; tan(x) coefficients
11106 F877DB ptan:
11107 ; TP[5] = -9.889929415807650724957118893791829849557E-1
11108 F877DB 58 BB A5 17 15 .DB $58,$BB,$A5,$17,$15,$D7,$E3,$C6,$CB
D7 E3 C6 CB
11109 F877E4 04 71 10 34 A4 .DB $04,$71,$10,$34,$A4,$2E,$FD,$FE,$BF
2E FD FE BF
11110
11111 ; TP[4] = 1.272297782199996882828849455156962260810E3
11112 F877ED D1 56 CC 23 3E .DB $D1,$56,$CC,$23,$3E,$E5,$D8,$0B,$50
E5 D8 0B 50
11113 F877F6 29 4A 89 6E 87 .DB $29,$4A,$89,$6E,$87,$09,$9F,$09,$40
09 9F 09 40
11114
11115 ; TP[3] = -4.249691853501233575668486667664718192660E5
11116 F877FF 94 A5 29 9E C5 .DB $94,$A5,$29,$9E,$C5,$9C,$0D,$8B,$2B
9C 0D 8B 2B
Tue Jul 17 11:00:18 2018 Page 155
11117 F87808 C4 61 63 EE 25 .DB $C4,$61,$63,$EE,$25,$81,$CF,$11,$C0
81 CF 11 C0
11118
11119 ; TP[2] = 5.160188250214037865511600561074819366815E7
11120 F87811 B4 52 C1 B5 30 .DB $B4,$52,$C1,$B5,$30,$D3,$30,$C9,$14
D3 30 C9 14
11121 F8781A 66 11 23 A0 76 .DB $66,$11,$23,$A0,$76,$D8,$C4,$18,$40
D8 C4 18 40
11122
11123 ; TP[1] = -2.307030822693734879744223131873392503321E9
11124 F87823 55 27 82 DF 66 .DB $55,$27,$82,$DF,$66,$F2,$8E,$98,$EC
F2 8E 98 EC
11125 F8782C 9B 98 B1 26 7F .DB $9B,$98,$B1,$26,$7F,$82,$89,$1E,$C0
82 89 1E C0
11126
11127 ; TP[0] = 2.883414728874239697964612246732416606301E10
11128 F87835 16 C6 4C C5 B1 .DB $16,$C6,$4C,$C5,$B1,$35,$56,$87,$4F
35 56 87 4F
11129 F8783E B7 C1 17 7B C5 .DB $B7,$C1,$17,$7B,$C5,$D4,$D6,$21,$40
D4 D6 21 40
11130
11131 F87847 qtan:
11132 ; TQ[5] = -1.317243702830553658702531997959756728291E3
11133 F87847 FA D3 81 DD E9 .DB $FA,$D3,$81,$DD,$E9,$7B,$94,$EB,$80
7B 94 EB 80
11134 F87850 75 E5 E0 69 CC .DB $75,$E5,$E0,$69,$CC,$A7,$A4,$09,$C0
A7 A4 09 C0
11135
11136 ; TQ[4] = 4.529422062441341616231663543669583527923E5
11137 F87859 E6 99 66 53 23 .DB $E6,$99,$66,$53,$23,$56,$5A,$89,$E9
56 5A 89 E9
11138 F87862 66 4C 8D 99 C6 .DB $66,$4C,$8D,$99,$C6,$29,$DD,$11,$40
29 DD 11 40
11139
11140 ; TQ[3] = -5.733709132766856723608447733926138506824E7
11141 F8786B 69 45 D0 B9 5E .DB $69,$45,$D0,$B9,$5E,$77,$B9,$31,$0D
77 B9 31 0D
11142 F87874 95 85 F8 D4 40 .DB $95,$85,$F8,$D4,$40,$B9,$DA,$18,$C0
B9 DA 18 C0
11143
11144 ; TQ[2] = 2.758476078803232151774723646710890525496E9
11145 F8787D 25 48 F2 7D A4 .DB $25,$48,$F2,$7D,$A4,$71,$D8,$F7,$4E
71 D8 F7 4E
11146 F87886 9F A0 CD 2E 01 .DB $9F,$A0,$CD,$2E,$01,$6B,$A4,$1E,$40
6B A4 1E 40
11147
11148 ; TQ[1] = -4.152206921457208101480801635640958361612E10
11149 F8788F 45 68 68 C0 AA .DB $45,$68,$68,$C0,$AA,$ED,$34,$14,$6C
ED 34 14 6C
11150 F87898 3E 27 E9 ED 87 .DB $3E,$27,$E9,$ED,$87,$AE,$9A,$22,$C0
AE 9A 22 C0
11151
11152 ; TQ[0] = 8.650244186622719093893836740197250197602E10
11153 F878A1 30 B9 F9 53 45 .DB $30,$B9,$F9,$53,$45,$A8,$80,$A5,$7B
A8 80 A5 7B
11154 F878AA 49 D1 51 1C 94 .DB $49,$D1,$51,$1C,$94,$1F,$A1,$23,$40
1F A1 23 40
Tue Jul 17 11:00:18 2018 Page 156
11155
11156 ; asin(x) coefficients
11157 F878B3 casp:
11158 ; ASP[9] = -8.067112765482705313585175280952515549833E-1
11159 F878B3 73 27 C0 8D 2C .DB $73,$27,$C0,$8D,$2C,$37,$96,$A8,$04
37 96 A8 04
11160 F878BC 05 D8 16 56 A1 .DB $05,$D8,$16,$56,$A1,$84,$CE,$FE,$BF
84 CE FE BF
11161
11162 ; ASP[8] = 4.845649797786849136525020822000172350977E1
11163 F878C5 10 4E 72 84 A0 .DB $10,$4E,$72,$84,$A0,$F4,$1C,$1D,$A9
F4 1C 1D A9
11164 F878CE 8C 8A B6 34 74 .DB $8C,$8A,$B6,$34,$74,$D3,$C1,$04,$40
D3 C1 04 40
11165
11166 ; ASP[7] = -8.510195404865297879959793548843395926847E2
11167 F878D7 EB 4D 4D 8F C3 .DB $EB,$4D,$4D,$8F,$C3,$B1,$24,$A9,$BD
B1 24 A9 BD
11168 F878E0 F9 A5 BD 26 40 .DB $F9,$A5,$BD,$26,$40,$C1,$D4,$08,$C0
C1 D4 08 C0
11169
11170 ; ASP[6] = 6.815196841370292688574521445731895826485E3
11171 F878E9 AA 5E 2D 43 AA .DB $AA,$5E,$2D,$43,$AA,$66,$ED,$0A,$61
66 ED 0A 61
11172 F878F2 41 7F 91 21 93 .DB $41,$7F,$91,$21,$93,$F9,$D4,$0B,$40
F9 D4 0B 40
11173
11174 ; ASP[5] = -2.967135182120339728996157454994675519735E4
11175 F878FB F2 CA 89 AC E2 .DB $F2,$CA,$89,$AC,$E2,$B3,$AC,$51,$EE
B3 AC 51 EE
11176 F87904 42 A5 E8 21 B4 .DB $42,$A5,$E8,$21,$B4,$CE,$E7,$0D,$C0
CE E7 0D C0
11177
11178 ; ASP[4] = 7.612250656518818109652985996692466409670E4
11179 F8790D 4D 89 09 49 F6 .DB $4D,$89,$09,$49,$F6,$5B,$21,$9C,$D3
5B 21 9C D3
11180 F87916 43 CA 20 D7 40 .DB $43,$CA,$20,$D7,$40,$AD,$94,$0F,$40
AD 94 0F 40
11181
11182 ; ASP[3] = -1.183360579752620455689557157684221905030E5
11183 F8791F C8 84 21 34 4B .DB $C8,$84,$21,$34,$4B,$51,$AB,$59,$3B
51 AB 59 3B
11184 F87928 3B BF BB 6B 07 .DB $3B,$BF,$BB,$6B,$07,$20,$E7,$0F,$C0
20 E7 0F C0
11185
11186 ; ASP[2] = 1.095432262510413338755837156377401348063E5
11187 F87931 5C D5 0E A4 53 .DB $5C,$D5,$0E,$A4,$53,$03,$23,$26,$83
03 23 26 83
11188 F8793A 9B 4B CB F5 9C .DB $9B,$4B,$CB,$F5,$9C,$F3,$D5,$0F,$40
F3 D5 0F 40
11189
11190 ; ASP[1] = -5.554124580991113991999636773382495788705E4
11191 F87943 A8 77 07 20 6B .DB $A8,$77,$07,$20,$6B,$5E,$DE,$66,$ED
5E DE 66 ED
11192 F8794C 60 F9 65 ED 3E .DB $60,$F9,$65,$ED,$3E,$F5,$D8,$0E,$C0
F5 D8 0E C0
11193
Tue Jul 17 11:00:18 2018 Page 157
11194 ; ASP[0] = 1.187132626694762543537732514905488896985E4
11195 F87955 14 17 24 62 E1 .DB $14,$17,$24,$62,$E1,$9B,$9A,$F9,$98
9B 9A F9 98
11196 F8795E 44 37 EC 18 4E .DB $44,$37,$EC,$18,$4E,$7D,$B9,$0C,$40
7D B9 0C 40
11197
11198 F87967 casq:
11199 ; ASQ[9] = -8.005471061732009595694099899234272342478E1
11200 F87967 AB CB 99 42 E0 .DB $AB,$CB,$99,$42,$E0,$53,$D9,$98,$3E
53 D9 98 3E
11201 F87970 7F 44 B0 07 03 .DB $7F,$44,$B0,$07,$03,$1C,$A0,$05,$C0
1C A0 05 C0
11202
11203 ; ASQ[8] = 1.817324228942812880965069608562483918025E3
11204 F87979 74 B0 9D 55 FC .DB $74,$B0,$9D,$55,$FC,$EE,$98,$24,$09
EE 98 24 09
11205 F87982 89 39 60 15 60 .DB $89,$39,$60,$15,$60,$2A,$E3,$09,$40
2A E3 09 40
11206
11207 ; ASQ[7] = -1.867017317425756524289537002141956583706E4
11208 F8798B CA 11 F0 E5 FC .DB $CA,$11,$F0,$E5,$FC,$8D,$72,$C6,$EB
8D 72 C6 EB
11209 F87994 80 D9 4B AA 58 .DB $80,$D9,$4B,$AA,$58,$DC,$91,$0D,$C0
DC 91 0D C0
11210
11211 ; ASQ[6] = 1.048196619402464497478959760337779705622E5
11212 F8799D EA F9 4B 5E 82 .DB $EA,$F9,$4B,$5E,$82,$00,$4C,$57,$34
00 4C 57 34
11213 F879A6 34 3F 75 BA D4 .DB $34,$3F,$75,$BA,$D4,$B9,$CC,$0F,$40
B9 CC 0F 40
11214
11215 ; ASQ[5] = -3.527040897897253459022458866536165564103E5
11216 F879AF 9E F0 E3 86 B9 .DB $9E,$F0,$E3,$86,$B9,$BB,$11,$41,$14
BB 11 41 14
11217 F879B8 BC B3 8E DF 02 .DB $BC,$B3,$8E,$DF,$02,$38,$AC,$11,$C0
38 AC 11 C0
11218
11219 ; ASQ[4] = 7.426302422018858001691440351763370029242E5
11220 F879C1 72 C6 78 BF 89 .DB $72,$C6,$78,$BF,$89,$F9,$2E,$F9,$A8
F9 2E F9 A8
11221 F879CA A8 15 0F E0 63 .DB $A8,$15,$0F,$E0,$63,$4E,$B5,$12,$40
4E B5 12 40
11222
11223 ; ASQ[3] = -9.863068411558756277454631976667880674474E5
11224 F879D3 FF 38 2A 9B 42 .DB $FF,$38,$2A,$9B,$42,$07,$BF,$F1,$8C
07 BF F1 8C
11225 F879DC 0A DD 5F 75 2D .DB $0A,$DD,$5F,$75,$2D,$CC,$F0,$12,$C0
CC F0 12 C0
11226
11227 ; ASQ[2] = 8.025654653926121907774766642393757364326E5
11228 F879E5 C1 3C 5A DF 8E .DB $C1,$3C,$5A,$DF,$8E,$AF,$32,$E7,$8C
AF 32 E7 8C
11229 F879EE 12 86 3F 72 57 .DB $12,$86,$3F,$72,$57,$F0,$C3,$12,$40
F0 C3 12 40
11230
11231 ; ASQ[1] = -3.653000557802254281954969843055623398839E5
11232 F879F7 CA 1B 43 FC 90 .DB $CA,$1B,$43,$FC,$90,$05,$03,$8F,$48
Tue Jul 17 11:00:18 2018 Page 158
05 03 8F 48
11233 F87A00 7F 9C F3 C8 81 .DB $7F,$9C,$F3,$C8,$81,$5E,$B2,$11,$C0
5E B2 11 C0
11234
11235 ; ASQ[0] = 7.122795760168575261226395089432959614179E4
11236 F87A09 93 75 A5 09 E9 .DB $93,$75,$A5,$09,$E9,$F4,$33,$BB,$72
F4 33 BB 72
11237 F87A12 73 29 B1 92 FA .DB $73,$29,$B1,$92,$FA,$1D,$8B,$0F,$40
1D 8B 0F 40
11238
11239 ; atan(x) coefficients
11240 F87A1B catp:
11241 ; ATP[08] = -6.635810778635296712545011270011752799963E-4
11242 F87A1B F1 6B 5F 23 D7 .DB $F1,$6B,$5F,$23,$D7,$8E,$2D,$08,$F8
8E 2D 08 F8
11243 F87A24 79 13 55 1C 2C .DB $79,$13,$55,$1C,$2C,$F4,$AD,$F4,$BF
F4 AD F4 BF
11244
11245 ; ATP[07] = -8.768423468036849091777415076702113400070E-1
11246 F87A2D 0C 62 A5 C3 8A .DB $0C,$62,$A5,$C3,$8A,$2F,$F9,$15,$4D
2F F9 15 4D
11247 F87A36 29 0C 45 73 BD .DB $29,$0C,$45,$73,$BD,$78,$E0,$FE,$BF
78 E0 FE BF
11248
11249 ; ATP[06] = -2.548067867495502632615671450650071218995E1
11250 F87A3F EA FC 2D 13 27 .DB $EA,$FC,$2D,$13,$27,$8A,$73,$51,$2A
8A 73 51 2A
11251 F87A48 18 88 A6 0F 6E .DB $18,$88,$A6,$0F,$6E,$D8,$CB,$03,$C0
D8 CB 03 C0
11252
11253 ; ATP[05] = -2.497759878476618348858065206895055957104E2
11254 F87A51 F8 A0 32 CF E6 .DB $F8,$A0,$32,$CF,$E6,$62,$5C,$EB,$0C
62 5C EB 0C
11255 F87A5A 0F CD BB 23 A7 .DB $0F,$CD,$BB,$23,$A7,$C6,$F9,$06,$C0
C6 F9 06 C0
11256
11257 ; ATP[04] = -1.148164399808514330375280133523543970854E3
11258 F87A63 F0 5F EE 9D 20 .DB $F0,$5F,$EE,$9D,$20,$0D,$F2,$58,$EE
0D F2 58 EE
11259 F87A6C 34 21 63 C3 42 .DB $34,$21,$63,$C3,$42,$85,$8F,$09,$C0
85 8F 09 C0
11260
11261 ; ATP[03] = -2.792272753241044941703278827346430350236E3
11262 F87A75 9A CD A1 B3 A8 .DB $9A,$CD,$A1,$B3,$A8,$AB,$A8,$87,$0E
AB A8 87 0E
11263 F87A7E A8 A2 80 32 5D .DB $A8,$A2,$80,$32,$5D,$84,$AE,$0A,$C0
84 AE 0A C0
11264
11265 ; ATP[02] = -3.696264445691821235400930243493001671932E3
11266 F87A87 76 73 C3 5C DA .DB $76,$73,$C3,$5C,$DA,$FA,$F9,$C5,$78
FA F9 C5 78
11267 F87A90 0B DF 67 2B 3B .DB $0B,$DF,$67,$2B,$3B,$04,$E7,$0A,$C0
04 E7 0A C0
11268
11269 ; ATP[01] = -2.514829758941713674909996882101723647996E3
11270 F87A99 FF 23 4B CB 5F .DB $FF,$23,$4B,$CB,$5F,$46,$30,$6F,$B3
46 30 6F B3
Tue Jul 17 11:00:18 2018 Page 159
11271 F87AA2 94 E3 4F B1 46 .DB $94,$E3,$4F,$B1,$46,$2D,$9D,$0A,$C0
2D 9D 0A C0
11272
11273 ; ATP[00] = -6.880597774405940432145577545328795037141E2
11274 F87AAB 02 27 91 66 97 .DB $02,$27,$91,$66,$97,$AB,$B4,$ED,$BB
AB B4 ED BB
11275 F87AB4 F5 18 C2 64 D3 .DB $F5,$18,$C2,$64,$D3,$03,$AC,$08,$C0
03 AC 08 C0
11276
11277 F87ABD catq:
11278 ; ATQ[07] = 3.566239794444800849656497338030115886153E1
11279 F87ABD C0 AA A1 BA 09 .DB $C0,$AA,$A1,$BA,$09,$B0,$53,$CA,$64
B0 53 CA 64
11280 F87AC6 06 5E 91 A5 4B .DB $06,$5E,$91,$A5,$4B,$A6,$8E,$04,$40
A6 8E 04 40
11281
11282 ; ATQ[06] = 4.308348370818927353321556740027020068897E2
11283 F87ACF F3 26 2F 03 B5 .DB $F3,$26,$2F,$03,$B5,$85,$60,$C3,$D8
85 60 C3 D8
11284 F87AD8 D2 1B 06 F1 DB .DB $D2,$1B,$06,$F1,$DB,$6A,$D7,$07,$40
6A D7 07 40
11285
11286 ; ATQ[05] = 2.494680540950601626662048893678584497900E3
11287 F87AE1 37 5A 94 B0 14 .DB $37,$5A,$94,$B0,$14,$01,$F9,$F5,$88
01 F9 F5 88
11288 F87AEA C3 66 E8 7E E3 .DB $C3,$66,$E8,$7E,$E3,$EA,$9B,$0A,$40
EA 9B 0A 40
11289
11290 ; ATQ[04] = 7.928572347062145288093560392463784743935E3
11291 F87AF3 E8 83 10 77 27 .DB $E8,$83,$10,$77,$27,$F7,$9C,$C9,$6A
F7 9C C9 6A
11292 F87AFC 01 4F B2 2A 94 .DB $01,$4F,$B2,$2A,$94,$C4,$F7,$0B,$40
C4 F7 0B 40
11293
11294 ; ATQ[03] = 1.458510242529987155225086911411015961174E4
11295 F87B05 F4 89 D9 F7 87 .DB $F4,$89,$D9,$F7,$87,$4A,$D8,$81,$DC
4A D8 81 DC
11296 F87B0E EC 84 2D E2 68 .DB $EC,$84,$2D,$E2,$68,$E4,$E3,$0C,$40
E4 E3 0C 40
11297
11298 ; ATQ[02] = 1.547394317752562611786521896296215170819E4
11299 F87B17 D6 33 A9 9B 41 .DB $D6,$33,$A9,$9B,$41,$D7,$06,$B7,$A6
D7 06 B7 A6
11300 F87B20 8B 4B 54 D0 C5 .DB $8B,$4B,$54,$D0,$C5,$C7,$F1,$0C,$40
C7 F1 0C 40
11301
11302 ; ATQ[01] = 8.782996876218210302516194604424986107121E3
11303 F87B29 F6 15 46 E3 7B .DB $F6,$15,$46,$E3,$7B,$EE,$EE,$EA,$5E
EE EE EA 5E
11304 F87B32 7E 8D 1E CD FC .DB $7E,$8D,$1E,$CD,$FC,$3B,$89,$0C,$40
3B 89 0C 40
11305
11306 ; ATQ[00] = 2.064179332321782129643673263598686441900E3
11307 F87B3B AD 9F 29 8D B1 .DB $AD,$9F,$29,$8D,$B1,$80,$47,$F2,$4C
80 47 F2 4C
11308 F87B44 B8 92 91 8B DE .DB $B8,$92,$91,$8B,$DE,$02,$81,$0A,$40
02 81 0A 40
Tue Jul 17 11:00:18 2018 Page 160
11309
11310 ;---------------------------------------------------------------------------
11311 ; hyperbolics functions & inverse hyperbolics functions
11312 ;---------------------------------------------------------------------------
11313
11314 ; fsinh - returns the hyperbolic sin of the argument
11315 ;
11316 ; entry:
11317 ; fac = x (argument)
11318 ;
11319 ; exit:
11320 ; fac = sinh(x)
11321 ; CF = 1 if invalid result(inf or nan)
11322 ;
11323 ; strategy x -x
11324 ; e - e
11325 ; Mathematically sinh(x) = -----------
11326 ; 2
11327 ;
11328 ; 1) if |x| <=1 sinh(x) is approximated by a rational function:
11329 ;
11330 ; 3 P(z) 2
11331 ; sinh(x) = x + x * R(z), R(z) = ------, z = x
11332 ; Q(z)
11333 ;
11334 ; E |x|
11335 ; 2) |x| > 1: sinh(x) = sgn(x)*0.5*(E + -----), E = e - 1 = expm1(|x|)
11336 ; E+1
11337 ;
11338 ; computation mean time: 65/100ms at 4MHz
11339 ;
11340 ; Note: overflow if |x| >= 11356.25
11341 ;
11342 ;-----
11343 F87B4D fsinh:
11344 ;-----
11345 F87B4D 38 sec
11346 F87B4E 24 25 bit facst
11347 F87B50 30 03 bmi ?rts ; fac=inf or inf
11348 F87B52 50 02 bvc ?nz ; if fac=0 returns zero
11349 F87B54 18 clc
11350 F87B55 60 ?rts: rts
11351 F87B56 20 24 74 ?nz: jsr cmpx1 ; compare |x| vs. 1.0
11352 F87B59 F0 2E beq rsinh ; |x|=1
11353 F87B5B 90 2C bcc rsinh ; |x|<1
11354 F87B5D A5 24 lda facsgn ; sinh(-x)=-sinh(x)
11355 F87B5F 85 CF sta fpcsgn ; save sign
11356 F87B61 64 24 stz facsgn ; |x|
11357 F87B63 20 BD 69 jsr fexpm1 ; E=exp(|x|)-1
11358 F87B66 B0 1C bcs ?done ; overflow
11359 F87B68 20 66 84 jsr mvf_t0
11360 F87B6B 20 6C 45 jsr faddone ; E+1
11361 F87B6E B0 14 bcs ?done ; overflow
11362 F87B70 20 CE 85 jsr mvt0_a ; arg=E
11363 F87B73 20 10 4A jsr fpdiv ; E/(E+1)
11364 F87B76 20 CE 85 jsr mvt0_a ; arg=E
11365 F87B79 20 7D 45 jsr fpadd ; E+E/(E+1)
Tue Jul 17 11:00:18 2018 Page 161
11366 F87B7C B0 06 bcs ?done ; overflow
11367 F87B7E ACC16 ; for sure here fac is normal
11368 F87B7E C2 20 rep #PMFLAG
11369 .LONGA on
11370 .MNLIST
11371 F87B80 C6 22 dec facexp ; divide by 2
11372 F87B82 ACC08
11373 F87B82 E2 20 sep #PMFLAG
11374 .LONGA off
11375 .MNLIST
11376 F87B84 A5 CF ?done: lda fpcsgn
11377 F87B86 85 24 sta facsgn ; set sign
11378 F87B88 60 rts
11379
11380 ; returns sinh(x) when |x|<=1 (approximated by rational function)
11381 F87B89 rsinh:
11382 F87B89 20 93 84 jsr mvf_t1 ; tfr1=x
11383 F87B8C 20 CC 49 jsr fsquare ; z=x*x
11384 F87B8F 20 66 84 jsr mvf_t0 ; tfr0=z
11385 F87B92 A9 6C lda #<cshp
11386 F87B94 A0 7E ldy #>cshp
11387 F87B96 A2 05 ldx #5
11388 F87B98 20 1C 87 jsr peval ; evaluates P(z)
11389 F87B9B 20 C0 84 jsr mvf_t2 ; tfr2=P(z)
11390 F87B9E A9 D8 lda #<cshq
11391 F87BA0 A0 7E ldy #>cshq
11392 F87BA2 A2 05 ldx #5
11393 F87BA4 20 3A 87 jsr pevalp1 ; evaluates Q(z)
11394 F87BA7 20 28 86 jsr mvt2_a ; arg=P(z)
11395 F87BAA 20 10 4A jsr fpdiv
11396 F87BAD 20 CE 85 jsr mvt0_a ; arg=z
11397 F87BB0 20 DD 49 jsr fpmult ; z*R(z)
11398 F87BB3 20 FB 85 jsr mvt1_a ; arg=x
11399 F87BB6 20 DD 49 jsr fpmult ; x*z*R(z)
11400 F87BB9 20 FB 85 jsr mvt1_a ; arg=x
11401 F87BBC 4C 7D 45 jmp fpadd ; returns sinh(x)=x + x*z*R(z)
11402
11403 ; fcosh - returns the hyperbolic cosin of the argument
11404 ;
11405 ; entry:
11406 ; fac = x (argument)
11407 ;
11408 ; exit:
11409 ; fac = cosh(x)
11410 ; CF = 1 if invalid result(inf or nan)
11411 ;
11412 ; strategy x -x
11413 ; e + e
11414 ; Mathematically cosh(x) = -----------
11415 ; 2
11416 ;
11417 ; 1) if |x| <=1 cosh(x) is approximated by a rational function
11418 ; that evaluates sinh(|x|):
11419 ;
11420 ; 3 P(z) 2
11421 ; sinh(x) = x + x * R(z), R(z) = ------, z = x
11422 ; Q(z)
Tue Jul 17 11:00:18 2018 Page 162
11423 ; 2
11424 ; then: cosh(x) = sqrt(1 + sinh(x) )
11425 ;
11426 ; 0.5 |x|
11427 ; 2) |x| > 1: cosh(x) = 0.5*E + -----, E = e = expm1(|x|) + 1
11428 ; E
11429 ;
11430 ; computation mean time: 100ms at 4MHz
11431 ;
11432 ; Note: overflow if |x| >= 11356.25
11433 ;
11434 ;-----
11435 F87BBF fcosh:
11436 ;-----
11437 F87BBF 64 24 stz facsgn ; cosh(-x) = cosh(x)
11438 F87BC1 38 sec
11439 F87BC2 24 25 bit facst
11440 F87BC4 30 05 bmi ?rts ; fac=inf or nan
11441 F87BC6 50 04 bvc ?nz ; if fac=0 returns 1
11442 F87BC8 4C 2E 4E jmp fldp1
11443 F87BCB 60 ?rts: rts
11444 F87BCC 20 24 74 ?nz: jsr cmpx1 ; compare |x| vs. 1.0
11445 F87BCF F0 02 beq ?le1 ; |x|=1
11446 F87BD1 B0 0C bcs ?gt1 ; |x|>1
11447 F87BD3 20 89 7B ?le1: jsr rsinh ; sinh(|x|)
11448 F87BD6 20 CC 49 jsr fsquare ; sinh(|x|)^2
11449 F87BD9 20 6C 45 jsr faddone ; 1+sinh(|x|)^2
11450 F87BDC 4C 53 60 jmp fsqrt ; cosh(x) = sqrt(1+sinh(|x|)^2)
11451 F87BDF 20 BD 69 ?gt1: jsr fexpm1 ; E=expm1(|x|)
11452 F87BE2 B0 E7 bcs ?rts ; overflow
11453 F87BE4 20 6C 45 jsr faddone
11454 F87BE7 B0 E2 bcs ?rts ; overflow
11455 F87BE9 20 66 84 jsr mvf_t0
11456 F87BEC 20 9F 4E jsr ldahalf
11457 F87BEF 20 10 4A jsr fpdiv ; 0.5/E
11458 F87BF2 20 CE 85 jsr mvt0_a ; arg=E
11459 F87BF5 ACC16
11460 F87BF5 C2 20 rep #PMFLAG
11461 .LONGA on
11462 .MNLIST
11463 F87BF7 C6 3A dec argexp ; E/2
11464 F87BF9 ACC08
11465 F87BF9 E2 20 sep #PMFLAG
11466 .LONGA off
11467 .MNLIST
11468 F87BFB 4C 7D 45 jmp fpadd
11469
11470 ; ftanh - returns the hyperbolic tangent of the argument
11471 ;
11472 ; entry:
11473 ; fac = x (argument)
11474 ;
11475 ; exit:
11476 ; fac = tanh(x)
11477 ; CF = 1 if invalid result(inf or nan)
11478 ;
11479 ; strategy x -x
Tue Jul 17 11:00:18 2018 Page 163
11480 ; e - e
11481 ; Mathematically cosh(x) = -----------
11482 ; x -x
11483 ; e + e
11484 ;
11485 ; strategy
11486 ;
11487 ; 1) if |x| < 0.625 tanh(x) is approximated by a rational function:
11488 ;
11489 ; 3 P(z) 2
11490 ; tanh(x) = x + x * R(z), R(z) = ------, z = x
11491 ; Q(z)
11492 ;
11493 ; 2 2|x|
11494 ; 2) |x| > 0.625: tanh(x) = 1 - -------, E = e
11495 ; E + 1
11496 ;
11497 ; computation mean time: 60/100ms at 4MHz
11498 ;
11499 ; Note: if |x| >= 40 tanh(x) = +/-1
11500 ;
11501 ;-----
11502 F87BFE ftanh:
11503 ;-----
11504 F87BFE 24 25 bit facst
11505 F87C00 10 07 bpl ?fv ; valid
11506 F87C02 50 03 bvc ?er ; fac=nan so returns nan
11507 F87C04 4C 36 4E jmp fld1 ; if fac =+/-inf returns +/-1
11508 F87C07 38 ?er: sec
11509 F87C08 60 rts
11510 F87C09 70 47 ?fv: bvs ?ok ; if fac=0 returns zero
11511 F87C0B ACC16 ; compare |x| vs. 0.625
11512 F87C0B C2 20 rep #PMFLAG
11513 .LONGA on
11514 .MNLIST
11515 F87C0D A5 22 lda facexp
11516 F87C0F C9 FE 3F cmp #$3FFE
11517 F87C12 F0 02 beq ?tst
11518 F87C14 B0 05 bcs ?cc ; |x| > 0.625
11519 F87C16 A5 20 ?tst: lda facm+14
11520 F87C18 C9 00 A0 cmp #$A000
11521 F87C1B ?cc: ACC08
11522 F87C1B E2 20 sep #PMFLAG
11523 .LONGA off
11524 .MNLIST
11525 F87C1D 90 35 bcc ?pp ; |x| < 0.625
11526 F87C1F A5 24 lda facsgn
11527 F87C21 85 CF sta fpcsgn ; save sign
11528 F87C23 64 24 stz facsgn ; |x|
11529 F87C25 ACC16
11530 F87C25 C2 20 rep #PMFLAG
11531 .LONGA on
11532 .MNLIST
11533 F87C27 A5 22 lda facexp
11534 F87C29 C9 FE 7F cmp #MAXEXP
11535 F87C2C B0 03 bcs ?cc2
11536 F87C2E 1A inc a
Tue Jul 17 11:00:18 2018 Page 164
11537 F87C2F 85 22 sta facexp
11538 F87C31 ?cc2: ACC08
11539 F87C31 E2 20 sep #PMFLAG
11540 .LONGA off
11541 .MNLIST
11542 F87C33 B0 16 bcs ?th1 ; overflow: return +1
11543 F87C35 20 6B 68 jsr fexp ; exp(|2x|)
11544 F87C38 B0 11 bcs ?th1 ; overflow
11545 F87C3A 20 6C 45 jsr faddone
11546 F87C3D 20 AD 4E jsr ldatwo ; arg=2.0
11547 F87C40 20 10 4A jsr fpdiv ; 2/(exp(|2x|)+1)
11548 F87C43 20 A6 4E jsr ldaone
11549 F87C46 20 5F 45 jsr fpsub ; 1 - 2/(exp(|2x|)+1)
11550 F87C49 80 03 bra ?done
11551 F87C4B 20 36 4E ?th1: jsr fld1 ; set fac=1
11552 F87C4E A5 CF ?done: lda fpcsgn
11553 F87C50 85 24 sta facsgn ; set sign
11554 F87C52 18 ?ok: clc
11555 F87C53 60 rts
11556 F87C54 20 93 84 ?pp: jsr mvf_t1 ; tfr1=x
11557 F87C57 20 CC 49 jsr fsquare ; z=x*x
11558 F87C5A 20 66 84 jsr mvf_t0 ; tfr0=z
11559 F87C5D A9 44 lda #<cthp
11560 F87C5F A0 7F ldy #>cthp
11561 F87C61 A2 05 ldx #5
11562 F87C63 20 1C 87 jsr peval ; evaluates P(z)
11563 F87C66 20 C0 84 jsr mvf_t2 ; tfr2=P(z)
11564 F87C69 A9 B0 lda #<cthq
11565 F87C6B A0 7F ldy #>cthq
11566 F87C6D A2 04 ldx #4
11567 F87C6F 20 3A 87 jsr pevalp1 ; evaluates Q(z)
11568 F87C72 20 28 86 jsr mvt2_a ; arg=P(z)
11569 F87C75 20 10 4A jsr fpdiv ; R(z)
11570 F87C78 20 CE 85 jsr mvt0_a ; arg=z
11571 F87C7B 20 DD 49 jsr fpmult ; z*R(z)
11572 F87C7E 20 FB 85 jsr mvt1_a ; arg=x
11573 F87C81 20 DD 49 jsr fpmult ; x*z*R(z)
11574 F87C84 20 FB 85 jsr mvt1_a ; arg=x
11575 F87C87 4C 7D 45 jmp fpadd ; returns tanh(x)=x + x*z*R(z)
11576
11577 ; fasinh - returns the inverse hyperbolic sine of the argument
11578 ;
11579 ; entry:
11580 ; fac=x
11581 ;
11582 ; exit:
11583 ; fac=asinh(x)
11584 ; CF = 1 if invalid result(inf or nan)
11585 ;
11586 ; strategy
11587 ;
11588 ; Mathematically asinh(x) = sgn(x)*ln[|x| + sqrt(x*x + 1)]
11589 ;
11590 ; 1) if |x| < 0.5 asinh(x) is approximated by a rational function:
11591 ;
11592 ; 3 P(z) 2
11593 ; asinh(x) = x + x * R(z), R(z) = ------, z = x
Tue Jul 17 11:00:18 2018 Page 165
11594 ; Q(z)
11595 ;
11596 ; 2) if |x| >= 0.5: asinh(x) = sgn(x)*ln[|x| + sqrt(x*x + 1)]
11597 ; overflow will be avoided computing x*x or |x| + sqrt(...)
11598 ; approximating asinh(x) with:
11599 ;
11600 ; asinh(x) = sgn(x)*ln(2*|x|) if x*x overflow
11601 ;
11602 ; or:
11603 ;
11604 ; asinh(x) = sgn(x)*[ln(|x|) + ln(2)] if 2*|x| overflow
11605 ;
11606 ; computation mean time: 100/150ms at 4MHz
11607 ;
11608 ;------
11609 F87C8A fasinh:
11610 ;------
11611 F87C8A 38 sec
11612 F87C8B 24 25 bit facst ; if fac=nan or fac=inf returns nan or inf
11613 F87C8D 30 03 bmi ?rts
11614 F87C8F 50 02 bvc ?fv
11615 F87C91 18 clc ; if fac=0 returns zero
11616 F87C92 60 ?rts: rts
11617 F87C93 A5 24 ?fv: lda facsgn ; asinh(-x) = -asinh(x)
11618 F87C95 85 CF sta fpcsgn ; save sign
11619 F87C97 64 24 stz facsgn ; |x|
11620 F87C99 ACC16
11621 F87C99 C2 20 rep #PMFLAG
11622 .LONGA on
11623 .MNLIST
11624 F87C9B A5 22 lda facexp
11625 F87C9D C9 FE 3F cmp #$3FFE ; 0.5
11626 F87CA0 ACC08
11627 F87CA0 E2 20 sep #PMFLAG
11628 .LONGA off
11629 .MNLIST
11630 F87CA2 08 php
11631 F87CA3 20 C0 84 jsr mvf_t2 ; tfr2=|x|
11632 F87CA6 20 CC 49 jsr fsquare ; z=x*x
11633 F87CA9 28 plp
11634 F87CAA 90 34 bcc ?lt05 ; |x| < 0.5
11635 F87CAC 20 6C 45 jsr faddone ; z+1
11636 F87CAF B0 10 bcs ?big ; x*x overflow
11637 F87CB1 20 53 60 jsr fsqrt ; sqrt(z+1)
11638 F87CB4 20 28 86 jsr mvt2_a ; arg=x
11639 F87CB7 20 7D 45 jsr fpadd ; x+sqrt(z+1)
11640 F87CBA B0 05 bcs ?big ; overflow
11641 F87CBC 20 B3 62 jsr floge ; ln(x+sqrt(z+1))
11642 F87CBF 80 4F bra ?done
11643 F87CC1 20 A1 85 ?big: jsr mvt2_f
11644 F87CC4 20 39 84 jsr mvftoa
11645 F87CC7 20 7D 45 jsr fpadd ; try 2*|x|
11646 F87CCA B0 05 bcs ?big1 ; overflow
11647 F87CCC 20 B3 62 jsr floge ; asinh(x) = sgn(x)*(ln(2*|x|))
11648 F87CCF 80 3F bra ?done
11649 F87CD1 20 A1 85 ?big1: jsr mvt2_f
11650 F87CD4 20 B3 62 jsr floge
Tue Jul 17 11:00:18 2018 Page 166
11651 F87CD7 A9 B1 lda #<cln2 ; asinh(x) = sgn(x)*(ln(|x|) + ln(2))
11652 F87CD9 A0 67 ldy #>cln2
11653 F87CDB 20 7A 45 jsr fcadd
11654 F87CDE 80 30 bra ?done
11655 F87CE0 20 66 84 ?lt05: jsr mvf_t0 ; tfr0=z
11656 F87CE3 A9 0A lda #<cashp
11657 F87CE5 A0 80 ldy #>cashp
11658 F87CE7 A2 08 ldx #8
11659 F87CE9 20 1C 87 jsr peval ; evaluates P(z)
11660 F87CEC 20 93 84 jsr mvf_t1 ; tfr2=P(z)
11661 F87CEF A9 AC lda #<cashq
11662 F87CF1 A0 80 ldy #>cashq
11663 F87CF3 A2 08 ldx #8
11664 F87CF5 20 3A 87 jsr pevalp1 ; evaluates Q(z)
11665 F87CF8 20 FB 85 jsr mvt1_a ; arg=P(z)
11666 F87CFB 20 10 4A jsr fpdiv ; R(z)
11667 F87CFE 20 CE 85 jsr mvt0_a ; arg=z
11668 F87D01 20 DD 49 jsr fpmult ; z*R(z)
11669 F87D04 20 28 86 jsr mvt2_a ; arg=x
11670 F87D07 20 DD 49 jsr fpmult ; x*z*R(z)
11671 F87D0A 20 28 86 jsr mvt2_a ; arg=x
11672 F87D0D 20 7D 45 jsr fpadd ; asinh(x)=x + x*z*R(z)
11673 F87D10 A5 CF ?done: lda fpcsgn ; set sign
11674 F87D12 85 24 sta facsgn
11675 F87D14 60 rts
11676
11677 ; facosh - returns the inverse hyperbolic cosine of the argument
11678 ;
11679 ; entry:
11680 ; fac=x
11681 ;
11682 ; exit:
11683 ; fac=acosh(x)
11684 ; CF = 1 if invalid result(inf or nan)
11685 ;
11686 ; strategy
11687 ;
11688 ; Mathematically acosh(x) = ln[x + sqrt(x*x - 1)], x >= 1
11689 ;
11690 ; 1) if 1 <= x < 1.5 acosh(x) is approximated by a rational function:
11691 ;
11692 ; P(z)
11693 ; acosh(x) = sqrt(2*z) * R(z), R(z) = ------, z = x - 1
11694 ; Q(z)
11695 ;
11696 ; 2) if |x| >= 1.5: acosh(x) = ln[x + sqrt(x*x - 1)]
11697 ; overflow will be avoided computing x*x or x + sqrt(...)
11698 ; approximating acosh(x) with:
11699 ;
11700 ; acosh(x) = ln(2*x) if x*x overflow
11701 ;
11702 ; or:
11703 ;
11704 ; acosh(x) = ln(x) + ln(2) if 2*x overflow
11705 ;
11706 ; computation mean time: 75/150ms at 4MHz
11707 ;
Tue Jul 17 11:00:18 2018 Page 167
11708 ;------
11709 F87D15 facosh:
11710 ;------
11711 F87D15 A5 24 lda facsgn ; acosh(x) defined only if x>=1
11712 F87D17 30 0B bmi ?nan
11713 F87D19 24 25 bit facst
11714 F87D1B 30 0A bmi ?er ; nan or inf; returns nan or inf
11715 F87D1D 20 24 74 jsr cmpx1 ; compare x with 1.0
11716 F87D20 F0 07 beq ?z ; acosh(1) = 0
11717 F87D22 B0 08 bcs ?ok ; returns nan if |x|<1
11718 F87D24 4C 74 4E ?nan: jmp fldnan
11719 F87D27 38 ?er: sec
11720 F87D28 60 rts
11721 F87D29 4C 56 4E ?z: jmp fldz
11722 F87D2C A9 5A ?ok: lda #<c1h5
11723 F87D2E A0 7E ldy #>c1h5
11724 F87D30 20 5E 87 jsr fccmp ; compare x vs. 1.5
11725 F87D33 F0 3B beq ?gt ; x = 1.5
11726 F87D35 10 39 bpl ?gt ; x > 1.5
11727 F87D37 20 71 45 jsr fsubone ; z = x - 1 (x < 1.5)
11728 F87D3A 20 66 84 jsr mvf_t0 ; tfr0=z
11729 F87D3D 20 39 84 jsr mvftoa
11730 F87D40 20 7D 45 jsr fpadd ; 2*z
11731 F87D43 20 C0 84 jsr mvf_t2 ; tfr2 = 2*z
11732 F87D46 A9 4E lda #<cachp
11733 F87D48 A0 81 ldy #>cachp
11734 F87D4A A2 09 ldx #9
11735 F87D4C 20 1C 87 jsr peval ; evaluates P(z)
11736 F87D4F 20 93 84 jsr mvf_t1 ; tfr1=P(z)
11737 F87D52 A9 02 lda #<cachq
11738 F87D54 A0 82 ldy #>cachq
11739 F87D56 A2 08 ldx #8
11740 F87D58 20 3A 87 jsr pevalp1 ; evaluates Q(z)
11741 F87D5B 20 FB 85 jsr mvt1_a ; arg=P(z)
11742 F87D5E 20 10 4A jsr fpdiv ; R(z)
11743 F87D61 20 ED 84 jsr mvf_t3 ; tfr3 = R(z)
11744 F87D64 20 A1 85 jsr mvt2_f ; fac=2*z
11745 F87D67 20 53 60 jsr fsqrt ; sqrt(2*z)
11746 F87D6A 20 55 86 jsr mvt3_a ; R(z)
11747 F87D6D 4C DD 49 jmp fpmult ; acosh(x) = sqrt(2*z)*R(z)
11748 F87D70 20 C0 84 ?gt: jsr mvf_t2 ; tfr2 = x
11749 F87D73 20 CC 49 jsr fsquare
11750 F87D76 B0 11 bcs ?big ; x*x overflow
11751 F87D78 20 71 45 jsr fsubone ; x*x - 1
11752 F87D7B 20 53 60 jsr fsqrt
11753 F87D7E 20 28 86 jsr mvt2_a ; x
11754 F87D81 20 7D 45 jsr fpadd
11755 F87D84 B0 03 bcs ?big ; overflow
11756 F87D86 4C B3 62 jmp floge ; acosh(x) = ln[x + sqrt(x*x - 1)]
11757 F87D89 20 A1 85 ?big: jsr mvt2_f ; x
11758 F87D8C 20 39 84 jsr mvftoa
11759 F87D8F 20 7D 45 jsr fpadd ; try 2*x
11760 F87D92 B0 03 bcs ?big1 ; overflow
11761 F87D94 4C B3 62 jmp floge ; acosh(x) = ln(2*x)
11762 F87D97 20 A1 85 ?big1: jsr mvt2_f ; x
11763 F87D9A 20 B3 62 jsr floge
11764 F87D9D A9 B1 lda #<cln2 ; acosh(x) = ln(x) + ln(2)
Tue Jul 17 11:00:18 2018 Page 168
11765 F87D9F A0 67 ldy #>cln2
11766 F87DA1 4C 7A 45 jmp fcadd
11767
11768 ; fatanh - returns the inverse hyperbolic tangent of the argument
11769 ;
11770 ; entry:
11771 ; fac=x
11772 ;
11773 ; exit:
11774 ; fac=atanh(x)
11775 ; CF = 1 if invalid result(inf or nan)
11776 ;
11777 ; strategy
11778 ; 1 1 + x
11779 ; Mathematically atanh(x) = --- * ln(-------) , -1 < x < 1
11780 ; 2 1 - x
11781 ;
11782 ; 1) if |x| < 0.5 atanh(x) is approximated by a rational function:
11783 ;
11784 ; 3 P(z) 2
11785 ; atanh(x) = x + x * R(z), R(z) = ------, z = x
11786 ; Q(z)
11787 ;
11788 ; 2) if |x| >= 0.5:
11789 ;
11790 ; 1 1 + |x|
11791 ; atanh(x) = --- * sgn(x) * ln(---------)
11792 ; 2 1 - |x|
11793 ;
11794 ; computation mean time: 80/100ms at 4MHz
11795 ;
11796 ;------
11797 F87DA4 fatanh:
11798 ;------
11799 F87DA4 24 25 bit facst ; if fac=nan or fac=inf returns nan
11800 F87DA6 30 07 bmi ?nan
11801 F87DA8 50 08 bvc ?fv
11802 F87DAA 18 clc ; if fac=0 returns zero
11803 F87DAB 60 rts
11804 F87DAC 4C 7D 4E ?inf: jmp fldinf
11805 F87DAF 4C 74 4E ?nan: jmp fldnan ; if |x| > 1 returns nan
11806 F87DB2 20 24 74 ?fv: jsr cmpx1 ; compare x vs. 1.0
11807 F87DB5 F0 F5 beq ?inf ; atanh(+/-1) = +/-inf
11808 F87DB7 B0 F6 bcs ?nan ; if |x| > 1 returns nan
11809 F87DB9 ACC16
11810 F87DB9 C2 20 rep #PMFLAG
11811 .LONGA on
11812 .MNLIST
11813 F87DBB A5 22 lda facexp
11814 F87DBD C9 FE 3F cmp #$3FFE ; compare x vs. 0.5
11815 F87DC0 ACC08
11816 F87DC0 E2 20 sep #PMFLAG
11817 .LONGA off
11818 .MNLIST
11819 F87DC2 B0 36 bcs ?gt ; |x| >= 0.5
11820 F87DC4 20 C0 84 jsr mvf_t2 ; tfr2 = x
11821 F87DC7 20 CC 49 jsr fsquare ; z=x*x
Tue Jul 17 11:00:18 2018 Page 169
11822 F87DCA 20 66 84 jsr mvf_t0 ; tfr0=z
11823 F87DCD A9 A4 lda #<cathp
11824 F87DCF A0 82 ldy #>cathp
11825 F87DD1 A2 09 ldx #9
11826 F87DD3 20 1C 87 jsr peval ; evaluates P(z)
11827 F87DD6 20 93 84 jsr mvf_t1 ; tfr2=P(z)
11828 F87DD9 A9 58 lda #<cathq
11829 F87DDB A0 83 ldy #>cathq
11830 F87DDD A2 09 ldx #9
11831 F87DDF 20 3A 87 jsr pevalp1 ; evaluates Q(z)
11832 F87DE2 20 FB 85 jsr mvt1_a ; arg=P(z)
11833 F87DE5 20 10 4A jsr fpdiv ; R(z)
11834 F87DE8 20 CE 85 jsr mvt0_a ; arg=z
11835 F87DEB 20 DD 49 jsr fpmult ; z*R(z)
11836 F87DEE 20 28 86 jsr mvt2_a ; arg=x
11837 F87DF1 20 DD 49 jsr fpmult ; x*z*R(z)
11838 F87DF4 20 28 86 jsr mvt2_a ; arg=x
11839 F87DF7 4C 7D 45 jmp fpadd ; atanh(x)=x + x*z*R(z)
11840 F87DFA A5 24 ?gt: lda facsgn
11841 F87DFC 85 CF sta fpcsgn ; save x sign
11842 F87DFE 64 24 stz facsgn ; |x|
11843 F87E00 20 66 84 jsr mvf_t0 ; tfr0 = |x|
11844 F87E03 20 6C 45 jsr faddone ; y = 1 + |x|
11845 F87E06 20 93 84 jsr mvf_t1 ; tfr1 = y
11846 F87E09 20 47 85 jsr mvt0_f ; |x|
11847 F87E0C A9 48 lda #<cthl
11848 F87E0E A0 7E ldy #>cthl
11849 F87E10 20 5E 87 jsr fccmp ; compare |x| vs. 0.9990234375
11850 F87E13 30 19 bmi ?dom1 ; if |x| <= 0.9990234375...
11851 F87E15 F0 17 beq ?dom1 ; ...computes z = 1 - |x|
11852 F87E17 A9 B3 lda #<fce32 ; otherwisa scale by 1e32
11853 F87E19 A0 5F ldy #>fce32
11854 F87E1B 20 D5 49 jsr fcmult
11855 F87E1E A9 B3 lda #<fce32 ; computes z = 1e32 - |x|*1e32
11856 F87E20 A0 5F ldy #>fce32
11857 F87E22 20 5C 45 jsr fcsub
11858 F87E25 A9 B3 lda #<fce32 ; scale back
11859 F87E27 A0 5F ldy #>fce32
11860 F87E29 20 0A 4A jsr fcrdiv ; z = 1 - |x|
11861 F87E2C 80 06 bra ?div
11862 F87E2E 20 A6 4E ?dom1: jsr ldaone ; arg=1
11863 F87E31 20 5F 45 jsr fpsub ; z = 1 - |x|
11864 F87E34 20 FB 85 ?div: jsr mvt1_a ; arg = y = 1 + |x|
11865 F87E37 20 10 4A jsr fpdiv ; w = y/z
11866 F87E3A 20 B3 62 jsr floge ; ln(w) = ln[(1 + |x|)/(1 - |x|)]
11867 F87E3D ACC16
11868 F87E3D C2 20 rep #PMFLAG
11869 .LONGA on
11870 .MNLIST
11871 F87E3F C6 22 dec facexp ; divide by2
11872 F87E41 ACC08
11873 F87E41 E2 20 sep #PMFLAG
11874 .LONGA off
11875 .MNLIST
11876 F87E43 A5 CF lda fpcsgn ; restore sign
11877 F87E45 85 24 sta facsgn
11878 F87E47 60 rts
Tue Jul 17 11:00:18 2018 Page 170
11879
11880 ; 0.9990234375 = tanh(3.81206529283064476456228418624)
11881 F87E48 00 00 00 00 00 cthl: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
11882 F87E51 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$C0,$FF,$FE,$3F
C0 FF FE 3F
11883 ; 1.5
11884 F87E5A 00 00 00 00 00 c1h5: .DB $00,$00,$00,$00,$00,$00,$00,$00,$00
00 00 00 00
11885 F87E63 00 00 00 00 00 .DB $00,$00,$00,$00,$00,$00,$C0,$FF,$3F
00 C0 FF 3F
11886
11887 ; sinh(x) coefficients
11888 F87E6C cshp:
11889 ; SHP[5] = 1.622194395724068297909052717437740288268E3
11890 F87E6C 17 69 DD D3 6C .DB $17,$69,$DD,$D3,$6C,$86,$A5,$72,$E8
86 A5 72 E8
11891 F87E75 60 AB 61 7D 38 .DB $60,$AB,$61,$7D,$38,$C6,$CA,$09,$40
C6 CA 09 40
11892
11893 ; SHP[4] = 1.124862584587770079742188354390171794549E6
11894 F87E7E 1D 93 DF 58 C9 .DB $1D,$93,$DF,$58,$C9,$1A,$0E,$8E,$12
1A 0E 8E 12
11895 F87E87 51 5A 3C AD F4 .DB $51,$5A,$3C,$AD,$F4,$4F,$89,$13,$40
4F 89 13 40
11896
11897 ; SHP[3] = 3.047548980769660162696832999871894196102E8
11898 F87E90 9E C2 A9 C6 06 .DB $9E,$C2,$A9,$C6,$06,$9F,$E8,$40,$D6
9F E8 40 D6
11899 F87E99 5B A0 9D 90 86 .DB $5B,$A0,$9D,$90,$86,$51,$91,$1B,$40
51 91 1B 40
11900
11901 ; SHP[2] = 3.966215348072348368191433063260384329745E10
11902 F87EA2 2F 3F 63 A6 E4 .DB $2F,$3F,$63,$A6,$E4,$FD,$2F,$10,$A0
FD 2F 10 A0
11903 F87EAB 63 93 8B F0 C6 .DB $63,$93,$8B,$F0,$C6,$C0,$93,$22,$40
C0 93 22 40
11904
11905 ; SHP[1] = 2.375869584584371194838551715348965605295E12
11906 F87EB4 0E D1 C3 AC F2 .DB $0E,$D1,$C3,$AC,$F2,$82,$01,$FF,$A7
82 01 FF A7
11907 F87EBD C1 17 32 35 37 .DB $C1,$17,$32,$35,$37,$4B,$8A,$28,$40
4B 8A 28 40
11908
11909 ; SHP[0] = 6.482835792103233269752264509192030816323E13
11910 F87EC6 6C 44 21 C8 30 .DB $6C,$44,$21,$C8,$30,$E2,$CC,$A8,$AE
E2 CC A8 AE
11911 F87ECF 54 21 24 FB 1C .DB $54,$21,$24,$FB,$1C,$D8,$EB,$2C,$40
D8 EB 2C 40
11912
11913 F87ED8 cshq:
11914 ; SHQ[5] = -9.101683853129357776079049616394849086007E2
11915 F87ED8 E1 53 03 04 33 .DB $E1,$53,$03,$04,$33,$F5,$4A,$94,$A1
F5 4A 94 A1
11916 F87EE1 E5 0B 31 D3 C6 .DB $E5,$0B,$31,$D3,$C6,$8A,$E3,$08,$C0
8A E3 08 C0
11917
Tue Jul 17 11:00:18 2018 Page 171
11918 ; SHQ[4] = 4.486400519836461218634448973793765123186E5
11919 F87EEA 1B 10 39 12 99 .DB $1B,$10,$39,$12,$99,$3F,$E1,$CF,$A5
3F E1 CF A5
11920 F87EF3 80 9B D9 A9 01 .DB $80,$9B,$D9,$A9,$01,$10,$DB,$11,$40
10 DB 11 40
11921
11922 ; SHQ[3] = -1.492531313030440305095318968983514314656E8
11923 F87EFC E3 FC 9D E6 6A .DB $E3,$FC,$9D,$E6,$6A,$12,$5D,$95,$84
12 5D 95 84
11924 F87F05 B2 44 D9 B4 C0 .DB $B2,$44,$D9,$B4,$C0,$56,$8E,$1A,$C0
56 8E 1A C0
11925
11926 ; SHQ[2] = 3.457771488856930054902696708717192082887E10
11927 F87F0E 36 87 1A 50 C3 .DB $36,$87,$1A,$50,$C3,$93,$A6,$7A,$E4
93 A6 7A E4
11928 F87F17 DA 1B 89 EC E0 .DB $DA,$1B,$89,$EC,$E0,$CF,$80,$22,$40
CF 80 22 40
11929
11930 ; SHQ[1] = -5.193289868803472640225483235513427062460E12
11931 F87F20 DF 76 FE 54 9D .DB $DF,$76,$FE,$54,$9D,$2F,$E7,$64,$DE
2F E7 64 DE
11932 F87F29 1F 6F C0 54 06 .DB $1F,$6F,$C0,$54,$06,$25,$97,$29,$C0
25 97 29 C0
11933
11934 ; SHQ[0] = 3.889701475261939961851358705515223019890E14
11935 F87F32 F5 20 1D 96 A4 .DB $F5,$20,$1D,$96,$A4,$A9,$99,$FE,$82
A9 99 FE 82
11936 F87F3B FF 18 5B BC 15 .DB $FF,$18,$5B,$BC,$15,$E2,$B0,$2F,$40
E2 B0 2F 40
11937
11938 ; tanh(x) coefficients
11939 F87F44 cthp:
11940 ; THP[5] = -6.505693197948351084912624750702492767503E-6
11941 F87F44 A5 DE 0A CF 2E .DB $A5,$DE,$0A,$CF,$2E,$1F,$25,$59,$90
1F 25 59 90
11942 F87F4D 92 24 C2 A2 7A .DB $92,$24,$C2,$A2,$7A,$4B,$DA,$ED,$BF
4B DA ED BF
11943
11944 ; THP[4] = -9.804083860188429726356968570322356183383E-1
11945 F87F56 2F F3 D5 9C 7D .DB $2F,$F3,$D5,$9C,$7D,$E3,$C3,$6C,$CA
E3 C3 6C CA
11946 F87F5F A9 D1 AC 42 0B .DB $A9,$D1,$AC,$42,$0B,$FC,$FA,$FE,$BF
FC FA FE BF
11947
11948 ; THP[3] = -5.055287638900473250703725789725376004355E2
11949 F87F68 74 6D 2D 35 A2 .DB $74,$6D,$2D,$35,$A2,$58,$08,$D8,$58
58 08 D8 58
11950 F87F71 8D 87 FF 88 AE .DB $8D,$87,$FF,$88,$AE,$C3,$FC,$07,$C0
C3 FC 07 C0
11951
11952 ; THP[2] = -7.307477148073823966594990496301416814519E4
11953 F87F7A 96 63 D3 D4 55 .DB $96,$63,$D3,$D4,$55,$B8,$E3,$D5,$DC
B8 E3 D5 DC
11954 F87F83 1D 7E E1 BF 62 .DB $1D,$7E,$E1,$BF,$62,$B9,$8E,$0F,$C0
B9 8E 0F C0
11955
11956 ; THP[1] = -3.531606586182691280701462523692471322688E6
Tue Jul 17 11:00:18 2018 Page 172
11957 F87F8C 96 14 AC DD D7 .DB $96,$14,$AC,$DD,$D7,$7B,$66,$A4,$20
7B 66 A4 20
11958 F87F95 82 46 40 58 5A .DB $82,$46,$40,$58,$5A,$8D,$D7,$14,$C0
8D D7 14 C0
11959
11960 ; THP[0] = -4.551377146142783468144190926206842300707E7
11961 F87F9E E4 75 8D 86 22 .DB $E4,$75,$8D,$86,$22,$74,$D2,$EF,$DA
74 D2 EF DA
11962 F87FA7 9C 08 88 DD 0A .DB $9C,$08,$88,$DD,$0A,$9F,$AD,$18,$C0
9F AD 18 C0
11963
11964 F87FB0 cthq:
11965 ; THQ[4] = 5.334865598460027935735737253027154828002E2
11966 F87FB0 19 BD 0A 16 6E .DB $19,$BD,$0A,$16,$6E,$A3,$F1,$38,$2C
A3 F1 38 2C
11967 F87FB9 3E 88 E8 CB 23 .DB $3E,$88,$E8,$CB,$23,$5F,$85,$08,$40
5F 85 08 40
11968
11969 ; THQ[3] = 8.058475607422391042912151298751537172870E4
11970 F87FC2 9F 9E F9 42 21 .DB $9F,$9E,$F9,$42,$21,$C6,$63,$AC,$9D
C6 63 AC 9D
11971 F87FCB 85 48 0A C7 60 .DB $85,$48,$0A,$C7,$60,$64,$9D,$0F,$40
64 9D 0F 40
11972
11973 ; THQ[2] = 4.197073523796142343374222405869721575491E6
11974 F87FD4 22 53 FB 45 7B .DB $22,$53,$FB,$45,$7B,$BE,$6D,$81,$45
BE 6D 81 45
11975 F87FDD 0A 02 2F 0C A3 .DB $0A,$02,$2F,$0C,$A3,$15,$80,$15,$40
15 80 15 40
11976
11977 ; THQ[1] = 6.521134551226147545983467868553677881771E7
11978 F87FE6 95 2E 27 14 95 .DB $95,$2E,$27,$14,$95,$C2,$CF,$71,$06
C2 CF 71 06
11979 F87FEF 5B E4 C8 60 F4 .DB $5B,$E4,$C8,$60,$F4,$C2,$F8,$18,$40
C2 F8 18 40
11980
11981 ; THQ[0] = 1.365413143842835040443257277862054198329E8
11982 F87FF8 34 03 ED E4 19 .DB $34,$03,$ED,$E4,$19,$D7,$DD,$33,$A4
D7 DD 33 A4
11983 F88001 75 06 26 26 48 .DB $75,$06,$26,$26,$48,$37,$82,$1A,$40
37 82 1A 40
11984
11985 ; asinh(x) coefficients
11986 F8800A cashp:
11987 ; ASHP[8] = -8.104404283317298189545629468767571317688E-1
11988 F8800A D4 44 8A 29 62 .DB $D4,$44,$8A,$29,$62,$9C,$61,$3B,$4F
9C 61 3B 4F
11989 F88013 B9 7F 0A 1F 06 .DB $B9,$7F,$0A,$1F,$06,$79,$CF,$FE,$BF
79 CF FE BF
11990
11991 ; ASHP[7] = -4.954206127425209147110732546633675599008E1
11992 F8801C 4C 2A 14 A7 8C .DB $4C,$2A,$14,$A7,$8C,$5D,$7A,$C6,$D8
5D 7A C6 D8
11993 F88025 FF 5C 55 1C 12 .DB $FF,$5C,$55,$1C,$12,$2B,$C6,$04,$C0
2B C6 04 C0
11994
11995 ; ASHP[6] = -8.438175619831548439550086251740438689853E2
Tue Jul 17 11:00:18 2018 Page 173
11996 F8802E 1F E6 69 54 E9 .DB $1F,$E6,$69,$54,$E9,$DD,$A7,$DA,$DB
DD A7 DA DB
11997 F88037 96 06 7F EF 52 .DB $96,$06,$7F,$EF,$52,$F4,$D2,$08,$C0
F4 D2 08 C0
11998
11999 ; ASHP[5] = -6.269710069245210459536983820505214648057E3
12000 F88040 4D 94 05 70 20 .DB $4D,$94,$05,$70,$20,$FD,$0E,$76,$39
FD 0E 76 39
12001 F88049 98 D0 C8 38 AE .DB $98,$D0,$C8,$38,$AE,$ED,$C3,$0B,$C0
ED C3 0B C0
12002
12003 ; ASHP[4] = -2.418935474493501382372711518024193326434E4
12004 F88052 65 46 D1 97 6C .DB $65,$46,$D1,$97,$6C,$45,$6A,$6B,$AE
45 6A 6B AE
12005 F8805B 9C CC 20 A1 B5 .DB $9C,$CC,$20,$A1,$B5,$FA,$BC,$0D,$C0
FA BC 0D C0
12006
12007 ; ASHP[3] = -5.208121780431312783866941311277024486498E4
12008 F88064 C1 0A 1C 9F EE .DB $C1,$0A,$1C,$9F,$EE,$A5,$FC,$D0,$D2
A5 FC D0 D2
12009 F8806D CF 01 06 C2 37 .DB $CF,$01,$06,$C2,$37,$71,$CB,$0E,$C0
71 CB 0E C0
12010
12011 ; ASHP[2] = -6.302755086521614763280617114866439227971E4
12012 F88076 27 92 3C F6 A2 .DB $27,$92,$3C,$F6,$A2,$88,$78,$6D,$A9
88 78 6D A9
12013 F8807F DB B7 80 05 8D .DB $DB,$B7,$80,$05,$8D,$33,$F6,$0E,$C0
33 F6 0E C0
12014
12015 ; ASHP[1] = -4.003566436224198252093684987323233921339E4
12016 F88088 3D 57 F5 E9 85 .DB $3D,$57,$F5,$E9,$85,$D7,$5B,$49,$1D
D7 5B 49 1D
12017 F88091 03 D6 A4 13 AA .DB $03,$D6,$A4,$13,$AA,$63,$9C,$0E,$C0
63 9C 0E C0
12018
12019 ; ASHP[0] = -1.037690841528359305134494613113086980551E4
12020 F8809A 75 93 4B 3D 7C .DB $75,$93,$4B,$3D,$7C,$5E,$17,$5F,$F8
5E 17 5F F8
12021 F880A3 DF B8 9D 37 A2 .DB $DF,$B8,$9D,$37,$A2,$23,$A2,$0C,$C0
23 A2 0C C0
12022
12023 F880AC cashq:
12024 ; ASHQ[8] = 8.175806439951395194771977809279448392548E1
12025 F880AC 2D 40 15 F1 2B .DB $2D,$40,$15,$F1,$2B,$46,$3A,$A0,$19
46 3A A0 19
12026 F880B5 3E 59 58 04 21 .DB $3E,$59,$58,$04,$21,$84,$A3,$05,$40
84 A3 05 40
12027
12028 ; ASHQ[7] = 1.822215299975696008284027212745010251320E3
12029 F880BE FC 15 F8 77 03 .DB $FC,$15,$F8,$77,$03,$2B,$9A,$81,$D7
2B 9A 81 D7
12030 F880C7 34 4E C6 BC E3 .DB $34,$4E,$C6,$BC,$E3,$C6,$E3,$09,$40
C6 E3 09 40
12031
12032 ; ASHQ[6] = 1.772040003462901790853111853838978236828E4
12033 F880D0 14 67 63 D4 3C .DB $14,$67,$63,$D4,$3C,$7C,$F1,$6E,$7F
7C F1 6E 7F
Tue Jul 17 11:00:18 2018 Page 174
12034 F880D9 CC C1 56 D1 CC .DB $CC,$C1,$56,$D1,$CC,$70,$8A,$0D,$40
70 8A 0D 40
12035
12036 ; ASHQ[5] = 9.077625379864046240143413577745818879353E4
12037 F880E2 C1 7C F0 4C 1A .DB $C1,$7C,$F0,$4C,$1A,$FC,$B2,$4C,$13
FC B2 4C 13
12038 F880EB 47 4E 79 7C 20 .DB $47,$4E,$79,$7C,$20,$4C,$B1,$0F,$40
4C B1 0F 40
12039
12040 ; ASHQ[4] = 2.675554475070211205153169988669677418808E5
12041 F880F4 F5 4D 22 AF FB .DB $F5,$4D,$22,$AF,$FB,$11,$EE,$02,$2D
11 EE 02 2D
12042 F880FD 8E 3E FA 51 6E .DB $8E,$3E,$FA,$51,$6E,$A4,$82,$11,$40
A4 82 11 40
12043
12044 ; ASHQ[3] = 4.689758557916492969463473819426544383586E5
12045 F88106 9B B8 C0 1B 1D .DB $9B,$B8,$C0,$1B,$1D,$C9,$87,$FB,$72
C9 87 FB 72
12046 F8810F 3D 2B A5 62 FB .DB $3D,$2B,$A5,$62,$FB,$FD,$E4,$11,$40
FD E4 11 40
12047
12048 ; ASHQ[2] = 4.821923684550711724710891114802924039911E5
12049 F88118 77 20 49 F1 27 .DB $77,$20,$49,$F1,$27,$60,$C2,$4C,$65
60 C2 4C 65
12050 F88121 17 4A 62 CA 0B .DB $17,$4A,$62,$CA,$0B,$72,$EB,$11,$40
72 EB 11 40
12051
12052 ; ASHQ[1] = 2.682316388947175963642524537892687560973E5
12053 F8812A F4 0E 30 16 03 .DB $F4,$0E,$30,$16,$03,$74,$A4,$B8,$3B
74 A4 B8 3B
12054 F88133 B5 55 D3 71 F4 .DB $B5,$55,$D3,$71,$F4,$F8,$82,$11,$40
F8 82 11 40
12055
12056 ; ASHQ[0] = 6.226145049170155830806967678679167550122E4
12057 F8813C F9 E9 F0 5D BA .DB $F9,$E9,$F0,$5D,$BA,$0D,$A3,$8E,$F4
0D A3 8E F4
12058 F88145 4F 95 6C 53 73 .DB $4F,$95,$6C,$53,$73,$35,$F3,$0E,$40
35 F3 0E 40
12059
12060 ; acosh(x) coefficients
12061 F8814E cachp:
12062 ; ACHP[9] = 1.895467874386341763387398084072833727168E-1
12063 F8814E 66 70 8A 32 3A .DB $66,$70,$8A,$32,$3A,$8B,$D0,$B4,$43
8B D0 B4 43
12064 F88157 DF 74 71 94 8D .DB $DF,$74,$71,$94,$8D,$18,$C2,$FC,$3F
18 C2 FC 3F
12065
12066 ; ACHP[8] = 6.443902084393244878979969557171256604767E1
12067 F88160 C5 F1 41 7D 6B .DB $C5,$F1,$41,$7D,$6B,$5B,$C4,$95,$21
5B C4 95 21
12068 F88169 85 E7 0D 57 C7 .DB $85,$E7,$0D,$57,$C7,$E0,$80,$05,$40
E0 80 05 40
12069
12070 ; ACHP[7] = 3.914593556594721458616408528941154205393E3
12071 F88172 8E E9 6A AE 1F .DB $8E,$E9,$6A,$AE,$1F,$EF,$B1,$89,$ED
EF B1 89 ED
12072 F8817B 75 2A 33 35 7F .DB $75,$2A,$33,$35,$7F,$A9,$F4,$0A,$40
Tue Jul 17 11:00:18 2018 Page 175
A9 F4 0A 40
12073
12074 ; ACHP[6] = 9.164040999602964494412169748897754668733E4
12075 F88184 17 50 27 B4 1E .DB $17,$50,$27,$B4,$1E,$5D,$6C,$09,$4E
5D 6C 09 4E
12076 F8818D 68 F9 BF 7A 34 .DB $68,$F9,$BF,$7A,$34,$FC,$B2,$0F,$40
FC B2 0F 40
12077
12078 ; ACHP[5] = 1.065909694792026382660307834723001543839E6
12079 F88196 33 4B 4E 96 02 .DB $33,$4B,$4E,$96,$02,$E5,$64,$46,$AE
E5 64 46 AE
12080 F8819F 36 1F EF 8E AD .DB $36,$1F,$EF,$8E,$AD,$1D,$82,$13,$40
1D 82 13 40
12081
12082 ; ACHP[4] = 6.899169896709615182428217047370629406305E6
12083 F881A8 84 A4 A5 35 34 .DB $84,$A4,$A5,$35,$34,$96,$92,$3E,$6F
96 92 3E 6F
12084 F881B1 CE 85 1D CB C3 .DB $CE,$85,$1D,$CB,$C3,$8B,$D2,$15,$40
8B D2 15 40
12085
12086 ; ACHP[3] = 2.599781868717579447900896150777162652518E7
12087 F881BA 46 B9 30 2C 87 .DB $46,$B9,$30,$2C,$87,$69,$CA,$F0,$F1
69 CA F0 F1
12088 F881C3 5D 60 F5 57 FD .DB $5D,$60,$F5,$57,$FD,$58,$C6,$17,$40
58 C6 17 40
12089
12090 ; ACHP[2] = 5.663733059389964024656501196827345337766E7
12091 F881CC B6 97 B7 46 A7 .DB $B6,$97,$B7,$46,$A7,$44,$37,$C5,$FD
44 37 C5 FD
12092 F881D5 A2 73 02 A6 E4 .DB $A2,$73,$02,$A6,$E4,$0D,$D8,$18,$40
0D D8 18 40
12093
12094 ; ACHP[1] = 6.606302846870644033621560858582696134512E7
12095 F881DE 3C C5 80 74 46 .DB $3C,$C5,$80,$74,$46,$EC,$B0,$CA,$2A
EC B0 CA 2A
12096 F881E7 4C 49 FF 1D AD .DB $4C,$49,$FF,$1D,$AD,$02,$FC,$18,$40
02 FC 18 40
12097
12098 ; ACHP[0] = 3.190482951215438078279772140481195200593E7
12099 F881F0 10 22 D8 A0 1A .DB $10,$22,$D8,$A0,$1A,$7C,$37,$8D,$FB
7C 37 8D FB
12100 F881F9 55 46 8E C1 1E .DB $55,$46,$8E,$C1,$1E,$6A,$F3,$17,$40
6A F3 17 40
12101
12102 F88202 cachq:
12103 ; ACHQ[8] = 1.635418024331924674147953764918262009321E2
12104 F88202 5C C5 F5 4B 8C .DB $5C,$C5,$F5,$4B,$8C,$8D,$25,$D8,$84
8D 25 D8 84
12105 F8820B 72 74 73 90 B3 .DB $72,$74,$73,$90,$B3,$8A,$A3,$06,$40
8A A3 06 40
12106
12107 ; ACHQ[7] = 7.290983678312632723073455563799692165828E3
12108 F88214 C3 9C 13 ED 77 .DB $C3,$9C,$13,$ED,$77,$C1,$6B,$F3,$08
C1 6B F3 08
12109 F8821D 56 34 BC 92 DE .DB $56,$34,$BC,$92,$DE,$D7,$E3,$0B,$40
D7 E3 0B 40
12110
Tue Jul 17 11:00:18 2018 Page 176
12111 ; ACHQ[6] = 1.418207894088607063257675159183397062114E5
12112 F88226 9E 1E 0F 35 24 .DB $9E,$1E,$0F,$35,$24,$95,$08,$A2,$00
95 08 A2 00
12113 F8822F FA BD AC 85 32 .DB $FA,$BD,$AC,$85,$32,$7F,$8A,$10,$40
7F 8A 10 40
12114
12115 ; ACHQ[5] = 1.453154285419072886840913424715826321357E6
12116 F88238 A8 C8 CD DC 85 .DB $A8,$C8,$CD,$DC,$85,$7E,$96,$04,$A1
7E 96 04 A1
12117 F88241 7D CB 89 48 12 .DB $7D,$CB,$89,$48,$12,$63,$B1,$13,$40
63 B1 13 40
12118
12119 ; ACHQ[4] = 8.566841438576725234955968880501739464425E6
12120 F8824A 7A 0D 61 29 7E .DB $7A,$0D,$61,$29,$7E,$C7,$01,$C1,$AB
C7 01 C1 AB
12121 F88253 73 90 46 70 39 .DB $73,$90,$46,$70,$39,$B8,$82,$16,$40
B8 82 16 40
12122
12123 ; ACHQ[3] = 3.003448667795089562511136059766833630017E7
12124 F8825C 5F BB CA 91 50 .DB $5F,$BB,$CA,$91,$50,$67,$4C,$7B,$80
67 4C 7B 80
12125 F88265 4E 18 C7 56 1B .DB $4E,$18,$C7,$56,$1B,$25,$E5,$17,$40
25 E5 17 40
12126
12127 ; ACHQ[2] = 6.176592872899557661256383958395266919654E7
12128 F8826E 56 19 E7 C9 A7 .DB $56,$19,$E7,$C9,$A7,$81,$29,$B2,$1E
81 29 B2 1E
12129 F88277 10 DD A7 2E 4A .DB $10,$DD,$A7,$2E,$4A,$9E,$EB,$18,$40
9E EB 18 40
12130
12131 ; ACHQ[1] = 6.872176426138597206811541870289420510034E7
12132 F88280 9F AE 34 C8 63 .DB $9F,$AE,$34,$C8,$63,$F3,$9E,$4D,$35
F3 9E 4D 35
12133 F88289 1D 46 5D 88 8C .DB $1D,$46,$5D,$88,$8C,$13,$83,$19,$40
13 83 19 40
12134
12135 ; ACHQ[0] = 3.190482951215438078279772140481195226621E7
12136 F88292 60 2C D8 A0 1A .DB $60,$2C,$D8,$A0,$1A,$7C,$37,$8D,$FB
7C 37 8D FB
12137 F8829B 55 46 8E C1 1E .DB $55,$46,$8E,$C1,$1E,$6A,$F3,$17,$40
6A F3 17 40
12138
12139 ; atanh(x) coefficients
12140 F882A4 cathp:
12141 ; ATHP[9] = -9.217569843805850417698565442251656375681E-1
12142 F882A4 56 9C 44 93 0B .DB $56,$9C,$44,$93,$0B,$94,$F9,$5D,$55
94 F9 5D 55
12143 F882AD AE 31 C6 06 44 .DB $AE,$31,$C6,$06,$44,$F8,$EB,$FE,$BF
F8 EB FE BF
12144
12145 ; ATHP[8] = 5.321929116410615470118183794063211260728E1
12146 F882B6 00 73 D2 C8 AD .DB $00,$73,$D2,$C8,$AD,$50,$DA,$62,$26
50 DA 62 26
12147 F882BF 02 8D E8 DC 8D .DB $02,$8D,$E8,$DC,$8D,$E0,$D4,$04,$40
E0 D4 04 40
12148
12149 ; ATHP[7] = -9.139522976807685333981548145417830690552E2
Tue Jul 17 11:00:18 2018 Page 177
12150 F882C8 FF 0B FD 2D D9 .DB $FF,$0B,$FD,$2D,$D9,$80,$67,$44,$AA
80 67 44 AA
12151 F882D1 47 BD F8 71 F2 .DB $47,$BD,$F8,$71,$F2,$7C,$E4,$08,$C0
7C E4 08 C0
12152
12153 ; ATHP[6] = 7.204314536952949779101646454146682033772E3
12154 F882DA B7 34 20 F1 AE .DB $B7,$34,$20,$F1,$AE,$B4,$89,$32,$1E
B4 89 32 1E
12155 F882E3 6C 32 F3 2B 84 .DB $6C,$32,$F3,$2B,$84,$22,$E1,$0B,$40
22 E1 0B 40
12156
12157 ; ATHP[5] = -3.097809640165146436529075324081668598891E4
12158 F882EC AB 05 FB 15 54 .DB $AB,$05,$FB,$15,$54,$FB,$82,$FE,$C1
FB 82 FE C1
12159 F882F5 A3 A8 8E 5B 31 .DB $A3,$A8,$8E,$5B,$31,$04,$F2,$0D,$C0
04 F2 0D C0
12160
12161 ; ATHP[4] = 7.865376554210973897486215630898496100534E4
12162 F882FE D8 06 5E 71 61 .DB $D8,$06,$5E,$71,$61,$54,$5E,$34,$16
54 5E 34 16
12163 F88307 85 AA 48 FD E1 .DB $85,$AA,$48,$FD,$E1,$9E,$99,$0F,$40
9E 99 0F 40
12164
12165 ; ATHP[3] = -1.211716814094785128366087489224821937203E5
12166 F88310 4A 97 EA 1A 1E .DB $4A,$97,$EA,$1A,$1E,$BF,$9D,$77,$D2
BF 9D 77 D2
12167 F88319 B2 00 6D 38 D7 .DB $B2,$00,$6D,$38,$D7,$A9,$EC,$0F,$C0
A9 EC 0F C0
12168
12169 ; ATHP[2] = 1.112669508789123834670923967462068457013E5
12170 F88322 4A 6F 5C D9 90 .DB $4A,$6F,$5C,$D9,$90,$61,$4B,$27,$4F
61 4B 27 4F
12171 F8832B 92 73 66 B6 79 .DB $92,$73,$66,$B6,$79,$51,$D9,$0F,$40
51 D9 0F 40
12172
12173 ; ATHP[1] = -5.600242872292477863751728708249167956542E4
12174 F88334 09 D6 41 CF B4 .DB $09,$D6,$41,$CF,$B4,$1F,$BF,$51,$3F
1F BF 51 3F
12175 F8833D F8 1C C9 C0 6D .DB $F8,$1C,$C9,$C0,$6D,$C2,$DA,$0E,$C0
C2 DA 0E C0
12176
12177 ; ATHP[0] = 1.188901082233997739779618679364295772810E4
12178 F88346 25 9B 90 FA 10 .DB $25,$9B,$90,$FA,$10,$5E,$5E,$62,$93
5E 5E 62 93
12179 F8834F 13 F1 02 15 0B .DB $13,$F1,$02,$15,$0B,$C4,$B9,$0C,$40
C4 B9 0C 40
12180
12181 F88358 cathq:
12182 ; ATHQ[9] = -6.807348436010016270202879229504392062418E1
12183 F88358 99 2F A4 39 46 .DB $99,$2F,$A4,$39,$46,$E2,$E3,$D8,$82
E2 E3 D8 82
12184 F88361 9D CB F6 BD 9F .DB $9D,$CB,$F6,$BD,$9F,$25,$88,$05,$C0
25 88 05 C0
12185
12186 ; ATHQ[8] = 1.386763299649315831625106608182196351693E3
12187 F8836A 85 34 75 16 4D .DB $85,$34,$75,$16,$4D,$4C,$65,$28,$33
4C 65 28 33
Tue Jul 17 11:00:18 2018 Page 178
12188 F88373 83 DB 62 F3 6C .DB $83,$DB,$62,$F3,$6C,$58,$AD,$09,$40
58 AD 09 40
12189
12190 ; ATHQ[7] = -1.310805752656879543134785263832907269320E4
12191 F8837C 10 00 DF D6 BA .DB $10,$00,$DF,$D6,$BA,$52,$8D,$F4,$87
52 8D F4 87
12192 F88385 82 AE 3E E8 3A .DB $82,$AE,$3E,$E8,$3A,$D0,$CC,$0C,$C0
D0 CC 0C C0
12193
12194 ; ATHQ[6] = 6.872174720355764193772953852564737816928E4
12195 F8838E 6E FA BF B3 EC .DB $6E,$FA,$BF,$B3,$EC,$33,$80,$DD,$73
33 80 DD 73
12196 F88397 C3 BD 5D A4 DF .DB $C3,$BD,$5D,$A4,$DF,$38,$86,$0F,$40
38 86 0F 40
12197
12198 ; ATHQ[5] = -2.181008360536226513009076189881617939380E5
12199 F883A0 F5 02 E5 97 FF .DB $F5,$02,$E5,$97,$FF,$97,$2A,$A0,$56
97 2A A0 56
12200 F883A9 BF 0D E7 81 35 .DB $BF,$0D,$E7,$81,$35,$FD,$D4,$10,$C0
FD D4 10 C0
12201
12202 ; ATHQ[4] = 4.362736119602298592874941767284979857248E5
12203 F883B2 61 1A B8 5B 6C .DB $61,$1A,$B8,$5B,$6C,$27,$7A,$54,$58
27 7A 54 58
12204 F883BB B6 9E 2D 95 33 .DB $B6,$9E,$2D,$95,$33,$06,$D5,$11,$40
06 D5 11 40
12205
12206 ; ATHQ[3] = -5.535251007539393347687001489396152923502E5
12207 F883C4 7F 3B 18 F4 58 .DB $7F,$3B,$18,$F4,$58,$AC,$E0,$0D,$2D
AC E0 0D 2D
12208 F883CD A6 29 B0 9C 51 .DB $A6,$29,$B0,$9C,$51,$23,$87,$12,$C0
23 87 12 C0
12209
12210 ; ATHQ[2] = 4.321594849688346708841188057241308805551E5
12211 F883D6 4B 52 86 98 30 .DB $4B,$52,$86,$98,$30,$13,$CC,$A2,$B3
13 CC A2 B3
12212 F883DF 8F 5C DD 84 EF .DB $8F,$5C,$DD,$84,$EF,$03,$D3,$11,$40
03 D3 11 40
12213
12214 ; ATHQ[1] = -1.894075056489862952285849974761239845873E5
12215 F883E8 03 9B EB F1 8F .DB $03,$9B,$EB,$F1,$8F,$F5,$F9,$11,$30
F5 F9 11 30
12216 F883F1 D9 90 8D 5C E0 .DB $D9,$90,$8D,$5C,$E0,$F7,$B8,$10,$C0
F7 B8 10 C0
12217
12218 ; ATHQ[0] = 3.566703246701993219338856038092901974725E4
12219 F883FA 02 11 F8 BB 8C .DB $02,$11,$F8,$BB,$8C,$C6,$C6,$89,$AE
C6 C6 89 AE
12220 F88403 CE 34 C2 4F 08 .DB $CE,$34,$C2,$4F,$08,$53,$8B,$0E,$40
53 8B 0E 40
12221
12222 ;---------------------------------------------------------------------------
12223 ; moving routines to/from fac/arg
12224 ;---------------------------------------------------------------------------
12225
12226 ; temporary registers tfr0..tfr5 are 20-bytes-sized register that can hold the
12227 ; full size 128 bits mantissa, the exponent, the sign and the byte status
Tue Jul 17 11:00:18 2018 Page 179
12228
12229 ; move arg to fac
12230 ;------
12231 F8840C mvatof:
12232 ;------
12233 F8840C INDEX16
12234 F8840C C2 10 rep #PXFLAG
12235 .LONGI on
12236 .MNLIST
12237 F8840E A6 2A ldx argm
12238 F88410 86 12 stx facm
12239 F88412 A6 2C ldx argm+2
12240 F88414 86 14 stx facm+2
12241 F88416 A6 2E ldx argm+4
12242 F88418 86 16 stx facm+4
12243 F8841A A6 30 ldx argm+6
12244 F8841C 86 18 stx facm+6
12245 F8841E A6 32 ldx argm+8
12246 F88420 86 1A stx facm+8
12247 F88422 A6 34 ldx argm+10
12248 F88424 86 1C stx facm+10
12249 F88426 A6 36 ldx argm+12
12250 F88428 86 1E stx facm+12
12251 F8842A A6 38 ldx argm+14
12252 F8842C 86 20 stx facm+14
12253 F8842E A6 3A ldx argexp
12254 F88430 86 22 stx facexp
12255 F88432 A6 3C ldx argsgn
12256 F88434 86 24 stx facsgn
12257 F88436 INDEX08
12258 F88436 E2 10 sep #PXFLAG
12259 .LONGI off
12260 .MNLIST
12261 F88438 60 rts
12262
12263 ; move fac to arg
12264 ;------
12265 F88439 mvftoa:
12266 ;------
12267 F88439 INDEX16
12268 F88439 C2 10 rep #PXFLAG
12269 .LONGI on
12270 .MNLIST
12271 F8843B A6 12 ldx facm
12272 F8843D 86 2A stx argm
12273 F8843F A6 14 ldx facm+2
12274 F88441 86 2C stx argm+2
12275 F88443 A6 16 ldx facm+4
12276 F88445 86 2E stx argm+4
12277 F88447 A6 18 ldx facm+6
12278 F88449 86 30 stx argm+6
12279 F8844B A6 1A ldx facm+8
12280 F8844D 86 32 stx argm+8
12281 F8844F A6 1C ldx facm+10
12282 F88451 86 34 stx argm+10
12283 F88453 A6 1E ldx facm+12
12284 F88455 86 36 stx argm+12
Tue Jul 17 11:00:18 2018 Page 180
12285 F88457 A6 20 ldx facm+14
12286 F88459 86 38 stx argm+14
12287 F8845B A6 22 ldx facexp
12288 F8845D 86 3A stx argexp
12289 F8845F A6 24 ldx facsgn
12290 F88461 86 3C stx argsgn
12291 F88463 INDEX08
12292 F88463 E2 10 sep #PXFLAG
12293 .LONGI off
12294 .MNLIST
12295 F88465 60 rts
12296
12297 ; move fac to temp. reg. tfr0
12298 ;------
12299 F88466 mvf_t0:
12300 ;------
12301 F88466 ACC16
12302 F88466 C2 20 rep #PMFLAG
12303 .LONGA on
12304 .MNLIST
12305 F88468 A5 12 lda facm
12306 F8846A 85 50 sta tfr0
12307 F8846C A5 14 lda facm+2
12308 F8846E 85 52 sta tfr0+2
12309 F88470 A5 16 lda facm+4
12310 F88472 85 54 sta tfr0+4
12311 F88474 A5 18 lda facm+6
12312 F88476 85 56 sta tfr0+6
12313 F88478 A5 1A lda facm+8
12314 F8847A 85 58 sta tfr0+8
12315 F8847C A5 1C lda facm+10
12316 F8847E 85 5A sta tfr0+10
12317 F88480 A5 1E lda facm+12
12318 F88482 85 5C sta tfr0+12
12319 F88484 A5 20 lda facm+14
12320 F88486 85 5E sta tfr0+14
12321 F88488 A5 22 lda facexp
12322 F8848A 85 60 sta tfr0+16
12323 F8848C A5 24 lda facsgn
12324 F8848E 85 62 sta tfr0+18
12325 F88490 ACC08
12326 F88490 E2 20 sep #PMFLAG
12327 .LONGA off
12328 .MNLIST
12329 F88492 60 rts
12330
12331 ; move fac to temp. reg. tfr1
12332 ;------
12333 F88493 mvf_t1:
12334 ;------
12335 F88493 ACC16
12336 F88493 C2 20 rep #PMFLAG
12337 .LONGA on
12338 .MNLIST
12339 F88495 A5 12 lda facm
12340 F88497 85 64 sta tfr1
12341 F88499 A5 14 lda facm+2
Tue Jul 17 11:00:18 2018 Page 181
12342 F8849B 85 66 sta tfr1+2
12343 F8849D A5 16 lda facm+4
12344 F8849F 85 68 sta tfr1+4
12345 F884A1 A5 18 lda facm+6
12346 F884A3 85 6A sta tfr1+6
12347 F884A5 A5 1A lda facm+8
12348 F884A7 85 6C sta tfr1+8
12349 F884A9 A5 1C lda facm+10
12350 F884AB 85 6E sta tfr1+10
12351 F884AD A5 1E lda facm+12
12352 F884AF 85 70 sta tfr1+12
12353 F884B1 A5 20 lda facm+14
12354 F884B3 85 72 sta tfr1+14
12355 F884B5 A5 22 lda facexp
12356 F884B7 85 74 sta tfr1+16
12357 F884B9 A5 24 lda facsgn
12358 F884BB 85 76 sta tfr1+18
12359 F884BD ACC08
12360 F884BD E2 20 sep #PMFLAG
12361 .LONGA off
12362 .MNLIST
12363 F884BF 60 rts
12364
12365 ; move fac to temp. reg. tfr2
12366 ;------
12367 F884C0 mvf_t2:
12368 ;------
12369 F884C0 ACC16
12370 F884C0 C2 20 rep #PMFLAG
12371 .LONGA on
12372 .MNLIST
12373 F884C2 A5 12 lda facm
12374 F884C4 85 78 sta tfr2
12375 F884C6 A5 14 lda facm+2
12376 F884C8 85 7A sta tfr2+2
12377 F884CA A5 16 lda facm+4
12378 F884CC 85 7C sta tfr2+4
12379 F884CE A5 18 lda facm+6
12380 F884D0 85 7E sta tfr2+6
12381 F884D2 A5 1A lda facm+8
12382 F884D4 85 80 sta tfr2+8
12383 F884D6 A5 1C lda facm+10
12384 F884D8 85 82 sta tfr2+10
12385 F884DA A5 1E lda facm+12
12386 F884DC 85 84 sta tfr2+12
12387 F884DE A5 20 lda facm+14
12388 F884E0 85 86 sta tfr2+14
12389 F884E2 A5 22 lda facexp
12390 F884E4 85 88 sta tfr2+16
12391 F884E6 A5 24 lda facsgn
12392 F884E8 85 8A sta tfr2+18
12393 F884EA ACC08
12394 F884EA E2 20 sep #PMFLAG
12395 .LONGA off
12396 .MNLIST
12397 F884EC 60 rts
12398
Tue Jul 17 11:00:18 2018 Page 182
12399 ; move fac to temp. reg. tfr3
12400 ;------
12401 F884ED mvf_t3:
12402 ;------
12403 F884ED ACC16
12404 F884ED C2 20 rep #PMFLAG
12405 .LONGA on
12406 .MNLIST
12407 F884EF A5 12 lda facm
12408 F884F1 85 8C sta tfr3
12409 F884F3 A5 14 lda facm+2
12410 F884F5 85 8E sta tfr3+2
12411 F884F7 A5 16 lda facm+4
12412 F884F9 85 90 sta tfr3+4
12413 F884FB A5 18 lda facm+6
12414 F884FD 85 92 sta tfr3+6
12415 F884FF A5 1A lda facm+8
12416 F88501 85 94 sta tfr3+8
12417 F88503 A5 1C lda facm+10
12418 F88505 85 96 sta tfr3+10
12419 F88507 A5 1E lda facm+12
12420 F88509 85 98 sta tfr3+12
12421 F8850B A5 20 lda facm+14
12422 F8850D 85 9A sta tfr3+14
12423 F8850F A5 22 lda facexp
12424 F88511 85 9C sta tfr3+16
12425 F88513 A5 24 lda facsgn
12426 F88515 85 9E sta tfr3+18
12427 F88517 ACC08
12428 F88517 E2 20 sep #PMFLAG
12429 .LONGA off
12430 .MNLIST
12431 F88519 60 rts
12432
12433 ; move arg to temp. reg. tfr0
12434 ;------
12435 F8851A mva_t0:
12436 ;------
12437 F8851A ACC16
12438 F8851A C2 20 rep #PMFLAG
12439 .LONGA on
12440 .MNLIST
12441 F8851C A5 2A lda argm
12442 F8851E 85 50 sta tfr0
12443 F88520 A5 2C lda argm+2
12444 F88522 85 52 sta tfr0+2
12445 F88524 A5 2E lda argm+4
12446 F88526 85 54 sta tfr0+4
12447 F88528 A5 30 lda argm+6
12448 F8852A 85 56 sta tfr0+6
12449 F8852C A5 32 lda argm+8
12450 F8852E 85 58 sta tfr0+8
12451 F88530 A5 34 lda argm+10
12452 F88532 85 5A sta tfr0+10
12453 F88534 A5 36 lda argm+12
12454 F88536 85 5C sta tfr0+12
12455 F88538 A5 38 lda argm+14
Tue Jul 17 11:00:18 2018 Page 183
12456 F8853A 85 5E sta tfr0+14
12457 F8853C A5 3A lda argexp
12458 F8853E 85 60 sta tfr0+16
12459 F88540 A5 3C lda argsgn
12460 F88542 85 62 sta tfr0+18
12461 F88544 ACC08
12462 F88544 E2 20 sep #PMFLAG
12463 .LONGA off
12464 .MNLIST
12465 F88546 60 rts
12466
12467 ; move temp. reg. tfr0 to fac
12468 ;------
12469 F88547 mvt0_f:
12470 ;------
12471 F88547 ACC16
12472 F88547 C2 20 rep #PMFLAG
12473 .LONGA on
12474 .MNLIST
12475 F88549 A5 50 lda tfr0
12476 F8854B 85 12 sta facm
12477 F8854D A5 52 lda tfr0+2
12478 F8854F 85 14 sta facm+2
12479 F88551 A5 54 lda tfr0+4
12480 F88553 85 16 sta facm+4
12481 F88555 A5 56 lda tfr0+6
12482 F88557 85 18 sta facm+6
12483 F88559 A5 58 lda tfr0+8
12484 F8855B 85 1A sta facm+8
12485 F8855D A5 5A lda tfr0+10
12486 F8855F 85 1C sta facm+10
12487 F88561 A5 5C lda tfr0+12
12488 F88563 85 1E sta facm+12
12489 F88565 A5 5E lda tfr0+14
12490 F88567 85 20 sta facm+14
12491 F88569 A5 60 lda tfr0+16
12492 F8856B 85 22 sta facexp
12493 F8856D A5 62 lda tfr0+18
12494 F8856F 85 24 sta facsgn
12495 F88571 ACC08
12496 F88571 E2 20 sep #PMFLAG
12497 .LONGA off
12498 .MNLIST
12499 F88573 60 rts
12500
12501 ; move temp. reg. tfr1 to fac
12502 ;------
12503 F88574 mvt1_f:
12504 ;------
12505 F88574 ACC16
12506 F88574 C2 20 rep #PMFLAG
12507 .LONGA on
12508 .MNLIST
12509 F88576 A5 64 lda tfr1
12510 F88578 85 12 sta facm
12511 F8857A A5 66 lda tfr1+2
12512 F8857C 85 14 sta facm+2
Tue Jul 17 11:00:18 2018 Page 184
12513 F8857E A5 68 lda tfr1+4
12514 F88580 85 16 sta facm+4
12515 F88582 A5 6A lda tfr1+6
12516 F88584 85 18 sta facm+6
12517 F88586 A5 6C lda tfr1+8
12518 F88588 85 1A sta facm+8
12519 F8858A A5 6E lda tfr1+10
12520 F8858C 85 1C sta facm+10
12521 F8858E A5 70 lda tfr1+12
12522 F88590 85 1E sta facm+12
12523 F88592 A5 72 lda tfr1+14
12524 F88594 85 20 sta facm+14
12525 F88596 A5 74 lda tfr1+16
12526 F88598 85 22 sta facexp
12527 F8859A A5 76 lda tfr1+18
12528 F8859C 85 24 sta facsgn
12529 F8859E ACC08
12530 F8859E E2 20 sep #PMFLAG
12531 .LONGA off
12532 .MNLIST
12533 F885A0 60 rts
12534
12535 ; move temp. reg. tfr2 to fac
12536 ;------
12537 F885A1 mvt2_f:
12538 ;------
12539 F885A1 ACC16
12540 F885A1 C2 20 rep #PMFLAG
12541 .LONGA on
12542 .MNLIST
12543 F885A3 A5 78 lda tfr2
12544 F885A5 85 12 sta facm
12545 F885A7 A5 7A lda tfr2+2
12546 F885A9 85 14 sta facm+2
12547 F885AB A5 7C lda tfr2+4
12548 F885AD 85 16 sta facm+4
12549 F885AF A5 7E lda tfr2+6
12550 F885B1 85 18 sta facm+6
12551 F885B3 A5 80 lda tfr2+8
12552 F885B5 85 1A sta facm+8
12553 F885B7 A5 82 lda tfr2+10
12554 F885B9 85 1C sta facm+10
12555 F885BB A5 84 lda tfr2+12
12556 F885BD 85 1E sta facm+12
12557 F885BF A5 86 lda tfr2+14
12558 F885C1 85 20 sta facm+14
12559 F885C3 A5 88 lda tfr2+16
12560 F885C5 85 22 sta facexp
12561 F885C7 A5 8A lda tfr2+18
12562 F885C9 85 24 sta facsgn
12563 F885CB ACC08
12564 F885CB E2 20 sep #PMFLAG
12565 .LONGA off
12566 .MNLIST
12567 F885CD 60 rts
12568 F885CE
12569 ; move temp. reg. tfr0 to arg
Tue Jul 17 11:00:18 2018 Page 185
12570 ;------
12571 F885CE mvt0_a:
12572 ;------
12573 F885CE ACC16
12574 F885CE C2 20 rep #PMFLAG
12575 .LONGA on
12576 .MNLIST
12577 F885D0 A5 50 lda tfr0
12578 F885D2 85 2A sta argm
12579 F885D4 A5 52 lda tfr0+2
12580 F885D6 85 2C sta argm+2
12581 F885D8 A5 54 lda tfr0+4
12582 F885DA 85 2E sta argm+4
12583 F885DC A5 56 lda tfr0+6
12584 F885DE 85 30 sta argm+6
12585 F885E0 A5 58 lda tfr0+8
12586 F885E2 85 32 sta argm+8
12587 F885E4 A5 5A lda tfr0+10
12588 F885E6 85 34 sta argm+10
12589 F885E8 A5 5C lda tfr0+12
12590 F885EA 85 36 sta argm+12
12591 F885EC A5 5E lda tfr0+14
12592 F885EE 85 38 sta argm+14
12593 F885F0 A5 60 lda tfr0+16
12594 F885F2 85 3A sta argexp
12595 F885F4 A5 62 lda tfr0+18
12596 F885F6 85 3C sta argsgn
12597 F885F8 ACC08
12598 F885F8 E2 20 sep #PMFLAG
12599 .LONGA off
12600 .MNLIST
12601 F885FA 60 rts
12602
12603 ; move temp. reg. tfr1 to arg
12604 ;------
12605 F885FB mvt1_a:
12606 ;------
12607 F885FB ACC16
12608 F885FB C2 20 rep #PMFLAG
12609 .LONGA on
12610 .MNLIST
12611 F885FD A5 64 lda tfr1
12612 F885FF 85 2A sta argm
12613 F88601 A5 66 lda tfr1+2
12614 F88603 85 2C sta argm+2
12615 F88605 A5 68 lda tfr1+4
12616 F88607 85 2E sta argm+4
12617 F88609 A5 6A lda tfr1+6
12618 F8860B 85 30 sta argm+6
12619 F8860D A5 6C lda tfr1+8
12620 F8860F 85 32 sta argm+8
12621 F88611 A5 6E lda tfr1+10
12622 F88613 85 34 sta argm+10
12623 F88615 A5 70 lda tfr1+12
12624 F88617 85 36 sta argm+12
12625 F88619 A5 72 lda tfr1+14
12626 F8861B 85 38 sta argm+14
Tue Jul 17 11:00:18 2018 Page 186
12627 F8861D A5 74 lda tfr1+16
12628 F8861F 85 3A sta argexp
12629 F88621 A5 76 lda tfr1+18
12630 F88623 85 3C sta argsgn
12631 F88625 ACC08
12632 F88625 E2 20 sep #PMFLAG
12633 .LONGA off
12634 .MNLIST
12635 F88627 60 rts
12636
12637 ; move temp. reg. tfr2 to arg
12638 ;------
12639 F88628 mvt2_a:
12640 ;------
12641 F88628 ACC16
12642 F88628 C2 20 rep #PMFLAG
12643 .LONGA on
12644 .MNLIST
12645 F8862A A5 78 lda tfr2
12646 F8862C 85 2A sta argm
12647 F8862E A5 7A lda tfr2+2
12648 F88630 85 2C sta argm+2
12649 F88632 A5 7C lda tfr2+4
12650 F88634 85 2E sta argm+4
12651 F88636 A5 7E lda tfr2+6
12652 F88638 85 30 sta argm+6
12653 F8863A A5 80 lda tfr2+8
12654 F8863C 85 32 sta argm+8
12655 F8863E A5 82 lda tfr2+10
12656 F88640 85 34 sta argm+10
12657 F88642 A5 84 lda tfr2+12
12658 F88644 85 36 sta argm+12
12659 F88646 A5 86 lda tfr2+14
12660 F88648 85 38 sta argm+14
12661 F8864A A5 88 lda tfr2+16
12662 F8864C 85 3A sta argexp
12663 F8864E A5 8A lda tfr2+18
12664 F88650 85 3C sta argsgn
12665 F88652 ACC08
12666 F88652 E2 20 sep #PMFLAG
12667 .LONGA off
12668 .MNLIST
12669 F88654 60 rts
12670
12671 ; move temp. reg. tfr3 to arg
12672 ;------
12673 F88655 mvt3_a:
12674 ;------
12675 F88655 ACC16
12676 F88655 C2 20 rep #PMFLAG
12677 .LONGA on
12678 .MNLIST
12679 F88657 A5 8C lda tfr3
12680 F88659 85 2A sta argm
12681 F8865B A5 8E lda tfr3+2
12682 F8865D 85 2C sta argm+2
12683 F8865F A5 90 lda tfr3+4
Tue Jul 17 11:00:18 2018 Page 187
12684 F88661 85 2E sta argm+4
12685 F88663 A5 92 lda tfr3+6
12686 F88665 85 30 sta argm+6
12687 F88667 A5 94 lda tfr3+8
12688 F88669 85 32 sta argm+8
12689 F8866B A5 96 lda tfr3+10
12690 F8866D 85 34 sta argm+10
12691 F8866F A5 98 lda tfr3+12
12692 F88671 85 36 sta argm+12
12693 F88673 A5 9A lda tfr3+14
12694 F88675 85 38 sta argm+14
12695 F88677 A5 9C lda tfr3+16
12696 F88679 85 3A sta argexp
12697 F8867B A5 9E lda tfr3+18
12698 F8867D 85 3C sta argsgn
12699 F8867F ACC08
12700 F8867F E2 20 sep #PMFLAG
12701 .LONGA off
12702 .MNLIST
12703 F88681 60 rts
12704
12705 ; ldfac - load fac with a constant K stored in program memory
12706 ;
12707 ; entry:
12708 ; A = low address of constant K
12709 ; Y = high address of constant K
12710 ;
12711 ; exit:
12712 ; fac = K
12713 ;
12714 ; This routine is used internally and not intended for end use.
12715 ; Constant are stored unpacked, and with full size 128 bits mantissa,
12716 ; in program memory segment(the code segment that hold this routine).
12717 ;
12718 ;-----
12719 F88682 ldfac:
12720 ;-----
12721 F88682 85 42 sta fcp ; set long pointer to K
12722 F88684 84 43 sty fcp+1
12723 F88686 A9 F8 lda #.SEG.ldfac
12724 F88688 85 44 sta fcp+2
12725 F8868A A2 00 ldx #0
12726 F8868C 86 25 stx facst ; always assume valid K
12727 F8868E ACC16
12728 F8868E C2 20 rep #PMFLAG
12729 .LONGA on
12730 .MNLIST
12731 F88690 A7 42 lda [fcp] ; set mantissa
12732 F88692 85 12 sta facm
12733 F88694 A0 02 ldy #2
12734 F88696 B7 42 lda [fcp],y
12735 F88698 85 14 sta facm+2
12736 F8869A A0 04 ldy #4
12737 F8869C B7 42 lda [fcp],y
12738 F8869E 85 16 sta facm+4
12739 F886A0 A0 06 ldy #6
12740 F886A2 B7 42 lda [fcp],y
Tue Jul 17 11:00:18 2018 Page 188
12741 F886A4 85 18 sta facm+6
12742 F886A6 A0 08 ldy #8
12743 F886A8 B7 42 lda [fcp],y
12744 F886AA 85 1A sta facm+8
12745 F886AC A0 0A ldy #10
12746 F886AE B7 42 lda [fcp],y
12747 F886B0 85 1C sta facm+10
12748 F886B2 A0 0C ldy #12
12749 F886B4 B7 42 lda [fcp],y
12750 F886B6 85 1E sta facm+12
12751 F886B8 A0 0E ldy #14
12752 F886BA B7 42 lda [fcp],y
12753 F886BC 85 20 sta facm+14
12754 F886BE A0 10 ldy #16
12755 F886C0 B7 42 lda [fcp],y
12756 F886C2 10 01 bpl ?p
12757 F886C4 CA dex
12758 F886C5 29 FF 7F ?p: and #$7FFF
12759 F886C8 85 22 sta facexp ; set exponent
12760 F886CA ACC08
12761 F886CA E2 20 sep #PMFLAG
12762 .LONGA off
12763 .MNLIST
12764 F886CC 86 24 stx facsgn ; set sign
12765 F886CE 60 rts
12766 F886CF
12767 ; ldarg - load arg with a constant K stored in program memory
12768 ;
12769 ; entry:
12770 ; A = low address of constant K
12771 ; Y = high address of constant K
12772 ;
12773 ; exit:
12774 ; arg = K
12775 ;
12776 ; This routine is used internally and not intended for end use.
12777 ; Constant are stored unpacked, and with full size 128 bits mantissa,
12778 ; in program memory segment(the code segment that hold this routine).
12779 ;
12780 F886CF ldarg:
12781 F886CF 85 42 sta fcp ; set long pointer to K
12782 F886D1 84 43 sty fcp+1
12783 F886D3 A9 F8 lda #.SEG.ldarg
12784 F886D5 85 44 sta fcp+2
12785
12786 ; ldarg2 - entry if long pointer fcp was already set
12787 F886D7 ldarg2:
12788 F886D7 A2 00 ldx #0
12789 F886D9 86 3D stx argst ; always assume valid K
12790 F886DB ACC16
12791 F886DB C2 20 rep #PMFLAG
12792 .LONGA on
12793 .MNLIST
12794 F886DD A7 42 lda [fcp] ; set mantissa
12795 F886DF 85 2A sta argm
12796 F886E1 A0 02 ldy #2
12797 F886E3 B7 42 lda [fcp],y
Tue Jul 17 11:00:18 2018 Page 189
12798 F886E5 85 2C sta argm+2
12799 F886E7 A0 04 ldy #4
12800 F886E9 B7 42 lda [fcp],y
12801 F886EB 85 2E sta argm+4
12802 F886ED A0 06 ldy #6
12803 F886EF B7 42 lda [fcp],y
12804 F886F1 85 30 sta argm+6
12805 F886F3 A0 08 ldy #8
12806 F886F5 B7 42 lda [fcp],y
12807 F886F7 85 32 sta argm+8
12808 F886F9 A0 0A ldy #10
12809 F886FB B7 42 lda [fcp],y
12810 F886FD 85 34 sta argm+10
12811 F886FF A0 0C ldy #12
12812 F88701 B7 42 lda [fcp],y
12813 F88703 85 36 sta argm+12
12814 F88705 A0 0E ldy #14
12815 F88707 B7 42 lda [fcp],y
12816 F88709 85 38 sta argm+14
12817 F8870B A0 10 ldy #16
12818 F8870D B7 42 lda [fcp],y
12819 F8870F 10 01 bpl ?p
12820 F88711 CA dex
12821 F88712 29 FF 7F ?p: and #$7FFF
12822 F88715 85 3A sta argexp ; set exponent
12823 F88717 ACC08
12824 F88717 E2 20 sep #PMFLAG
12825 .LONGA off
12826 .MNLIST
12827 F88719 86 3C stx argsgn ; set sign
12828 F8871B 60 rts
12829
12830 ;----------------------------------------------------------------------------
12831 ; polynomial evaluatation
12832 ;----------------------------------------------------------------------------
12833
12834 ; peval - evaluate polynomial of degree N
12835 ;
12836 ; entry:
12837 ; A = low address of coefficient C
12838 ; N
12839 ;
12840 ; Y = high address of coefficient C
12841 ; N
12842 ; X = degree (N)
12843 ; tfr0 = x (temp. register #0)
12844 ;
12845 ; exit: 2 N
12846 ; fac = y = C + C x + C x +...+ C x
12847 ; 0 1 2 N
12848 ;
12849 ; Constant Cn..C0 are stored unpacked, and with full size 128 bits mantissa,
12850 ; in program memory segment(the code segment that hold this routine), from
12851 ; the highest order Cn to lowest order C0.
12852 ;
12853 ;-----
12854 F8871C peval:
Tue Jul 17 11:00:18 2018 Page 190
12855 ;-----
12856 F8871C 86 4B stx pdeg
12857 F8871E 20 82 86 jsr ldfac ; fac=coefficient Cn
12858 F88721 20 CE 85 ?lp: jsr mvt0_a ; arg=tfr0
12859 F88724 20 DD 49 jsr fpmult ; multiplies by x
12860 F88727 ACC16CLC
12861 F88727 C2 21 rep #(PMFLAG.OR.PCFLAG)
12862 .LONGA on
12863 .MNLIST
12864 F88729 A5 42 lda fcp ; next coefficient
12865 F8872B 69 12 00 adc #FCSIZ
12866 F8872E 85 42 sta fcp
12867 F88730 ACC08
12868 F88730 E2 20 sep #PMFLAG
12869 .LONGA off
12870 .MNLIST
12871 F88732 20 7A 45 jsr fcadd ; add coefficient Ck
12872 F88735 C6 4B dec pdeg
12873 F88737 D0 E8 bne ?lp
12874 F88739 60 rts
12875
12876 ; pevalp1 - evaluate polynomial of degree N+1
12877 ;
12878 ; entry:
12879 ; A = low address of coefficient C
12880 ; N
12881 ;
12882 ; Y = high address of coefficient C
12883 ; N
12884 ; X = degree - 1 (N)
12885 ; tfr0 = x (temp. register #0)
12886 ;
12887 ; exit: 2 N N+1
12888 ; fac = y = C + C x + C x +...+ C x + x
12889 ; 0 1 2 N
12890 ;
12891 ; Constant Cn..C0 are stored unpacked, and with full size 128 bits mantissa,
12892 ; in program memory segment(the code segment that hold this routine), from
12893 ; the highest order Cn to lowest order C0.
12894 ;
12895 ;-------
12896 F8873A pevalp1:
12897 ;-------
12898 F8873A 86 4B stx pdeg
12899 F8873C 20 82 86 jsr ldfac ; coefficient Cn
12900 F8873F 20 CE 85 jsr mvt0_a ; arg=tfr0
12901 F88742 20 7D 45 jsr fpadd ; x + Cn
12902 F88745 20 CE 85 ?lp: jsr mvt0_a ; loop
12903 F88748 20 DD 49 jsr fpmult ; multiplies by x
12904 F8874B ACC16CLC
12905 F8874B C2 21 rep #(PMFLAG.OR.PCFLAG)
12906 .LONGA on
12907 .MNLIST
12908 F8874D A5 42 lda fcp ; next coefficient
12909 F8874F 69 12 00 adc #FCSIZ
12910 F88752 85 42 sta fcp
12911 F88754 ACC08
Tue Jul 17 11:00:18 2018 Page 191
12912 F88754 E2 20 sep #PMFLAG
12913 .LONGA off
12914 .MNLIST
12915 F88756 20 7A 45 jsr fcadd ; add coefficient Ck
12916 F88759 C6 4B dec pdeg
12917 F8875B D0 E8 bne ?lp
12918 F8875D 60 rts
12919
12920 ;----------------------------------------------------------------------------
12921 ; utilities & helper routines
12922 ;----------------------------------------------------------------------------
12923
12924 ; fccmp - compare fac versus a constant stored in program memory
12925 ;
12926 ; entry:
12927 ; fac = x
12928 ; A = low address of constant K
12929 ; Y = high address of constant K
12930 ;
12931 ; exit:
12932 ; if fac < K: ZF=0,NF=1
12933 ; if fac = K: ZF=1,NF=0
12934 ; if fac > K: ZF=0,NF=0
12935 ;
12936 ; This routine is used internally and not intended for end use.
12937 ; Constant are stored unpacked, and with full size 128 bits mantissa,
12938 ; in program memory segment(the code segment that hold this routine).
12939 ;
12940 ;-----
12941 F8875E fccmp:
12942 ;-----
12943 F8875E 85 42 sta fcp ; set long pointer to K
12944 F88760 84 43 sty fcp+1
12945 F88762 A9 F8 lda #.SEG.fccmp
12946 F88764 85 44 sta fcp+2
12947 F88766 A0 11 ldy #17
12948 F88768 B7 42 lda [fcp],y ; K sign
12949 F8876A 45 24 eor facsgn ; compare with fac sign
12950 F8876C 10 04 bpl ?same ; sign match
12951 F8876E A5 24 lda facsgn ; sign unmatch so return...
12952 F88770 80 54 bra ?sgn ; ...fac sign
12953 F88772 ?same: ACC16
12954 F88772 C2 20 rep #PMFLAG
12955 .LONGA on
12956 .MNLIST
12957 F88774 88 dey
12958 F88775 B7 42 lda [fcp],y ; biased exponent
12959 F88777 29 FF 7F and #$7FFF ; mask off sign
12960 F8877A C5 22 cmp facexp
12961 F8877C 90 3E bcc ?chk ; fac > K (CF=0)
12962 F8877E D0 3C bne ?chk ; fac < K (CF=1)
12963 F88780 A0 0E ldy #14 ; same exponent so now compare mantissa
12964 F88782 B7 42 lda [fcp],y
12965 F88784 C5 20 cmp facm+14
12966 F88786 D0 34 bne ?chk ; CF=0 if fac>K else CF=1 if fac<K
12967 F88788 A0 0C ldy #12
12968 F8878A B7 42 lda [fcp],y
Tue Jul 17 11:00:18 2018 Page 192
12969 F8878C C5 1E cmp facm+12
12970 F8878E D0 2C bne ?chk
12971 F88790 A0 0A ldy #10
12972 F88792 B7 42 lda [fcp],y
12973 F88794 C5 1C cmp facm+10
12974 F88796 D0 24 bne ?chk
12975 F88798 A0 08 ldy #8
12976 F8879A B7 42 lda [fcp],y
12977 F8879C C5 1A cmp facm+8
12978 F8879E D0 1C bne ?chk
12979 F887A0 A0 06 ldy #6
12980 F887A2 B7 42 lda [fcp],y
12981 F887A4 C5 18 cmp facm+6
12982 F887A6 D0 14 bne ?chk
12983 F887A8 A0 04 ldy #4
12984 F887AA B7 42 lda [fcp],y
12985 F887AC C5 16 cmp facm+4
12986 F887AE D0 0C bne ?chk
12987 F887B0 A0 02 ldy #2
12988 F887B2 B7 42 lda [fcp],y
12989 F887B4 C5 14 cmp facm+2
12990 F887B6 D0 04 bne ?chk
12991 F887B8 A7 42 lda [fcp]
12992 F887BA C5 12 cmp facm
12993 F887BC ?chk: ACC08
12994 F887BC E2 20 sep #PMFLAG
12995 .LONGA off
12996 .MNLIST
12997 F887BE F0 0D beq ?done ; fac=K so return ZF=1
12998 F887C0 A5 24 lda facsgn
12999 F887C2 90 02 bcc ?sgn ; fac>K
13000 F887C4 49 FF eor #$FF ; invert sign (fac<K)
13001 F887C6 2A ?sgn: rol a ; CF=sign
13002 F887C7 A9 FF lda #$FF ; NF=1 if fac<K
13003 F887C9 B0 02 bcs ?done
13004 F887CB A9 01 lda #1 ; NF=0 if fac>K
13005 F887CD 60 ?done: rts
13006
13007 ; signed multiplication 16 bit
13008 ;
13009 ; entry: C = multiplicand 1 16 bit
13010 ; X = multiplicand 2 low byte
13011 ; Y = multiplicand 2 high byte
13012 ;
13013 ; exit: C = result high word
13014 ; X = result low-low byte
13015 ; Y = result low-high byte
13016 ;
13017 ; call with A in 16 bit mode
13018 ;
13019 ;-----
13020 F887CE imult:
13021 ;-----
13022 .LONGA on
13023 .LONGI off
13024
13025 F887CE 85 BC sta mcand1 ; store mcand1&mcand2
Tue Jul 17 11:00:18 2018 Page 193
13026 F887D0 86 BE stx mcand2
13027 F887D2 84 BF sty mcand2+1
13028 F887D4 45 BE eor mcand2 ; sign of the result
13029 F887D6 85 C0 sta mcsgn
13030 F887D8 A2 00 ldx #0
13031 F887DA A4 BD ldy mcand1+1
13032 F887DC 10 06 bpl ?p1 ; mcand1 is positive
13033 F887DE 38 sec
13034 F887DF 8A txa
13035 F887E0 E5 BC sbc mcand1 ; complement mcand1
13036 F887E2 85 BC sta mcand1
13037 F887E4 A4 BF ?p1: ldy mcand2+1
13038 F887E6 10 06 bpl ?p2 ; mcand2 is positive
13039 F887E8 38 sec
13040 F887E9 8A txa
13041 F887EA E5 BE sbc mcand2 ; complement mcand2
13042 F887EC 85 BE sta mcand2
13043 F887EE 8A ?p2: txa ; clear high word of result
13044 F887EF A2 11 ldx #17 ; 17 bit loop
13045 F887F1 18 clc
13046 F887F2 6A ?shr: ror a ; shift in any carry - high result
13047 F887F3 66 BC ror mcand1 ; low result
13048 F887F5 90 03 bcc ?no ; no add
13049 F887F7 18 clc
13050 F887F8 65 BE adc mcand2
13051 F887FA CA ?no: dex
13052 F887FB D0 F5 bne ?shr ; repeat
13053 F887FD 85 BE sta mcand2 ; store result high
13054 F887FF 24 C0 bit mcsgn ; if result is positive...
13055 F88801 10 09 bpl ?done ; ...done (C=result high)
13056 F88803 8A txa
13057 F88804 38 sec ; else complement result
13058 F88805 E5 BC sbc mcand1
13059 F88807 85 BC sta mcand1
13060 F88809 8A txa
13061 F8880A E5 BE sbc mcand2 ; C=result high word
13062 F8880C A6 BC ?done: ldx mcand1 ; X=result low-low byte
13063 F8880E A4 BD ldy mcand1+1 ; Y=result low-high byte
13064 F88810 60 rts
13065
13066 .LONGA off
13067
13068 ; unsigned division 16 bit
13069 ;
13070 ; entry: C = 16 bit dividend
13071 ; X = 16 bit divisor
13072 ;
13073 ; exit: C = 16 bit quotient
13074 ; Y = 16 bits remainder
13075 ;
13076 ; use: all
13077 ;
13078 ; note: no check for null divisor
13079 ;
13080 ; call in 16 bit mode
13081 ;-----
13082 F88811 udiv:
Tue Jul 17 11:00:18 2018 Page 194
13083 ;-----
13084 .LONGA on
13085 .LONGI on
13086
13087 F88811 86 C2 stx dvsor ; divisor
13088 F88813 A8 tay ; Y=dividend
13089 F88814 64 C4 stz quot ; init quotient
13090 F88816 8A txa ; C=divisor
13091 F88817 A2 01 00 ldx #1 ; bit counter
13092 F8881A 0A ?shd: asl a ; shift divisor: get leftmost bit
13093 F8881B B0 06 bcs ?div ; go to division
13094 F8881D E8 inx
13095 F8881E E0 11 00 cpx #17 ; test all divisor bit's
13096 F88821 D0 F7 bne ?shd
13097 F88823 6A ?div: ror a ; put shifted-out bit back
13098 F88824 85 C2 sta dvsor
13099 F88826 98 ?sub: tya ; get dividend
13100 F88827 38 sec
13101 F88828 E5 C2 sbc dvsor
13102 F8882A 90 01 bcc ?no ; can't subctract, retain old dividend
13103 F8882C A8 tay ; Y=new dividend
13104 F8882D 26 C4 ?no: rol quot ; shift carry into quotient (1 if division)
13105 F8882F 46 C2 lsr dvsor ; shift right divisor for next subtract
13106 F88831 CA dex
13107 F88832 D0 F2 bne ?sub ; repeat
13108 F88834 84 C2 sty dvsor ; store remainder
13109 F88836 A5 C4 lda quot ; C=quotient
13110 F88838 60 rts
13111
13112 .LONGA off
13113 .LONGI off
13114
13115 0042DE CODESIZ .EQU $ - fcsub +1
13116
13117 ; end of file
Lines Assembled : 12356 Errors : 0