projects / unix-history / blame
? search:
summary | tags | clone url | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
syscons util remove use kbdcontrol & vidcontrol instead
[unix-history] / lib / libI77 / lread.c
CommitLineData
bae7117f
WH		 1#include "f2c.h"
2#include "fio.h"
3#include "fmt.h"
4#include "lio.h"
5#include "ctype.h"
6#include "fp.h"
7
8extern char *f__fmtbuf;
9#ifdef KR_headers
10extern double atof();
11extern char *malloc(), *realloc();
12int (*f__lioproc)(), (*l_getc)(), (*l_ungetc)();
13#else
14#undef abs
15#undef min
16#undef max
17#include "stdlib.h"
18int (*f__lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
19 (*l_ungetc)(int,FILE*);
20#endif
21int l_eof;
22
23#define isblnk(x) (f__ltab[x+1]&B)
24#define issep(x) (f__ltab[x+1]&SX)
25#define isapos(x) (f__ltab[x+1]&AX)
26#define isexp(x) (f__ltab[x+1]&EX)
27#define issign(x) (f__ltab[x+1]&SG)
28#define iswhit(x) (f__ltab[x+1]&WH)
29#define SX 1
30#define B 2
31#define AX 4
32#define EX 8
33#define SG 16
34#define WH 32
35char f__ltab[128+1] = { /* offset one for EOF */
36 0,
37 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
38 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
39 SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
40 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
41 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
42 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
43 AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
44 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
45};
46
47#ifdef ungetc
48 static int
49#ifdef KR_headers
50un_getc(x,f__cf) int x; FILE *f__cf;
51#else
52un_getc(int x, FILE *f__cf)
53#endif
54{ return ungetc(x,f__cf); }
55#else
56#define un_getc ungetc
57#ifdef KR_headers
58 extern int ungetc();
59#endif
60#endif
61
62t_getc(Void)
63{ int ch;
64 if(f__curunit->uend) return(EOF);
65 if((ch=getc(f__cf))!=EOF) return(ch);
66 if(feof(f__cf))
67 f__curunit->uend = l_eof = 1;
68 return(EOF);
69}
70integer e_rsle(Void)
71{
72 int ch;
73 if(f__curunit->uend) return(0);
74 while((ch=t_getc())!='\n' && ch!=EOF);
75 return(0);
76}
77
78flag f__lquit;
79int f__lcount,f__ltype,nml_read;
80char *f__lchar;
81double f__lx,f__ly;
82#define ERR(x) if(n=(x)) return(n)
83#define GETC(x) (x=(*l_getc)())
84#define Ungetc(x,y) (*l_ungetc)(x,y)
85
86#ifdef KR_headers
87l_R(poststar) int poststar;
88#else
89l_R(int poststar)
90#endif
91{
92 char s[FMAX+EXPMAXDIGS+4];
93 register int ch;
94 register char *sp, *spe, *sp1;
95 long e, exp;
96 int havenum, havestar, se;
97
98 if (!poststar) {
99 if (f__lcount > 0)
100 return(0);
101 f__lcount = 1;
102 }
103 f__ltype = 0;
104 exp = 0;
105 havestar = 0;
106retry:
107 sp1 = sp = s;
108 spe = sp + FMAX;
109 havenum = 0;
110
111 switch(GETC(ch)) {
112 case '-': *sp++ = ch; sp1++; spe++;
113 case '+':
114 GETC(ch);
115 }
116 while(ch == '0') {
117 ++havenum;
118 GETC(ch);
119 }
120 while(isdigit(ch)) {
121 if (sp < spe) *sp++ = ch;
122 else ++exp;
123 GETC(ch);
124 }
125 if (ch == '*' && !poststar) {
126 if (sp == sp1 || exp || *s == '-') {
127 errfl(f__elist->cierr,112,"bad repetition count");
128 }
129 poststar = havestar = 1;
130 *sp = 0;
131 f__lcount = atoi(s);
132 goto retry;
133 }
134 if (ch == '.') {
135 GETC(ch);
136 if (sp == sp1)
137 while(ch == '0') {
138 ++havenum;
139 --exp;
140 GETC(ch);
141 }
142 while(isdigit(ch)) {
143 if (sp < spe)
144 { *sp++ = ch; --exp; }
145 GETC(ch);
146 }
147 }
148 havenum += sp - sp1;
149 se = 0;
150 if (issign(ch))
151 goto signonly;
152 if (havenum && isexp(ch)) {
153 GETC(ch);
154 if (issign(ch)) {
155signonly:
156 if (ch == '-') se = 1;
157 GETC(ch);
158 }
159 if (!isdigit(ch)) {
160bad:
161 errfl(f__elist->cierr,112,"exponent field");
162 }
163
164 e = ch - '0';
165 while(isdigit(GETC(ch))) {
166 e = 10*e + ch - '0';
167 if (e > EXPMAX)
168 goto bad;
169 }
170 if (se)
171 exp -= e;
172 else
173 exp += e;
174 }
175 (void) Ungetc(ch, f__cf);
176 if (sp > sp1) {
177 ++havenum;
178 while(*--sp == '0')
179 ++exp;
180 if (exp)
181 sprintf(sp+1, "e%ld", exp);
182 else
183 sp[1] = 0;
184 f__lx = atof(s);
185 }
186 else
187 f__lx = 0.;
188 if (havenum)
189 f__ltype = TYLONG;
190 else
191 switch(ch) {
192 case ',':
193 case '/':
194 break;
195 default:
196 if (havestar && ( ch == ' '
197 ||ch == '\t'
198 ||ch == '\n'))
199 break;
200 if (nml_read > 1) {
201 f__lquit = 2;
202 return 0;
203 }
204 errfl(f__elist->cierr,112,"invalid number");
205 }
206 return 0;
207 }
208
209 static int
210#ifdef KR_headers
211rd_count(ch) register int ch;
212#else
213rd_count(register int ch)
214#endif
215{
216 if (ch < '0' || ch > '9')
217 return 1;
218 f__lcount = ch - '0';
219 while(GETC(ch) >= '0' && ch <= '9')
220 f__lcount = 10*f__lcount + ch - '0';
221 Ungetc(ch,f__cf);
222 return f__lcount <= 0;
223 }
224
225l_C(Void)
226{ int ch, nml_save;
227 double lz;
228 if(f__lcount>0) return(0);
229 f__ltype=0;
230 GETC(ch);
231 if(ch!='(')
232 {
233 if (nml_read > 1 && (ch < '0' || ch > '9')) {
234 Ungetc(ch,f__cf);
235 f__lquit = 2;
236 return 0;
237 }
238 if (rd_count(ch))
239 if(!f__cf || !feof(f__cf))
240 errfl(f__elist->cierr,112,"complex format");
241 else
242 err(f__elist->cierr,(EOF),"lread");
243 if(GETC(ch)!='*')
244 {
245 if(!f__cf || !feof(f__cf))
246 errfl(f__elist->cierr,112,"no star");
247 else
248 err(f__elist->cierr,(EOF),"lread");
249 }
250 if(GETC(ch)!='(')
251 { Ungetc(ch,f__cf);
252 return(0);
253 }
254 }
255 else
256 f__lcount = 1;
257 while(iswhit(GETC(ch)));
258 Ungetc(ch,f__cf);
259 nml_save = nml_read;
260 nml_read = 0;
261 if (ch = l_R(1))
262 return ch;
263 if (!f__ltype)
264 errfl(f__elist->cierr,112,"no real part");
265 lz = f__lx;
266 while(iswhit(GETC(ch)));
267 if(ch!=',')
268 { (void) Ungetc(ch,f__cf);
269 errfl(f__elist->cierr,112,"no comma");
270 }
271 while(iswhit(GETC(ch)));
272 (void) Ungetc(ch,f__cf);
273 if (ch = l_R(1))
274 return ch;
275 if (!f__ltype)
276 errfl(f__elist->cierr,112,"no imaginary part");
277 while(iswhit(GETC(ch)));
278 if(ch!=')') errfl(f__elist->cierr,112,"no )");
279 f__ly = f__lx;
280 f__lx = lz;
281 nml_read = nml_save;
282 return(0);
283}
284l_L(Void)
285{
286 int ch;
287 if(f__lcount>0) return(0);
288 f__lcount = 1;
289 f__ltype=0;
290 GETC(ch);
291 if(isdigit(ch))
292 {
293 rd_count(ch);
294 if(GETC(ch)!='*')
295 if(!f__cf || !feof(f__cf))
296 errfl(f__elist->cierr,112,"no star");
297 else
298 err(f__elist->cierr,(EOF),"lread");
299 GETC(ch);
300 }
301 if(ch == '.') GETC(ch);
302 switch(ch)
303 {
304 case 't':
305 case 'T':
306 f__lx=1;
307 break;
308 case 'f':
309 case 'F':
310 f__lx=0;
311 break;
312 default:
313 if(isblnk(ch) || issep(ch) || ch==EOF)
314 { (void) Ungetc(ch,f__cf);
315 return(0);
316 }
317 if (nml_read > 1) {
318 Ungetc(ch,f__cf);
319 f__lquit = 2;
320 return 0;
321 }
322 errfl(f__elist->cierr,112,"logical");
323 }
324 f__ltype=TYLONG;
325 while(!issep(GETC(ch)) && ch!=EOF);
326 (void) Ungetc(ch, f__cf);
327 return(0);
328}
329#define BUFSIZE 128
330l_CHAR(Void)
331{ int ch,size,i;
332 char quote,*p;
333 if(f__lcount>0) return(0);
334 f__ltype=0;
335 if(f__lchar!=NULL) free(f__lchar);
336 size=BUFSIZE;
337 p=f__lchar = (char *)malloc((unsigned int)size);
338 if(f__lchar == NULL)
339 errfl(f__elist->cierr,113,"no space");
340
341 GETC(ch);
342 if(isdigit(ch)) {
343 /* allow Fortran 8x-style unquoted string... */
344 /* either find a repetition count or the string */
345 f__lcount = ch - '0';
346 *p++ = ch;
347 for(i = 1;;) {
348 switch(GETC(ch)) {
349 case '*':
350 if (f__lcount == 0) {
351 f__lcount = 1;
352 goto noquote;
353 }
354 p = f__lchar;
355 goto have_lcount;
356 case ',':
357 case ' ':
358 case '\t':
359 case '\n':
360 case '/':
361 Ungetc(ch,f__cf);
362 /* no break */
363 case EOF:
364 f__lcount = 1;
365 f__ltype = TYCHAR;
366 return *p = 0;
367 }
368 if (!isdigit(ch)) {
369 f__lcount = 1;
370 goto noquote;
371 }
372 *p++ = ch;
373 f__lcount = 10*f__lcount + ch - '0';
374 if (++i == size) {
375 f__lchar = (char *)realloc(f__lchar,
376 (unsigned int)(size += BUFSIZE));
377 p = f__lchar + i;
378 }
379 }
380 }
381 else (void) Ungetc(ch,f__cf);
382 have_lcount:
383 if(GETC(ch)=='\'' || ch=='"') quote=ch;
384 else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
385 { (void) Ungetc(ch,f__cf);
386 return(0);
387 }
388 else {
389 /* Fortran 8x-style unquoted string */
390 *p++ = ch;
391 for(i = 1;;) {
392 switch(GETC(ch)) {
393 case ',':
394 case ' ':
395 case '\t':
396 case '\n':
397 case '/':
398 Ungetc(ch,f__cf);
399 /* no break */
400 case EOF:
401 f__ltype = TYCHAR;
402 return *p = 0;
403 }
404 noquote:
405 *p++ = ch;
406 if (++i == size) {
407 f__lchar = (char *)realloc(f__lchar,
408 (unsigned int)(size += BUFSIZE));
409 p = f__lchar + i;
410 }
411 }
412 }
413 f__ltype=TYCHAR;
414 for(i=0;;)
415 { while(GETC(ch)!=quote && ch!='\n'
416 && ch!=EOF && ++i<size) *p++ = ch;
417 if(i==size)
418 {
419 newone:
420 f__lchar= (char *)realloc(f__lchar,
421 (unsigned int)(size += BUFSIZE));
422 p=f__lchar+i-1;
423 *p++ = ch;
424 }
425 else if(ch==EOF) return(EOF);
426 else if(ch=='\n')
427 { if(*(p-1) != '\\') continue;
428 i--;
429 p--;
430 if(++i<size) *p++ = ch;
431 else goto newone;
432 }
433 else if(GETC(ch)==quote)
434 { if(++i<size) *p++ = ch;
435 else goto newone;
436 }
437 else
438 { (void) Ungetc(ch,f__cf);
439 *p = 0;
440 return(0);
441 }
442 }
443}
444#ifdef KR_headers
445c_le(a) cilist *a;
446#else
447c_le(cilist *a)
448#endif
449{
450 f__fmtbuf="list io";
451 if(a->ciunit>=MXUNIT || a->ciunit<0)
452 err(a->cierr,101,"stler");
453 f__scale=f__recpos=0;
454 f__elist=a;
455 f__curunit = &f__units[a->ciunit];
456 if(f__curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
457 err(a->cierr,102,"lio");
458 f__cf=f__curunit->ufd;
459 if(!f__curunit->ufmt) err(a->cierr,103,"lio")
460 return(0);
461}
462#ifdef KR_headers
463l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
464#else
465l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
466#endif
467{
468#define Ptr ((flex *)ptr)
469 int i,n,ch;
470 doublereal *yy;
471 real *xx;
472 for(i=0;i<*number;i++)
473 {
474 if(f__lquit) return(0);
475 if(l_eof)
476 err(f__elist->ciend, EOF, "list in")
477 if(f__lcount == 0) {
478 f__ltype = 0;
479 for(;;) {
480 GETC(ch);
481 switch(ch) {
482 case EOF:
483 goto loopend;
484 case ' ':
485 case '\t':
486 case '\n':
487 continue;
488 case '/':
489 f__lquit = 1;
490 goto loopend;
491 case ',':
492 f__lcount = 1;
493 goto loopend;
494 default:
495 (void) Ungetc(ch, f__cf);
496 goto rddata;
497 }
498 }
499 }
500 rddata:
501 switch((int)type)
502 {
503 case TYINT1:
504 case TYSHORT:
505 case TYLONG:
506#ifdef TYQUAD
507 case TYQUAD:
508#endif
509 case TYREAL:
510 case TYDREAL:
511 ERR(l_R(0));
512 break;
513 case TYCOMPLEX:
514 case TYDCOMPLEX:
515 ERR(l_C());
516 break;
517 case TYLOGICAL1:
518 case TYLOGICAL2:
519 case TYLOGICAL:
520 ERR(l_L());
521 break;
522 case TYCHAR:
523 ERR(l_CHAR());
524 break;
525 }
526 while (GETC(ch) == ' ' || ch == '\t');
527 if (ch != ',' || f__lcount > 1)
528 Ungetc(ch,f__cf);
529 loopend:
530 if(f__lquit) return(0);
531 if(f__cf) {
532 if (feof(f__cf))
533 err(f__elist->ciend,(EOF),"list in")
534 else if(ferror(f__cf)) {
535 clearerr(f__cf);
536 errfl(f__elist->cierr,errno,"list in");
537 }
538 }
539 if(f__ltype==0) goto bump;
540 switch((int)type)
541 {
542 case TYINT1:
543 case TYLOGICAL1:
544 Ptr->flchar = (char)f__lx;
545 break;
546 case TYLOGICAL2:
547 case TYSHORT:
548 Ptr->flshort = (short)f__lx;
549 break;
550 case TYLOGICAL:
551 case TYLONG:
552 Ptr->flint=f__lx;
553 break;
554#ifdef TYQUAD
555 case TYQUAD:
556 Ptr->fllongint = f__lx;
557 break;
558#endif
559 case TYREAL:
560 Ptr->flreal=f__lx;
561 break;
562 case TYDREAL:
563 Ptr->fldouble=f__lx;
564 break;
565 case TYCOMPLEX:
566 xx=(real *)ptr;
567 *xx++ = f__lx;
568 *xx = f__ly;
569 break;
570 case TYDCOMPLEX:
571 yy=(doublereal *)ptr;
572 *yy++ = f__lx;
573 *yy = f__ly;
574 break;
575 case TYCHAR:
576 b_char(f__lchar,ptr,len);
577 break;
578 }
579 bump:
580 if(f__lcount>0) f__lcount--;
581 ptr += len;
582 if (nml_read)
583 nml_read++;
584 }
585 return(0);
586#undef Ptr
587}
588#ifdef KR_headers
589integer s_rsle(a) cilist *a;
590#else
591integer s_rsle(cilist *a)
592#endif
593{
594 int n;
595
596 if(!f__init) f_init();
597 if(n=c_le(a)) return(n);
598 f__reading=1;
599 f__external=1;
600 f__formatted=1;
601 f__lioproc = l_read;
602 f__lquit = 0;
603 f__lcount = 0;
604 l_eof = 0;
605 if(f__curunit->uwrt && f__nowreading(f__curunit))
606 err(a->cierr,errno,"read start");
607 l_getc = t_getc;
608 l_ungetc = un_getc;
609 f__doend = xrd_SL;
610 return(0);
611}
Continuous source code history from original PDP-7 UNIX to FreeBSD 2, the first fully unencumbered FreeBSD release.