1112158Sdas/****************************************************************
2112158Sdas
3112158SdasThe author of this software is David M. Gay.
4112158Sdas
5112158SdasCopyright (C) 1998, 2000 by Lucent Technologies
6112158SdasAll Rights Reserved
7112158Sdas
8112158SdasPermission to use, copy, modify, and distribute this software and
9112158Sdasits documentation for any purpose and without fee is hereby
10112158Sdasgranted, provided that the above copyright notice appear in all
11112158Sdascopies and that both that the copyright notice and this
12112158Sdaspermission notice and warranty disclaimer appear in supporting
13112158Sdasdocumentation, and that the name of Lucent or any of its entities
14112158Sdasnot be used in advertising or publicity pertaining to
15112158Sdasdistribution of the software without specific, written prior
16112158Sdaspermission.
17112158Sdas
18112158SdasLUCENT DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
19112158SdasINCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS.
20112158SdasIN NO EVENT SHALL LUCENT OR ANY OF ITS ENTITIES BE LIABLE FOR ANY
21112158SdasSPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
22112158SdasWHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER
23112158SdasIN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
24112158SdasARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF
25112158SdasTHIS SOFTWARE.
26112158Sdas
27112158Sdas****************************************************************/
28112158Sdas
29165743Sdas/* Please send bug reports to David M. Gay (dmg at acm dot org,
30165743Sdas * with " at " changed at "@" and " dot " changed to ".").	*/
31112158Sdas
32112158Sdas#include "gdtoaimp.h"
33112158Sdas
34112158Sdas static double
35112158Sdas#ifdef KR_headers
36219557Sdasulpdown(d) U *d;
37112158Sdas#else
38219557Sdasulpdown(U *d)
39112158Sdas#endif
40112158Sdas{
41112158Sdas	double u;
42219557Sdas	ULong *L = d->L;
43112158Sdas
44219557Sdas	u = ulp(d);
45219557Sdas	if (!(L[_1] | (L[_0] & 0xfffff))
46112158Sdas	 && (L[_0] & 0x7ff00000) > 0x00100000)
47112158Sdas		u *= 0.5;
48112158Sdas	return u;
49112158Sdas	}
50112158Sdas
51112158Sdas int
52112158Sdas#ifdef KR_headers
53112158SdasstrtodI(s, sp, dd) CONST char *s; char **sp; double *dd;
54112158Sdas#else
55112158SdasstrtodI(CONST char *s, char **sp, double *dd)
56112158Sdas#endif
57112158Sdas{
58165743Sdas	static FPI fpi = { 53, 1-1023-53+1, 2046-1023-53+1, 1, SI };
59112158Sdas	ULong bits[2], sign;
60112158Sdas	Long exp;
61112158Sdas	int j, k;
62112158Sdas	U *u;
63112158Sdas
64112158Sdas	k = strtodg(s, sp, &fpi, &exp, bits);
65112158Sdas	u = (U*)dd;
66112158Sdas	sign = k & STRTOG_Neg ? 0x80000000L : 0;
67112158Sdas	switch(k & STRTOG_Retmask) {
68112158Sdas	  case STRTOG_NoNumber:
69219557Sdas		dval(&u[0]) = dval(&u[1]) = 0.;
70112158Sdas		break;
71112158Sdas
72112158Sdas	  case STRTOG_Zero:
73219557Sdas		dval(&u[0]) = dval(&u[1]) = 0.;
74112158Sdas#ifdef Sudden_Underflow
75112158Sdas		if (k & STRTOG_Inexact) {
76112158Sdas			if (sign)
77219557Sdas				word0(&u[0]) = 0x80100000L;
78112158Sdas			else
79219557Sdas				word0(&u[1]) = 0x100000L;
80112158Sdas			}
81112158Sdas		break;
82112158Sdas#else
83112158Sdas		goto contain;
84112158Sdas#endif
85112158Sdas
86112158Sdas	  case STRTOG_Denormal:
87219557Sdas		word1(&u[0]) = bits[0];
88219557Sdas		word0(&u[0]) = bits[1];
89112158Sdas		goto contain;
90112158Sdas
91112158Sdas	  case STRTOG_Normal:
92219557Sdas		word1(&u[0]) = bits[0];
93219557Sdas		word0(&u[0]) = (bits[1] & ~0x100000) | ((exp + 0x3ff + 52) << 20);
94112158Sdas	  contain:
95112158Sdas		j = k & STRTOG_Inexact;
96112158Sdas		if (sign) {
97219557Sdas			word0(&u[0]) |= sign;
98112158Sdas			j = STRTOG_Inexact - j;
99112158Sdas			}
100112158Sdas		switch(j) {
101112158Sdas		  case STRTOG_Inexlo:
102112158Sdas#ifdef Sudden_Underflow
103112158Sdas			if ((u->L[_0] & 0x7ff00000) < 0x3500000) {
104219557Sdas				word0(&u[1]) = word0(&u[0]) + 0x3500000;
105219557Sdas				word1(&u[1]) = word1(&u[0]);
106219557Sdas				dval(&u[1]) += ulp(&u[1]);
107219557Sdas				word0(&u[1]) -= 0x3500000;
108219557Sdas				if (!(word0(&u[1]) & 0x7ff00000)) {
109219557Sdas					word0(&u[1]) = sign;
110219557Sdas					word1(&u[1]) = 0;
111112158Sdas					}
112112158Sdas				}
113112158Sdas			else
114112158Sdas#endif
115219557Sdas			dval(&u[1]) = dval(&u[0]) + ulp(&u[0]);
116112158Sdas			break;
117112158Sdas		  case STRTOG_Inexhi:
118219557Sdas			dval(&u[1]) = dval(&u[0]);
119112158Sdas#ifdef Sudden_Underflow
120219557Sdas			if ((word0(&u[0]) & 0x7ff00000) < 0x3500000) {
121219557Sdas				word0(&u[0]) += 0x3500000;
122219557Sdas				dval(&u[0]) -= ulpdown(u);
123219557Sdas				word0(&u[0]) -= 0x3500000;
124219557Sdas				if (!(word0(&u[0]) & 0x7ff00000)) {
125219557Sdas					word0(&u[0]) = sign;
126219557Sdas					word1(&u[0]) = 0;
127112158Sdas					}
128112158Sdas				}
129112158Sdas			else
130112158Sdas#endif
131219557Sdas			dval(&u[0]) -= ulpdown(u);
132112158Sdas			break;
133112158Sdas		  default:
134219557Sdas			dval(&u[1]) = dval(&u[0]);
135112158Sdas		  }
136112158Sdas		break;
137112158Sdas
138112158Sdas	  case STRTOG_Infinite:
139219557Sdas		word0(&u[0]) = word0(&u[1]) = sign | 0x7ff00000;
140219557Sdas		word1(&u[0]) = word1(&u[1]) = 0;
141112158Sdas		if (k & STRTOG_Inexact) {
142112158Sdas			if (sign) {
143219557Sdas				word0(&u[1]) = 0xffefffffL;
144219557Sdas				word1(&u[1]) = 0xffffffffL;
145112158Sdas				}
146112158Sdas			else {
147219557Sdas				word0(&u[0]) = 0x7fefffffL;
148219557Sdas				word1(&u[0]) = 0xffffffffL;
149112158Sdas				}
150112158Sdas			}
151112158Sdas		break;
152112158Sdas
153112158Sdas	  case STRTOG_NaN:
154219557Sdas		u->L[0] = (u+1)->L[0] = d_QNAN0;
155219557Sdas		u->L[1] = (u+1)->L[1] = d_QNAN1;
156112158Sdas		break;
157112158Sdas
158112158Sdas	  case STRTOG_NaNbits:
159219557Sdas		word0(&u[0]) = word0(&u[1]) = 0x7ff00000 | sign | bits[1];
160219557Sdas		word1(&u[0]) = word1(&u[1]) = bits[0];
161112158Sdas	  }
162112158Sdas	return k;
163112158Sdas	}
164