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