1/****************************************************************
2
3The author of this software is David M. Gay.
4
5Copyright (C) 1998, 2000 by Lucent Technologies
6All Rights Reserved
7
8Permission to use, copy, modify, and distribute this software and
9its documentation for any purpose and without fee is hereby
10granted, provided that the above copyright notice appear in all
11copies and that both that the copyright notice and this
12permission notice and warranty disclaimer appear in supporting
13documentation, and that the name of Lucent or any of its entities
14not be used in advertising or publicity pertaining to
15distribution of the software without specific, written prior
16permission.
17
18LUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
19INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
20IN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
21SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
22WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
23IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
24ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
25THIS SOFTWARE.
26
27****************************************************************/
28
29/* Please send bug reports to David M. Gay (dmg at acm dot org,
30 * with " at " changed at "@" and " dot " changed to ".").	*/
31
32#include "gdtoaimp.h"
33
34 static double
35#ifdef KR_headers
36ulpdown(d) U *d;
37#else
38ulpdown(U *d)
39#endif
40{
41	double u;
42	ULong *L = d->L;
43
44	u = ulp(d);
45	if (!(L[_1] | (L[_0] & 0xfffff))
46	 && (L[_0] & 0x7ff00000) > 0x00100000)
47		u *= 0.5;
48	return u;
49	}
50
51 int
52#ifdef KR_headers
53strtodI(s, sp, dd) CONST char *s; char **sp; double *dd;
54#else
55strtodI(CONST char *s, char **sp, double *dd)
56#endif
57{
58	static FPI fpi = { 53, 1-1023-53+1, 2046-1023-53+1, 1, SI };
59	ULong bits[2], sign;
60	Long exp;
61	int j, k;
62	U *u;
63
64	k = strtodg(s, sp, &fpi, &exp, bits);
65	u = (U*)dd;
66	sign = k & STRTOG_Neg ? 0x80000000L : 0;
67	switch(k & STRTOG_Retmask) {
68	  case STRTOG_NoNumber:
69		dval(&u[0]) = dval(&u[1]) = 0.;
70		break;
71
72	  case STRTOG_Zero:
73		dval(&u[0]) = dval(&u[1]) = 0.;
74#ifdef Sudden_Underflow
75		if (k & STRTOG_Inexact) {
76			if (sign)
77				word0(&u[0]) = 0x80100000L;
78			else
79				word0(&u[1]) = 0x100000L;
80			}
81		break;
82#else
83		goto contain;
84#endif
85
86	  case STRTOG_Denormal:
87		word1(&u[0]) = bits[0];
88		word0(&u[0]) = bits[1];
89		goto contain;
90
91	  case STRTOG_Normal:
92		word1(&u[0]) = bits[0];
93		word0(&u[0]) = (bits[1] & ~0x100000) | ((exp + 0x3ff + 52) << 20);
94	  contain:
95		j = k & STRTOG_Inexact;
96		if (sign) {
97			word0(&u[0]) |= sign;
98			j = STRTOG_Inexact - j;
99			}
100		switch(j) {
101		  case STRTOG_Inexlo:
102#ifdef Sudden_Underflow
103			if ((u->L[_0] & 0x7ff00000) < 0x3500000) {
104				word0(&u[1]) = word0(&u[0]) + 0x3500000;
105				word1(&u[1]) = word1(&u[0]);
106				dval(&u[1]) += ulp(&u[1]);
107				word0(&u[1]) -= 0x3500000;
108				if (!(word0(&u[1]) & 0x7ff00000)) {
109					word0(&u[1]) = sign;
110					word1(&u[1]) = 0;
111					}
112				}
113			else
114#endif
115			dval(&u[1]) = dval(&u[0]) + ulp(&u[0]);
116			break;
117		  case STRTOG_Inexhi:
118			dval(&u[1]) = dval(&u[0]);
119#ifdef Sudden_Underflow
120			if ((word0(&u[0]) & 0x7ff00000) < 0x3500000) {
121				word0(&u[0]) += 0x3500000;
122				dval(&u[0]) -= ulpdown(u);
123				word0(&u[0]) -= 0x3500000;
124				if (!(word0(&u[0]) & 0x7ff00000)) {
125					word0(&u[0]) = sign;
126					word1(&u[0]) = 0;
127					}
128				}
129			else
130#endif
131			dval(&u[0]) -= ulpdown(u);
132			break;
133		  default:
134			dval(&u[1]) = dval(&u[0]);
135		  }
136		break;
137
138	  case STRTOG_Infinite:
139		word0(&u[0]) = word0(&u[1]) = sign | 0x7ff00000;
140		word1(&u[0]) = word1(&u[1]) = 0;
141		if (k & STRTOG_Inexact) {
142			if (sign) {
143				word0(&u[1]) = 0xffefffffL;
144				word1(&u[1]) = 0xffffffffL;
145				}
146			else {
147				word0(&u[0]) = 0x7fefffffL;
148				word1(&u[0]) = 0xffffffffL;
149				}
150			}
151		break;
152
153	  case STRTOG_NaN:
154		u->L[0] = (u+1)->L[0] = d_QNAN0;
155		u->L[1] = (u+1)->L[1] = d_QNAN1;
156		break;
157
158	  case STRTOG_NaNbits:
159		word0(&u[0]) = word0(&u[1]) = 0x7ff00000 | sign | bits[1];
160		word1(&u[0]) = word1(&u[1]) = bits[0];
161	  }
162	return k;
163	}
164