source: trunk/src/gcc/libf2c/libI77/lwrite.c@ 81

Last change on this file since 81 was 2, checked in by bird, 23 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#include "fmt.h"
4#include "lio.h"
5
6ftnint L_len;
7int f__Aquote;
8
9 static VOID
10donewrec(Void)
11{
12 if (f__recpos)
13 (*f__donewrec)();
14 }
15
16 static VOID
17#ifdef KR_headers
18lwrt_I(n) longint n;
19#else
20lwrt_I(longint n)
21#endif
22{
23 char *p;
24 int ndigit, sign;
25
26 p = f__icvt(n, &ndigit, &sign, 10);
27 if(f__recpos + ndigit >= L_len)
28 donewrec();
29 PUT(' ');
30 if (sign)
31 PUT('-');
32 while(*p)
33 PUT(*p++);
34}
35 static VOID
36#ifdef KR_headers
37lwrt_L(n, len) ftnint n; ftnlen len;
38#else
39lwrt_L(ftnint n, ftnlen len)
40#endif
41{
42 if(f__recpos+LLOGW>=L_len)
43 donewrec();
44 wrt_L((Uint *)&n,LLOGW, len);
45}
46 static VOID
47#ifdef KR_headers
48lwrt_A(p,len) char *p; ftnlen len;
49#else
50lwrt_A(char *p, ftnlen len)
51#endif
52{
53 int a;
54 char *p1, *pe;
55
56 a = 0;
57 pe = p + len;
58 if (f__Aquote) {
59 a = 3;
60 if (len > 1 && p[len-1] == ' ') {
61 while(--len > 1 && p[len-1] == ' ');
62 pe = p + len;
63 }
64 p1 = p;
65 while(p1 < pe)
66 if (*p1++ == '\'')
67 a++;
68 }
69 if(f__recpos+len+a >= L_len)
70 donewrec();
71 if (a
72#ifndef OMIT_BLANK_CC
73 || !f__recpos
74#endif
75 )
76 PUT(' ');
77 if (a) {
78 PUT('\'');
79 while(p < pe) {
80 if (*p == '\'')
81 PUT('\'');
82 PUT(*p++);
83 }
84 PUT('\'');
85 }
86 else
87 while(p < pe)
88 PUT(*p++);
89}
90
91 static int
92#ifdef KR_headers
93l_g(buf, n) char *buf; double n;
94#else
95l_g(char *buf, double n)
96#endif
97{
98#ifdef Old_list_output
99 doublereal absn;
100 char *fmt;
101
102 absn = n;
103 if (absn < 0)
104 absn = -absn;
105 fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
106#ifdef USE_STRLEN
107 sprintf(buf, fmt, n);
108 return strlen(buf);
109#else
110 return sprintf(buf, fmt, n);
111#endif
112
113#else
114 register char *b, c, c1;
115
116 b = buf;
117 *b++ = ' ';
118 if (n < 0) {
119 *b++ = '-';
120 n = -n;
121 }
122 else
123 *b++ = ' ';
124 if (n == 0) {
125 *b++ = '0';
126 *b++ = '.';
127 *b = 0;
128 goto f__ret;
129 }
130 sprintf(b, LGFMT, n);
131 switch(*b) {
132#ifndef WANT_LEAD_0
133 case '0':
134 while(b[0] = b[1])
135 b++;
136 break;
137#endif
138 case 'i':
139 case 'I':
140 /* Infinity */
141 case 'n':
142 case 'N':
143 /* NaN */
144 while(*++b);
145 break;
146
147 default:
148 /* Fortran 77 insists on having a decimal point... */
149 for(;; b++)
150 switch(*b) {
151 case 0:
152 *b++ = '.';
153 *b = 0;
154 goto f__ret;
155 case '.':
156 while(*++b);
157 goto f__ret;
158 case 'E':
159 for(c1 = '.', c = 'E'; *b = c1;
160 c1 = c, c = *++b);
161 goto f__ret;
162 }
163 }
164 f__ret:
165 return b - buf;
166#endif
167 }
168
169 static VOID
170#ifdef KR_headers
171l_put(s) register char *s;
172#else
173l_put(register char *s)
174#endif
175{
176#ifdef KR_headers
177 register void (*pn)() = f__putn;
178#else
179 register void (*pn)(int) = f__putn;
180#endif
181 register int c;
182
183 while(c = *s++)
184 (*pn)(c);
185 }
186
187 static VOID
188#ifdef KR_headers
189lwrt_F(n) double n;
190#else
191lwrt_F(double n)
192#endif
193{
194 char buf[LEFBL];
195
196 if(f__recpos + l_g(buf,n) >= L_len)
197 donewrec();
198 l_put(buf);
199}
200 static VOID
201#ifdef KR_headers
202lwrt_C(a,b) double a,b;
203#else
204lwrt_C(double a, double b)
205#endif
206{
207 char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
208 int al, bl;
209
210 al = l_g(bufa, a);
211 for(ba = bufa; *ba == ' '; ba++)
212 --al;
213 bl = l_g(bufb, b) + 1; /* intentionally high by 1 */
214 for(bb = bufb; *bb == ' '; bb++)
215 --bl;
216 if(f__recpos + al + bl + 3 >= L_len)
217 donewrec();
218#ifdef OMIT_BLANK_CC
219 else
220#endif
221 PUT(' ');
222 PUT('(');
223 l_put(ba);
224 PUT(',');
225 if (f__recpos + bl >= L_len) {
226 (*f__donewrec)();
227#ifndef OMIT_BLANK_CC
228 PUT(' ');
229#endif
230 }
231 l_put(bb);
232 PUT(')');
233}
234#ifdef KR_headers
235l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
236#else
237l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
238#endif
239{
240#define Ptr ((flex *)ptr)
241 int i;
242 longint x;
243 double y,z;
244 real *xx;
245 doublereal *yy;
246 for(i=0;i< *number; i++)
247 {
248 switch((int)type)
249 {
250 default: f__fatal(204,"unknown type in lio");
251 case TYINT1:
252 x = Ptr->flchar;
253 goto xint;
254 case TYSHORT:
255 x=Ptr->flshort;
256 goto xint;
257#ifdef Allow_TYQUAD
258 case TYQUAD:
259 x = Ptr->fllongint;
260 goto xint;
261#endif
262 case TYLONG:
263 x=Ptr->flint;
264 xint: lwrt_I(x);
265 break;
266 case TYREAL:
267 y=Ptr->flreal;
268 goto xfloat;
269 case TYDREAL:
270 y=Ptr->fldouble;
271 xfloat: lwrt_F(y);
272 break;
273 case TYCOMPLEX:
274 xx= &Ptr->flreal;
275 y = *xx++;
276 z = *xx;
277 goto xcomplex;
278 case TYDCOMPLEX:
279 yy = &Ptr->fldouble;
280 y= *yy++;
281 z = *yy;
282 xcomplex:
283 lwrt_C(y,z);
284 break;
285 case TYLOGICAL1:
286 x = Ptr->flchar;
287 goto xlog;
288 case TYLOGICAL2:
289 x = Ptr->flshort;
290 goto xlog;
291 case TYLOGICAL:
292 x = Ptr->flint;
293 xlog: lwrt_L(Ptr->flint, len);
294 break;
295 case TYCHAR:
296 lwrt_A(ptr,len);
297 break;
298 }
299 ptr += len;
300 }
301 return(0);
302}
Note: See TracBrowser for help on using the repository browser.