1 /****************************************************************
2 Copyright 1990 - 1997 by AT&T, Lucent Technologies and Bellcore.
3
4 Permission to use, copy, modify, and distribute this software
5 and its documentation for any purpose and without fee is hereby
6 granted, provided that the above copyright notice appear in all
7 copies and that both that the copyright notice and this
8 permission notice and warranty disclaimer appear in supporting
9 documentation, and that the names of AT&T, Bell Laboratories,
10 Lucent or Bellcore or any of their entities not be used in
11 advertising or publicity pertaining to distribution of the
12 software without specific, written prior permission.
13
14 AT&T, Lucent and Bellcore disclaim all warranties with regard to
15 this software, including all implied warranties of
16 merchantability and fitness. In no event shall AT&T, Lucent or
17 Bellcore be liable for any special, indirect or consequential
18 damages or any damages whatsoever resulting from loss of use,
19 data or profits, whether in an action of contract, negligence or
20 other tortious action, arising out of or in connection with the
21 use or performance of this software.
22 ****************************************************************/
23
24 #include <f2c_config.h>
25 #include <stdlib.h>
26 #include <string.h>
27 #include <ctype.h>
28 #include "f2c.h"
29 #include "fio.h"
30 #include "arith.h"
31
32 #include "fmt.h"
33 #include "fp.h"
34
wrt_E(ufloat * p,int w,int d,int e,ftnlen len)35 int wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
36 {
37 char buf[FMAX+EXPMAXDIGS+4], *s, *se;
38 int d1, delta, e1, i, sign, signspace;
39 double dd;
40 #ifdef WANT_LEAD_0
41 int insert0 = 0;
42 #endif
43 int e0 = e;
44
45 if(e <= 0)
46 e = 2;
47 if(f__scale) {
48 if(f__scale >= d + 2 || f__scale <= -d)
49 goto nogood;
50 }
51 if(f__scale <= 0)
52 --d;
53 if (len == sizeof(real))
54 dd = p->pf;
55 else
56 dd = p->pd;
57 if (dd < 0.) {
58 signspace = sign = 1;
59 dd = -dd;
60 }
61 else {
62 sign = 0;
63 signspace = (int)f__cplus;
64 if (!dd) {
65 #ifdef SIGNED_ZEROS
66 if (signbit(dd))
67 signspace = sign = 1;
68 #endif
69 dd = 0.; /* avoid -0 */
70 }
71 }
72 delta = w - (2 /* for the . and the d adjustment above */
73 + 2 /* for the E+ */ + signspace + d + e);
74 #ifdef WANT_LEAD_0
75 if (f__scale <= 0 && delta > 0) {
76 delta--;
77 insert0 = 1;
78 }
79 else
80 #endif
81 if (delta < 0) {
82 nogood:
83 while(--w >= 0)
84 PUT('*');
85 return(0);
86 }
87 if (f__scale < 0)
88 d += f__scale;
89 if (d > FMAX) {
90 d1 = d - FMAX;
91 d = FMAX;
92 }
93 else
94 d1 = 0;
95 sprintf(buf,"%#.*E", d, dd);
96 /* check for NaN, Infinity */
97 if (!isdigit(buf[0])) {
98 switch(buf[0]) {
99 case 'n':
100 case 'N':
101 signspace = 0; /* no sign for NaNs */
102 }
103 delta = w - strlen(buf) - signspace;
104 if (delta < 0)
105 goto nogood;
106 while(--delta >= 0)
107 PUT(' ');
108 if (signspace)
109 PUT(sign ? '-' : '+');
110 for(s = buf; *s; s++)
111 PUT(*s);
112 return 0;
113 }
114 se = buf + d + 3;
115 #ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
116 if (f__scale != 1 && dd)
117 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
118 #else
119 if (dd)
120 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
121 else
122 strcpy(se, "+00");
123 #endif
124 s = ++se;
125 if (e < 2) {
126 if (*s != '0')
127 goto nogood;
128 }
129 /* accommodate 3 significant digits in exponent */
130 if (s[2]) {
131 #ifdef Pedantic
132 if (!e0 && !s[3])
133 for(s -= 2, e1 = 2; s[0] = s[1]; s++);
134
135 /* Pedantic gives the behavior that Fortran 77 specifies, */
136 /* i.e., requires that E be specified for exponent fields */
137 /* of more than 3 digits. With Pedantic undefined, we get */
138 /* the behavior that Cray displays -- you get a bigger */
139 /* exponent field if it fits. */
140 #else
141 if (!e0) {
142 for(s -= 2, e1 = 2; s[0] = s[1]; s++)
143 #ifdef CRAY
144 delta--;
145 if ((delta += 4) < 0)
146 goto nogood
147 #endif
148 ;
149 }
150 #endif
151 else if (e0 >= 0)
152 goto shift;
153 else
154 e1 = e;
155 }
156 else
157 shift:
158 for(s += 2, e1 = 2; *s; ++e1, ++s)
159 if (e1 >= e)
160 goto nogood;
161 while(--delta >= 0)
162 PUT(' ');
163 if (signspace)
164 PUT(sign ? '-' : '+');
165 s = buf;
166 i = f__scale;
167 if (f__scale <= 0) {
168 #ifdef WANT_LEAD_0
169 if (insert0)
170 PUT('0');
171 #endif
172 PUT('.');
173 for(; i < 0; ++i)
174 PUT('0');
175 PUT(*s);
176 s += 2;
177 }
178 else if (f__scale > 1) {
179 PUT(*s);
180 s += 2;
181 while(--i > 0)
182 PUT(*s++);
183 PUT('.');
184 }
185 if (d1) {
186 se -= 2;
187 while(s < se) PUT(*s++);
188 se += 2;
189 do PUT('0'); while(--d1 > 0);
190 }
191 while(s < se)
192 PUT(*s++);
193 if (e < 2)
194 PUT(s[1]);
195 else {
196 while(++e1 <= e)
197 PUT('0');
198 while(*s)
199 PUT(*s++);
200 }
201 return 0;
202 }
203
wrt_F(ufloat * p,int w,int d,ftnlen len)204 int wrt_F(ufloat *p, int w, int d, ftnlen len)
205 {
206 int d1, sign, n;
207 double x;
208 char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
209
210 x= (len==sizeof(real)?p->pf:p->pd);
211 if (d < MAXFRACDIGS)
212 d1 = 0;
213 else {
214 d1 = d - MAXFRACDIGS;
215 d = MAXFRACDIGS;
216 }
217 if (x < 0.)
218 { x = -x; sign = 1; }
219 else {
220 sign = 0;
221 if (!x) {
222 #ifdef SIGNED_ZEROS
223 if (signbit(x))
224 sign = 2;
225 #endif
226 x = 0.;
227 }
228 }
229
230 if (n = f__scale)
231 if (n > 0)
232 do x *= 10.; while(--n > 0);
233 else
234 do x *= 0.1; while(++n < 0);
235
236 n = sprintf(b = buf, "%#.*f", d, x) + d1;
237
238 #ifndef WANT_LEAD_0
239 if (buf[0] == '0' && d)
240 { ++b; --n; }
241 #endif
242 if (sign == 1) {
243 /* check for all zeros */
244 for(s = b;;) {
245 while(*s == '0') s++;
246 switch(*s) {
247 case '.':
248 s++; continue;
249 case 0:
250 sign = 0;
251 }
252 break;
253 }
254 }
255 if (sign || f__cplus)
256 ++n;
257 if (n > w) {
258 #ifdef WANT_LEAD_0
259 if (buf[0] == '0' && --n == w)
260 ++b;
261 else
262 #endif
263 {
264 while(--w >= 0)
265 PUT('*');
266 return 0;
267 }
268 }
269 for(w -= n; --w >= 0; )
270 PUT(' ');
271 if (sign)
272 PUT('-');
273 else if (f__cplus)
274 PUT('+');
275 while(n = *b++)
276 PUT(n);
277 while(--d1 >= 0)
278 PUT('0');
279 return 0;
280 }
281