source: trunk/src/gcc/libf2c/libI77/wref.c@ 2

Last change on this file since 2 was 2, checked in by bird, 22 years ago

Initial revision
  • Property cvs2svn:cvs-rev set to 1.1
  • Property svn:eol-style set to native
  • Property svn:executable set to *
File size: 4.4 KB
Line 
1#include "f2c.h"
2#include "fio.h"
3#ifndef VAX
4#include <ctype.h>
5#endif
6
7#ifndef KR_headers
8#undef abs
9#undef min
10#undef max
11#include <stdlib.h>
12#include <string.h>
13#endif
14
15#include "fmt.h"
16#include "fp.h"
17
18#ifdef KR_headers
19wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
20#else
21wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
22#endif
23{
24 char buf[FMAX+EXPMAXDIGS+4], *s, *se;
25 int d1, delta, e1, i, sign, signspace;
26 double dd;
27#ifdef WANT_LEAD_0
28 int insert0 = 0;
29#endif
30#ifndef VAX
31 int e0 = e;
32#endif
33
34 if(e <= 0)
35 e = 2;
36 if(f__scale) {
37 if(f__scale >= d + 2 || f__scale <= -d)
38 goto nogood;
39 }
40 if(f__scale <= 0)
41 --d;
42 if (len == sizeof(real))
43 dd = p->pf;
44 else
45 dd = p->pd;
46 if (dd < 0.) {
47 signspace = sign = 1;
48 dd = -dd;
49 }
50 else {
51 sign = 0;
52 signspace = (int)f__cplus;
53#ifndef VAX
54 if (!dd)
55 dd = 0.; /* avoid -0 */
56#endif
57 }
58 delta = w - (2 /* for the . and the d adjustment above */
59 + 2 /* for the E+ */ + signspace + d + e);
60#ifdef WANT_LEAD_0
61 if (f__scale <= 0 && delta > 0) {
62 delta--;
63 insert0 = 1;
64 }
65 else
66#endif
67 if (delta < 0) {
68nogood:
69 while(--w >= 0)
70 PUT('*');
71 return(0);
72 }
73 if (f__scale < 0)
74 d += f__scale;
75 if (d > FMAX) {
76 d1 = d - FMAX;
77 d = FMAX;
78 }
79 else
80 d1 = 0;
81 sprintf(buf,"%#.*E", d, dd);
82#ifndef VAX
83 /* check for NaN, Infinity */
84 if (!isdigit(buf[0])) {
85 switch(buf[0]) {
86 case 'n':
87 case 'N':
88 signspace = 0; /* no sign for NaNs */
89 }
90 delta = w - strlen(buf) - signspace;
91 if (delta < 0)
92 goto nogood;
93 while(--delta >= 0)
94 PUT(' ');
95 if (signspace)
96 PUT(sign ? '-' : '+');
97 for(s = buf; *s; s++)
98 PUT(*s);
99 return 0;
100 }
101#endif
102 se = buf + d + 3;
103#ifdef GOOD_SPRINTF_EXPONENT /* When possible, exponent has 2 digits. */
104 if (f__scale != 1 && dd)
105 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
106#else
107 if (dd)
108 sprintf(se, "%+.2d", atoi(se) + 1 - f__scale);
109 else
110 strcpy(se, "+00");
111#endif
112 s = ++se;
113 if (e < 2) {
114 if (*s != '0')
115 goto nogood;
116 }
117#ifndef VAX
118 /* accommodate 3 significant digits in exponent */
119 if (s[2]) {
120#ifdef Pedantic
121 if (!e0 && !s[3])
122 for(s -= 2, e1 = 2; s[0] = s[1]; s++);
123
124 /* Pedantic gives the behavior that Fortran 77 specifies, */
125 /* i.e., requires that E be specified for exponent fields */
126 /* of more than 3 digits. With Pedantic undefined, we get */
127 /* the behavior that Cray displays -- you get a bigger */
128 /* exponent field if it fits. */
129#else
130 if (!e0) {
131 for(s -= 2, e1 = 2; s[0] = s[1]; s++)
132#ifdef CRAY
133 delta--;
134 if ((delta += 4) < 0)
135 goto nogood
136#endif
137 ;
138 }
139#endif
140 else if (e0 >= 0)
141 goto shift;
142 else
143 e1 = e;
144 }
145 else
146 shift:
147#endif
148 for(s += 2, e1 = 2; *s; ++e1, ++s)
149 if (e1 >= e)
150 goto nogood;
151 while(--delta >= 0)
152 PUT(' ');
153 if (signspace)
154 PUT(sign ? '-' : '+');
155 s = buf;
156 i = f__scale;
157 if (f__scale <= 0) {
158#ifdef WANT_LEAD_0
159 if (insert0)
160 PUT('0');
161#endif
162 PUT('.');
163 for(; i < 0; ++i)
164 PUT('0');
165 PUT(*s);
166 s += 2;
167 }
168 else if (f__scale > 1) {
169 PUT(*s);
170 s += 2;
171 while(--i > 0)
172 PUT(*s++);
173 PUT('.');
174 }
175 if (d1) {
176 se -= 2;
177 while(s < se) PUT(*s++);
178 se += 2;
179 do PUT('0'); while(--d1 > 0);
180 }
181 while(s < se)
182 PUT(*s++);
183 if (e < 2)
184 PUT(s[1]);
185 else {
186 while(++e1 <= e)
187 PUT('0');
188 while(*s)
189 PUT(*s++);
190 }
191 return 0;
192 }
193
194#ifdef KR_headers
195wrt_F(p,w,d,len) ufloat *p; ftnlen len;
196#else
197wrt_F(ufloat *p, int w, int d, ftnlen len)
198#endif
199{
200 int d1, sign, n;
201 double x;
202 char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
203
204 x= (len==sizeof(real)?p->pf:p->pd);
205 if (d < MAXFRACDIGS)
206 d1 = 0;
207 else {
208 d1 = d - MAXFRACDIGS;
209 d = MAXFRACDIGS;
210 }
211 if (x < 0.)
212 { x = -x; sign = 1; }
213 else {
214 sign = 0;
215#ifndef VAX
216 if (!x)
217 x = 0.;
218#endif
219 }
220
221 if (n = f__scale)
222 if (n > 0)
223 do x *= 10.; while(--n > 0);
224 else
225 do x *= 0.1; while(++n < 0);
226
227#ifdef USE_STRLEN
228 sprintf(b = buf, "%#.*f", d, x);
229 n = strlen(b) + d1;
230#else
231 n = sprintf(b = buf, "%#.*f", d, x) + d1;
232#endif
233
234#ifndef WANT_LEAD_0
235 if (buf[0] == '0' && d)
236 { ++b; --n; }
237#endif
238 if (sign) {
239 /* check for all zeros */
240 for(s = b;;) {
241 while(*s == '0') s++;
242 switch(*s) {
243 case '.':
244 s++; continue;
245 case 0:
246 sign = 0;
247 }
248 break;
249 }
250 }
251 if (sign || f__cplus)
252 ++n;
253 if (n > w) {
254#ifdef WANT_LEAD_0
255 if (buf[0] == '0' && --n == w)
256 ++b;
257 else
258#endif
259 {
260 while(--w >= 0)
261 PUT('*');
262 return 0;
263 }
264 }
265 for(w -= n; --w >= 0; )
266 PUT(' ');
267 if (sign)
268 PUT('-');
269 else if (f__cplus)
270 PUT('+');
271 while(n = *b++)
272 PUT(n);
273 while(--d1 >= 0)
274 PUT('0');
275 return 0;
276 }
Note: See TracBrowser for help on using the repository browser.