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}
303