Code: Select all
;================= R10 Declarations and Procedures=================
;
;Include this code to use the FPU with double extended precision
;Enable 'Inline ASM support' in the compiler option window.
;
;This allows calculations up to 18 decimal digit accuracy
;Variables are stored as 80 bit r10 type (same as FPU)
;Variables must be in the range 1.0e4900 to 1.0e-4900
;
; CHANGES HISTORY
; ===============
;
; 3 Apr 2003
; Procedures created by tejon
;14 May 2003
; Geoff made these changes:
; 1) Prefixed all globals and procedure names with "R10" so they
; don't clash with names in user programs.
; 2) Fixed several minor bugs
; 3) Changed r10atof() to fix bugs and make clearer
; 3) Replaced xtoy() and xtoy1() with a single faster procedure
; 4) Corrected r10ftoa and added 3 format options (see procedure)
; Fixed scientific
; Fixed decimal places
; Fixed significant figures
; 5) Tested all routines with at least one set of input values
; and found them all accurate to +- 5 in the 18th significant
; digit (most procedures are accurate to +- 1)
;18 May 2003
; r10antilog(),r10exp() improved
; r10ftoa() variable order reversed
;20 May 2003
; r10asin(),r10acos() improved
; r10int() changed, now rounds towards -inf same as PB int()
; r10comp() added to allow branching in r10 routines
;
;
;
;Declare r10 variable type (double extended precision floats)
Structure r10
StructureUnion
fword.w[5]
tbyte.b[10]
EndStructureUnion
EndStructure
;
;Declare r10 procedures
Declare r10acos(*x.r10,*y.r10); x=acos(y)
Declare r10add(*x.r10,*y.r10,*z.r10); x=y+z
Declare r10antilog(*x.r10,*y.r10); x=10^y
Declare r10asin(*x.r10,*y.r10); x=asin(y)
Declare r10atan(*x.r10,*y.r10); x=atan(y)
Declare r10atof(*x.r10,a$); string to r10
Declare r10copy(*x.r10,*y.r10); x=y
Declare.l r10comp(*x.r10,*y.r10); compare x and y
Declare r10cos(*x.r10,*y.r10); x=cos(y)
Declare r10div(*x.r10,*y.r10,*z.r10); x=y/z
Declare r10recip(*x.r10,*y.r10); x=1/y
Declare r10exp(*x.r10,*y.r10); x=e^y
Declare r10frac(*x.r10,*y.r10); x=frac(y)
Declare.s r10ftoa(*x.r10,format.l); r10 to string
Declare r10int(*x.r10,*y.r10); x=int(y)
Declare r10ln(*x.r10,*y.r10); x=ln(y)
Declare r10log10(*x.r10,*y.r10); x=log10(y)
Declare r10mul(*x.r10,*y.r10,*z.r10); x=y*z
Declare r10pi(*x.r10); x=Pi
Declare r10power(*x.r10,e.w); x=x^(y.w)
Declare r10sin(*x.r10,*y.r10); x=sin(y)
Declare r10sqrt(*x.r10,*y.r10); x=sqrt(y)
Declare r10sub(*x.r10,*y.r10,*z.r10); x=y-z
Declare r10tan(*x.r10,*y.r10); x=tan(y)
Declare r10xtoy(*x.r10,*y.r10,*z.r10);x=y^z
;
;Define r10 constants
Global r10ten.r10;used by 10^x
Global r10e.r10;used by e^x
r10atof(@r10ten,"10")
r10atof(@r10e,"2.71828182845904523")
;
;
;R10 procedures in alphabetical order
Procedure r10acos(*x.r10,*y.r10);x=acos(y)
FINIT
MOV ebx,*y
! fld tword [ebx]
FLD1
FLD st1
FMUL st0,st0
! FSUBP st1,st0
FSQRT
FXCH
FPATAN
MOV ebx,*x
! fstp tword [ebx]
EndProcedure
;
Procedure r10add(*x.r10,*y.r10,*z.r10);x=y+z
FINIT
MOV ebx,*z
! fld tword [ebx]
FST st1
MOV ebx,*y
! fld tword [ebx]
FADD st0,st1
MOV ebx,*x
! fstp tword [ebx]
EndProcedure
;
Procedure r10antilog(*x.r10,*y.r10);x=10^y
r10xtoy(*x,@r10ten,*y)
EndProcedure
;
Procedure r10asin(*x.r10,*y.r10);x=asin(y)
FINIT
MOV ebx,*y
! fld tword [ebx]
FLD1
FLD st1
FMUL st0,st0
! FSUBP st1,st0
FSQRT
FPATAN
MOV ebx,*x
! fstp tword [ebx]
EndProcedure
;
Procedure r10atan(*x.r10,*y.r10);x=atan(y)
FINIT
MOV ebx,*y
! fld tword [ebx]
FLD1
FPATAN ;
MOV ebx,*x
! fstp tword [ebx]
EndProcedure
;
Procedure r10atof(*x.r10,afloat$);string to r10 var x
;afloat should be string representation of valid number
tenx.r10
tenxptr=@tenx
ten.l=10
tenptr=@ten
f1$=UCase(afloat$)
f$=""
;
;remove invalid chars
For i=1 To Len(f1$)
a=Asc(Mid(f1$,i,1))
If (a>47 And a0
e$=Right(f$,Len(f$)-p)
f$=Trim(Left(f$,p-1))
Else
e$="0"
f$=Trim(f$)
EndIf
;
;remove sign of mantissa
If Left(f$,1)="+"
f$=Right(f$,Len(f$)-1)
s=0
ElseIf Left(f$,1)="-"
f$=Right(f$,Len(f$)-1)
s=-1
EndIf
;
;add decimal point to mantissa if missing
p=FindString(f$,".",1)
If p=0: f$=f$+".0": EndIf
;
;remove leading zeros before mantissa decimal point
i=0
Repeat: i=i+1: Until Mid(f$,i,1)"0"
f$=Right(f$,Len(f$)-i+1)
;
;if mantissa "0" Or i>Len(f$)
f$=Right(f$,Len(f$)-i+1)
ex.w=2-i
EndIf
;
;create 18 decimal digit mantissa and exponent word
p=FindString(f$,".",1)
a$=Left(f$,p-1)
b$=Right(f$,Len(f$)-p)
ex=ex+Len(a$)+Val(e$);exponent
f1$=a$+b$
While Len(f1$)18
l.w=Len(a$)
f1$=Left(f1$,18)
EndIf
;example of variables so far:
;if string was "-.00000000001234e-33"
;then f1 would now hold; "123400000000000000", s=-1 (sign)
;ex now holds -43 ie exponent as in 0.1234e-43
;
;we now convert f1$ to a packed BCD number and store
;it in *x, then divide *x by 10^(18-ex).
*x\tbyte[9]=0 ;alway zero for positive BCD number
i=1
j=8
While iy 0 if x=y -1 if x19):format=19:EndIf
If (z=0) And (zz=0)
If format=0
f$="0.00000000000000000"
ElseIf format=19
f$="+0.00000000000000000e+0000"
ElseIf format>0
f$="0"
Else
f$=LSet("0.",2-format,"0")
EndIf
ProcedureReturn f$
EndIf
bex.w=(*x\fword[4]&%111111111111111)-$3ffe
s.w=*x\fword[4]>>15
ex.w=Int(0.30103*bex);initial guess at decimal exponent
exp=@bex
ex1.w=17-ex
tenx.r10
tenxptr=@tenx
t.l=10
tptr=@t
FINIT
MOV ebx,tptr ;load 10 into ebx
! fild word [ebx] ;load integer 10, convert to float in st0
MOV ebx,tenxptr ;load address of tenx into ebx
! fstp tword [ebx] ;store float 10 into tenx
r10power(@tenx,ex1) ;raise tenx to ex power
FINIT
MOV ebx,tenxptr
! fld tword [ebx] ;load tenx^ex into st0
FST st1 ;store into st1
MOV ebx,*x
! fld tword [ebx];
FMUL st0,st1 ;the number is multiplied by tenx^ex
FST st1
! fbstp [ebx] ;BCD pack float into *x
;multiply *x by 10 if most sig BCD digit is zero
;this happens when next BCD digit is 8 or 9
If (*x\tbyte[8]&$ff)>4
l.w=c-h10;FBSTP value for FPU exception
f$="INVALID"
If format=19:f$=f$+Space(19)+"":EndIf
ProcedureReturn f$
EndIf
i=8
While i>=0;load 18 digit mantissa to f$
c.w=*x\tbyte[i] & $ff
h.w=c>>4
l.w=c-h0: f$=f$+"e"+Str(ex): EndIf
If s=-1: f$="-"+f$:EndIf
ElseIf format=19;fixed length scientific format
f$=Left(f$,1)+"."+Right(f$,Len(f$)-1)
If ex=18 so need to add extra digits
f$=LSet(f$,d,"0")
EndIf
If d0;significant figures format
If format8 Or ex(ex+1)
a$=a$+"."+Mid(f$,ex+2,format-ex-1)
EndIf
f$=a$
EndIf
EndIf
r10copy(*x,@xtem);restore *x after use by bcd pack
ProcedureReturn f$
EndProcedure
;
Procedure r10int(*x.r10,*y.r10) ;x=int(y)
MaskedCW.l
mcw.l=@MaskedCW.l
SaveCW.l
scw.l=@SaveCW.l
FINIT
MOV ebx,mcw
! fstcw [ebx]
SaveCW=MaskedCW
MaskedCW=MaskedCW|%010000000000;round toward -inf
MOV ebx,mcw
! FLDCW [ebx]
MOV ebx,*y
! fld tword [ebx]
FRNDINT
MOV ebx,*x
! fstp tword [ebx]
MOV ebx,scw
! fldcw [ebx]
EndProcedure
;
Procedure r10ln(*x.r10,*y.r10);x=ln(y)
FINIT
! fldln2 ;load loge(2)
FST st1
MOV ebx,*y
! FLD tword [ebx]
! FYL2X ;st1*log2(x)
MOV ebx,*x
! fstp tword [ebx]
EndProcedure
;
Procedure r10log10(*x.r10,*y.r10);x=log10(y)
FINIT
! fldlg2 ;load Log10(2)
FST st1
MOV ebx,*y
! FLD tword [ebx]
! fyl2x ; st1*log2(x)
MOV ebx,*x
! fstp tword [ebx]
EndProcedure
;
Procedure r10mul(*x.r10,*y.r10,*z.r10);x=y*z
FINIT
MOV ebx,*z
! fld tword [ebx]
FST st1
MOV ebx,*y
! fld tword [ebx]
FMUL st0,st1
MOV ebx,*x
! fstp tword [ebx]
EndProcedure
;
Procedure r10pi(*x.r10);x=Pi
! fldpi;
MOV ebx,*x
! fstp tword [ebx];
EndProcedure
;
Procedure r10power(*x.r10,e.w);x=x^e.w ie integer power
;this proc is only used by r10atof() and r10ftoa()
;x must be an address of a r10 variable
e1.w=Abs(e)
;take x To an integer power
FINIT
FLD1 ; z:=1.0
FST st1
MOV ebx,*x
! fld tword [ebx];load st0 with x
While e1>0
While (e1&1)=0;while e is even
e1=e1 >> 1;e1=e1/2
FMUL st0,st0;x=x*x
Wend
e1=e1-1
FMUL st1,st0;z=z*x ;st1=st1*st0
Wend
FXCH st1;exchange st0 and st1
If e 0
If EventID = #PB_EventRepaint
PaintScreen()
EndIf
Until EventID = #PB_EventCloseWindow
EndIf
End