1 /* $NetBSD: strtodg.c,v 1.6 2008/03/21 23:13:48 christos Exp $ */
3 /****************************************************************
5 The author of this software is David M. Gay.
7 Copyright (C) 1998-2001 by Lucent Technologies
10 Permission to use, copy, modify, and distribute this software and
11 its documentation for any purpose and without fee is hereby
12 granted, provided that the above copyright notice appear in all
13 copies and that both that the copyright notice and this
14 permission notice and warranty disclaimer appear in supporting
15 documentation, and that the name of Lucent or any of its entities
16 not be used in advertising or publicity pertaining to
17 distribution of the software without specific, written prior
20 LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
21 INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
22 IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
23 SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
24 WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
25 IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
26 ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
29 ****************************************************************/
31 /* Please send bug reports to David M. Gay (dmg at acm dot org,
32 * with " at " changed at "@" and " dot " changed to "."). */
41 fivesbits
[] = { 0, 3, 5, 7, 10, 12, 14, 17, 19, 21,
42 24, 26, 28, 31, 33, 35, 38, 40, 42, 45,
51 increment(b
) Bigint
*b
;
66 if (*x
< (ULong
)0xffffffffL
) {
83 if (b
->wds
>= b
->maxwds
) {
98 decrement(b
) Bigint
*b
;
122 borrow
= (y
& 0x10000) >> 16;
124 } while(borrow
&& x
< xe
);
126 return STRTOG_Inexlo
;
131 all_on(b
, n
) CONST Bigint
*b
; int n
;
133 all_on(CONST Bigint
*b
, int n
)
139 xe
= x
+ ((unsigned int)n
>> kshift
);
141 if ((*x
++ & ALL_ON
) != ALL_ON
)
144 return ((*x
| (ALL_ON
<< n
)) & ALL_ON
) == ALL_ON
;
150 set_ones(b
, n
) Bigint
*b
; int n
;
152 set_ones(Bigint
*b
, int n
)
158 k
= (unsigned int)(n
+ ((1 << kshift
) - 1)) >> kshift
;
165 k
= (unsigned int)n
>> kshift
;
174 x
[-1] >>= ULbits
- n
;
181 (d
, fpi
, expt
, bits
, exact
, rd
, irv
)
182 double d
; CONST FPI
*fpi
; Long
*expt
; ULong
*bits
; int exact
, rd
, *irv
;
184 (double d
, CONST FPI
*fpi
, Long
*expt
, ULong
*bits
, int exact
, int rd
, int *irv
)
188 ULong carry
, inex
, lostbits
;
189 int bdif
, e
, j
, k
, k1
, nb
, rv
;
192 b
= d2b(d
, &e
, &bdif
);
193 bdif
-= nb
= fpi
->nbits
;
202 #ifndef IMPRECISE_INEXACT
219 default: /* round near */
228 if (b
->x
[(unsigned int)k
>>kshift
] & ((ULong
)1 << (k
& kmask
)))
232 /* "break" cases: round up 1 bit, then truncate; bdif > 0 */
237 if ( (lostbits
= any_on(b
, bdif
)) !=0)
238 inex
= STRTOG_Inexlo
;
241 inex
= STRTOG_Inexhi
;
243 if ( (j
= nb
& kmask
) !=0)
245 if (hi0bits(b
->x
[b
->wds
- 1]) != j
) {
247 lostbits
= b
->x
[0] & 1;
254 b
= lshift(b
, -bdif
);
258 if (k
> nb
|| fpi
->sudden_underflow
) {
260 *irv
= STRTOG_Underflow
| STRTOG_Inexlo
;
264 if (k1
> 0 && !lostbits
)
265 lostbits
= any_on(b
, k1
);
266 if (!lostbits
&& !exact
)
269 carry
= b
->x
[(unsigned int)k1
>>kshift
] &
272 *irv
= STRTOG_Denormal
;
275 inex
= STRTOG_Inexhi
| STRTOG_Underflow
;
278 inex
= STRTOG_Inexlo
| STRTOG_Underflow
;
281 else if (e
> fpi
->emax
) {
283 *irv
= STRTOG_Infinite
| STRTOG_Overflow
| STRTOG_Inexhi
;
290 copybits(bits
, nb
, b
);
301 mantbits(d
) double d
;
308 L
= word1(d
) << 16 | word1(d
) >> 16;
311 if ( (L
= word1(d
)) !=0)
313 return P
- lo0bits(&L
);
315 L
= word0(d
) << 16 | word0(d
) >> 16 | Exp_msk11
;
317 L
= word0(d
) | Exp_msk1
;
319 return P
- 32 - lo0bits(&L
);
326 (s00
, se
, fpi
, expt
, bits
)
327 CONST
char *s00
; char **se
; CONST FPI
*fpi
; Long
*expt
; ULong
*bits
;
329 (CONST
char *s00
, char **se
, CONST FPI
*fpi
, Long
*expt
, ULong
*bits
)
332 int abe
, abits
, asub
;
333 int bb0
, bb2
, bb5
, bbe
, bd2
, bd5
, bbbits
, bs2
, c
, decpt
, denorm
;
334 int dsign
, e
, e1
, e2
, emin
, esign
, finished
, i
, inex
, irv
;
335 int j
, k
, nbits
, nd
, nd0
, nf
, nz
, nz0
, rd
, rvbits
, rve
, rve1
, sign
;
336 int sudden_underflow
= 0; /* pacify gcc */
337 CONST
char *s
, *s0
, *s1
;
338 double adj
, adj0
, rv
, tol
;
341 Bigint
*ab
, *bb
, *bb1
, *bd
, *bd0
, *bs
, *delta
, *rvb
, *rvb0
;
343 e2
= 0; /* XXX gcc */
346 denorm
= sign
= nz0
= nz
= 0;
350 for(s
= s00
;;s
++) switch(*s
) {
360 irv
= STRTOG_NoNumber
;
379 irv
= gethex(&s
, fpi
, expt
, &rvb
, sign
);
380 if (irv
== STRTOG_NoNumber
) {
392 sudden_underflow
= fpi
->sudden_underflow
;
395 for(decpt
= nd
= nf
= 0; (c
= *s
) >= '0' && c
<= '9'; nd
++, s
++)
402 if (c
== *localeconv()->decimal_point
)
410 for(; c
== '0'; c
= *++s
)
412 if (c
> '0' && c
<= '9') {
420 for(; c
>= '0' && c
<= '9'; c
= *++s
) {
425 for(i
= 1; i
< nz
; i
++)
428 else if (nd
<= DBL_DIG
+ 1)
432 else if (nd
<= DBL_DIG
+ 1)
440 if (c
== 'e' || c
== 'E') {
441 if (!nd
&& !nz
&& !nz0
) {
442 irv
= STRTOG_NoNumber
;
455 if (c
>= '0' && c
<= '9') {
458 if (c
> '0' && c
<= '9') {
461 while((c
= *++s
) >= '0' && c
<= '9')
463 if (s
- s1
> 8 || L
> 19999)
464 /* Avoid confusion from exponents
465 * so large that e might overflow.
467 e
= 19999; /* safe for 16 bit ints */
482 /* Check for Nan and Infinity */
487 if (match(&s
,"nf")) {
489 if (!match(&s
,"inity"))
491 irv
= STRTOG_Infinite
;
497 if (match(&s
, "an")) {
499 *expt
= fpi
->emax
+ 1;
502 irv
= hexnan(&s
, fpi
, bits
);
507 #endif /* INFNAN_CHECK */
508 irv
= STRTOG_NoNumber
;
517 switch(fpi
->rounding
& 3) {
528 /* Now we have nd0 digits, starting at s0, followed by a
529 * decimal point, followed by nd-nd0 digits. The number we're
530 * after is the integer represented by those digits times
535 k
= nd
< DBL_DIG
+ 1 ? nd
: DBL_DIG
+ 1;
538 dval(rv
) = tens
[k
- 9] * dval(rv
) + z
;
540 if (nbits
<= P
&& nd
<= DBL_DIG
) {
542 if (rvOK(dval(rv
), fpi
, expt
, bits
, 1, rd
, &irv
))
550 i
= fivesbits
[e
] + mantbits(dval(rv
)) <= P
;
551 /* rv = */ rounded_product(dval(rv
), tens
[e
]);
552 if (rvOK(dval(rv
), fpi
, expt
, bits
, i
, rd
, &irv
))
559 if (e
<= Ten_pmax
+ i
) {
560 /* A fancier test would sometimes let us do
561 * this for larger i values.
567 /* VAX exponent range is so narrow we must
568 * worry about overflow here...
571 dval(adj
) = dval(rv
);
572 word0(adj
) -= P
*Exp_msk1
;
573 /* adj = */ rounded_product(dval(adj
), tens
[e2
]);
574 if ((word0(adj
) & Exp_mask
)
575 > Exp_msk1
*(DBL_MAX_EXP
+Bias
-1-P
))
577 word0(adj
) += P
*Exp_msk1
;
578 dval(rv
) = dval(adj
);
580 /* rv = */ rounded_product(dval(rv
), tens
[e2
]);
582 if (rvOK(dval(rv
), fpi
, expt
, bits
, 0, rd
, &irv
))
587 #ifndef Inaccurate_Divide
588 else if (e
>= -Ten_pmax
) {
589 /* rv = */ rounded_quotient(dval(rv
), tens
[-e
]);
590 if (rvOK(dval(rv
), fpi
, expt
, bits
, 0, rd
, &irv
))
599 /* Get starting approximation = rv * 10**e1 */
603 if ( (i
= e1
& 15) !=0)
606 e1
= (unsigned int)e1
>> 4;
607 while(e1
>= (1 << (n_bigtens
-1))) {
608 e2
+= ((word0(rv
) & Exp_mask
)
609 >> Exp_shift1
) - Bias
;
610 word0(rv
) &= ~Exp_mask
;
611 word0(rv
) |= Bias
<< Exp_shift1
;
612 dval(rv
) *= bigtens
[n_bigtens
-1];
613 e1
-= 1 << (n_bigtens
-1);
615 e2
+= ((word0(rv
) & Exp_mask
) >> Exp_shift1
) - Bias
;
616 word0(rv
) &= ~Exp_mask
;
617 word0(rv
) |= Bias
<< Exp_shift1
;
618 for(j
= 0; e1
> 0; j
++, e1
= (unsigned int)e1
>> 1)
620 dval(rv
) *= bigtens
[j
];
625 if ( (i
= e1
& 15) !=0)
628 e1
= (unsigned int)e1
>> 4;
629 while(e1
>= (1 << (n_bigtens
-1))) {
630 e2
+= ((word0(rv
) & Exp_mask
)
631 >> Exp_shift1
) - Bias
;
632 word0(rv
) &= ~Exp_mask
;
633 word0(rv
) |= Bias
<< Exp_shift1
;
634 dval(rv
) *= tinytens
[n_bigtens
-1];
635 e1
-= 1 << (n_bigtens
-1);
637 e2
+= ((word0(rv
) & Exp_mask
) >> Exp_shift1
) - Bias
;
638 word0(rv
) &= ~Exp_mask
;
639 word0(rv
) |= Bias
<< Exp_shift1
;
640 for(j
= 0; e1
> 0; j
++, e1
= (unsigned int)e1
>> 1)
642 dval(rv
) *= tinytens
[j
];
646 /* e2 is a correction to the (base 2) exponent of the return
647 * value, reflecting adjustments above to avoid overflow in the
648 * native arithmetic. For native IBM (base 16) arithmetic, we
649 * must multiply e2 by 4 to change from base 16 to 2.
653 rvb
= d2b(dval(rv
), &rve
, &rvbits
); /* rv = rvb * 2^rve */
655 return STRTOG_NoMemory
;
657 if ((j
= rvbits
- nbits
) > 0) {
662 bb0
= 0; /* trailing zero bits in rvb */
663 e2
= rve
+ rvbits
- nbits
;
664 if (e2
> fpi
->emax
+ 1)
666 rve1
= rve
+ rvbits
- nbits
;
667 if (e2
< (emin
= fpi
->emin
)) {
671 rvb
= lshift(rvb
, j
);
682 irv
= STRTOG_Underflow
| STRTOG_Inexlo
;
685 rvb
->x
[0] = rvb
->wds
= rvbits
= 1;
691 if (sudden_underflow
&& e2
+ 1 < emin
)
695 /* Now the hard part -- adjusting rv to the correct value.*/
697 /* Put digits into bd: true value = bd * 10^e */
699 bd0
= s2b(s0
, nd0
, nd
, y
);
704 return STRTOG_NoMemory
;
708 return STRTOG_NoMemory
;
710 bbbits
= rvbits
- bb0
;
714 return STRTOG_NoMemory
;
729 j
= nbits
+ 1 - bbbits
;
730 i
= bbe
+ bbbits
- nbits
;
731 if (i
< emin
) /* denormal */
735 i
= bb2
< bd2
? bb2
: bd2
;
744 bs
= pow5mult(bs
, bb5
);
746 return STRTOG_NoMemory
;
749 return STRTOG_NoMemory
;
755 bb
= lshift(bb
, bb2
);
757 return STRTOG_NoMemory
;
762 bd
= pow5mult(bd
, bd5
);
764 return STRTOG_NoMemory
;
767 bd
= lshift(bd
, bd2
);
769 return STRTOG_NoMemory
;
772 bs
= lshift(bs
, bs2
);
774 return STRTOG_NoMemory
;
777 inex
= STRTOG_Inexhi
;
778 delta
= diff(bb
, bd
);
780 return STRTOG_NoMemory
;
781 if (delta
->wds
<= 1 && !delta
->x
[0])
784 delta
->sign
= finished
= 0;
789 if ( (finished
= dsign
^ (rd
&1)) !=0) {
791 irv
|= STRTOG_Inexhi
;
794 irv
|= STRTOG_Inexlo
;
797 for(i
= 0, j
= nbits
; j
>= ULbits
;
799 if (rvb
->x
[i
] & ALL_ON
)
802 if (j
> 1 && lo0bits(rvb
->x
+ i
) < j
- 1)
805 rvb
= set_ones(rvb
, rvbits
= nbits
);
807 return STRTOG_NoMemory
;
810 irv
|= dsign
? STRTOG_Inexlo
: STRTOG_Inexhi
;
814 /* Error is less than half an ulp -- check for
815 * special case of mantissa a power of two.
818 ? STRTOG_Normal
| STRTOG_Inexlo
819 : STRTOG_Normal
| STRTOG_Inexhi
;
820 if (dsign
|| bbbits
> 1 || denorm
|| rve1
== emin
)
822 delta
= lshift(delta
,1);
824 return STRTOG_NoMemory
;
825 if (cmp(delta
, bs
) > 0) {
826 irv
= STRTOG_Normal
| STRTOG_Inexlo
;
832 /* exactly half-way between */
834 if (denorm
&& all_on(rvb
, rvbits
)) {
835 /*boundary case -- increment exponent*/
838 rve
= emin
+ nbits
- (rvbits
= 1);
839 irv
= STRTOG_Normal
| STRTOG_Inexhi
;
843 irv
= STRTOG_Normal
| STRTOG_Inexlo
;
845 else if (bbbits
== 1) {
848 /* boundary case -- decrement exponent */
850 irv
= STRTOG_Normal
| STRTOG_Inexhi
;
851 if (rvb
->wds
== 1 && rvb
->x
[0] == 1)
852 sudden_underflow
= 1;
856 rvb
= set_ones(rvb
, rvbits
= nbits
);
858 return STRTOG_NoMemory
;
862 irv
= STRTOG_Normal
| STRTOG_Inexhi
;
863 if ((bbbits
< nbits
&& !denorm
) || !(rvb
->x
[0] & 1))
866 rvb
= increment(rvb
);
868 return STRTOG_NoMemory
;
869 if ( (j
= rvbits
& kmask
) !=0)
871 if (hi0bits(rvb
->x
[(unsigned int)(rvb
->wds
- 1)
875 irv
= STRTOG_Normal
| STRTOG_Inexhi
;
881 irv
= STRTOG_Normal
| STRTOG_Inexlo
;
885 if ((dval(adj
) = ratio(delta
, bs
)) <= 2.) {
887 inex
= STRTOG_Inexlo
;
890 inex
= STRTOG_Inexhi
;
892 else if (denorm
&& bbbits
<= 1) {
896 irv
= STRTOG_Underflow
| STRTOG_Inexlo
;
899 adj0
= dval(adj
) = 1.;
902 adj0
= dval(adj
) *= 0.5;
905 inex
= STRTOG_Inexlo
;
907 if (dval(adj
) < 2147483647.) {
916 if (asub
&& adj0
> 0.)
920 if (!asub
&& adj0
> 0.) {
923 inex
= STRTOG_Inexact
- inex
;
931 /* adj *= ulp(dval(rv)); */
932 /* if (asub) rv -= adj; else rv += adj; */
934 if (!denorm
&& rvbits
< nbits
) {
935 rvb
= lshift(rvb
, j
= nbits
- rvbits
);
937 return STRTOG_NoMemory
;
941 ab
= d2b(dval(adj
), &abe
, &abits
);
943 return STRTOG_NoMemory
;
947 ab
= lshift(ab
, abe
);
951 j
= hi0bits(rvb
->x
[rvb
->wds
-1]);
954 return STRTOG_NoMemory
;
958 else if (rvb
->wds
<= k
959 || hi0bits( rvb
->x
[k
]) >
960 hi0bits(rvb0
->x
[k
])) {
961 /* unlikely; can only have lost 1 high bit */
967 rvb
= lshift(rvb
, 1);
969 return STRTOG_NoMemory
;
979 return STRTOG_NoMemory
;
982 || hi0bits(rvb
->x
[k
]) < hi0bits(rvb0
->x
[k
])) {
984 if (++rvbits
== nbits
)
1002 /* Can we stop now? */
1003 tol
= dval(adj
) * 5e-16; /* > max rel error */
1004 dval(adj
) = adj0
- .5;
1005 if (dval(adj
) < -tol
) {
1011 else if (dval(adj
) > tol
&& adj0
< 1. - tol
) {
1016 bb0
= denorm
? 0 : trailz(rvb
);
1022 if (!denorm
&& (j
= nbits
- rvbits
)) {
1024 rvb
= lshift(rvb
, j
);
1035 if (rve
> fpi
->emax
) {
1038 irv
= STRTOG_Infinite
| STRTOG_Overflow
| STRTOG_Inexhi
;
1045 *expt
= fpi
->emax
+ 1;
1049 if (sudden_underflow
) {
1051 irv
= STRTOG_Underflow
| STRTOG_Inexlo
;
1054 irv
= (irv
& ~STRTOG_Retmask
) |
1055 (rvb
->wds
> 0 ? STRTOG_Denormal
: STRTOG_Zero
);
1056 if (irv
& STRTOG_Inexact
)
1057 irv
|= STRTOG_Underflow
;
1065 copybits(bits
, nbits
, rvb
);