![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to libI77.st0 CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to libI77.st0 CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: ./ ADD NAME=libI77/README TIME=627747849
2: If your system lacks /usr/include/local.h ,
3: then you should create an appropriate local.h in
4: this directory. An appropriate local.h may simply
5: be empty, or it may #define VAX or #define CRAY
6: (or whatever else you must do to make fp.h work right).
7: Alternatively, edit fp.h to suite your machine.
8:
9: If your system's sprintf does not work the way ANSI C
10: specifies -- specifically, if it does not return the
11: number of characters transmitted -- then insert the line
12:
13: #define USE_STRLEN
14:
15: at the beginning of wref.c . This is necessary with
16: at least some versions of Sun software.
17:
18: If you get error messages about references to cf->_ptr
19: and cf->_base when compiling wrtfmt.c and wsfe.c or to
20: stderr->_flag when compiling err.c, then insert the line
21:
22: #define NON_UNIX_STDIO
23:
24: at the beginning of fio.h, and recompile these modules.
25:
26: You may need to supply the following non-ANSI routines:
27:
28: access(char *Name, 0) is supposed to return 0
29: if file Name exists, nonzero otherwise.
30:
31: fstat(int fileds, struct stat *buf) is similar
32: to stat(char *name, struct stat *buf), except that
33: the first argument, fileds, is the file descriptor
34: returned by open rather than the name of the file.
35: fstat is used in the system-dependent routine
36: canseek (in the libI77 source file err.c), which
37: is supposed to return 1 if it's possible to issue
38: seeks on the file in question, 0 if it's not; you may
39: need to suitably modify err.c
40:
41: char * mktemp(char *buf) is supposed to replace the
42: 6 trailing X's in buf with a unique number and then
43: return buf. The idea is to get a unique name for
44: a temporary file.
45: ./ ADD NAME=libI77/makefile TIME=628988590
46: .SUFFIXES: .c .o
47:
48: CFLAGS =-I. -O
49:
50: # compile, then strip unnecessary symbols
51: .c.o:
52: cc $(CFLAGS) -c $*.c
53: ld -r -x $*.o
54: mv a.out $*.o
55:
56: OBJ = Version.o backspace.o dfe.o due.o iio.o inquire.o rewind.o rsfe.o \
57: rdfmt.o sue.o uio.o wsfe.o sfe.o fmt.o lio.o lread.o open.o \
58: close.o util.o endfile.o wrtfmt.o wref.o err.o fmtlib.o
59:
60: libI77.a: $(OBJ)
61: ar r libI77.a $?
62: ranlib libI77.a
63: install: libI77.a
64: cp libI77.a /usr/lib/libI77.a
65: ranlib /usr/lib/libI77.a
66:
67: lio.o: lio.h
68: SRC= lio.h fio.h fmt.h backspace.c dfe.c due.c iio.c inquire.c rewind.c \
69: rsfe.c rdfmt.c sue.c uio.c wsfe.c sfe.c fmt.c lio.c lread.c open.c \
70: close.c util.c endfile.c wrtfmt.c wref.c err.c fmtlib.c
71:
72: Version.o: Version.c
73: cc -c Version.c
74:
75:
76: clean:
77: rm -f $(OBJ) libI77.a
78:
79: clobber: clean
80: rm -f libI77.a
81:
82: backspace.o: fio.h
83: close.o: fio.h
84: dfe.o: fio.h
85: dfe.o: fmt.h
86: due.o: fio.h
87: endfile.o: fio.h
88: err.o: fio.h
89: fmt.o: fio.h
90: fmt.o: fmt.h
91: ftest.o: fio.h
92: iio.o: fio.h
93: iio.o: fmt.h
94: inquire.o: fio.h
95: lib.o: fio.h
96: lio.o: fio.h
97: lio.o: fmt.h
98: lio.o: lio.h
99: lread.o: fio.h
100: lread.o: fmt.h
101: lread.o: lio.h
102: lread.o: fp.h
103: nio.o: fio.h
104: nio.o: fmt.h
105: nio.o: lio.h
106: open.o: fio.h
107: rdfmt.o: fio.h
108: rdfmt.o: fmt.h
109: rdfmt.o: fp.h
110: rewind.o: fio.h
111: rsfe.o: fio.h
112: rsfe.o: fmt.h
113: sfe.o: fio.h
114: stest.o: fio.h
115: sue.o: fio.h
116: uio.o: fio.h
117: util.o: fio.h
118: wref.o: fio.h fmt.h fp.h
119: wrtfmt.o: fio.h
120: wrtfmt.o: fmt.h
121: wsfe.o: fio.h
122: wsfe.o: fmt.h
123: namelist.o: fio.h lio.h
124: ./ ADD NAME=libI77/Version.c TIME=628965828
125: static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 6 Dec. 1989\n";
126:
127: /*
128: 2.01 $ format added
129: 2.02 Coding bug in open.c repaired
130: 2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c
131: and lio.h (e-format conforming to spec)
132: 2.04 changed open.c and err.c (fopen and freopen respectively) to
133: update to new c-library (append mode)
134: 2.05 added namelist capability
135: */
136:
137: /*
138: close.c:
139: allow upper-case STATUS= values
140: endfile.c
141: create fort.nnn if unit nnn not open;
142: else if (file length == 0) use creat() rather than copy;
143: use local copy() rather than forking /bin/cp;
144: rewind, fseek to clear buffer (for no reading past EOF)
145: err.c
146: use neither setbuf nor setvbuf; make stderr buffered
147: fio.h
148: #define _bufend
149: inquire.c
150: upper case responses;
151: omit byfile test from SEQUENTIAL=
152: answer "YES" to DIRECT= for unopened file (open to debate)
153: lio.c
154: flush stderr, stdout at end of each stmt
155: space before character strings in list output only at line start
156: lio.h
157: adjust LEW, LED consistent with old libI77
158: lread.c
159: use atof()
160: allow "nnn*," when reading complex constants
161: open.c
162: try opening for writing when open for read fails, with
163: special uwrt value (2) delaying creat() to first write;
164: set curunit so error messages don't drop core;
165: no file name ==> fort.nnn except for STATUS='SCRATCH'
166: rdfmt.c
167: use atof(); trust EOF == end-of-file (so don't read past
168: end-of-file after endfile stmt)
169: sfe.c
170: flush stderr, stdout at end of each stmt
171: wrtfmt.c:
172: use upper case
173: put wrt_E and wrt_F into wref.c, use sprintf()
174: rather than ecvt() and fcvt() [more accurate on VAX]
175: */
176:
177: /* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */
178:
179: /* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */
180:
181: /* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */
182: /* 29 Nov. 1989: change various int return types to long for f2c */
183: /* 30 Nov. 1989: various types from f2c.h */
184: /* 6 Dec. 1989: types corrected various places */
185: ./ ADD NAME=libI77/backspace.c TIME=628440563
186: #include "f2c.h"
187: #include "fio.h"
188: integer f_back(a) alist *a;
189: { unit *b;
190: int n,i;
191: long x;
192: char buf[32];
193: if(a->aunit >= MXUNIT || a->aunit < 0)
194: err(a->aerr,101,"backspace")
195: b= &units[a->aunit];
196: if(b->useek==0) err(a->aerr,106,"backspace")
197: if(b->ufd==NULL) {
198: fk_open(1, 1, a->aunit);
199: return(0);
200: }
201: if(b->uend==1)
202: { b->uend=0;
203: return(0);
204: }
205: if(b->uwrt) {
206: (void) t_runc(a);
207: if (nowreading(b))
208: err(a->aerr,errno,"backspace")
209: }
210: if(b->url>0)
211: { long y;
212: x=ftell(b->ufd);
213: y = x % b->url;
214: if(y == 0) x--;
215: x /= b->url;
216: x *= b->url;
217: (void) fseek(b->ufd,x,0);
218: return(0);
219: }
220:
221: if(b->ufmt==0)
222: { (void) fseek(b->ufd,-(long)sizeof(int),1);
223: (void) fread((char *)&n,sizeof(int),1,b->ufd);
224: (void) fseek(b->ufd,-(long)n-2*sizeof(int),1);
225: return(0);
226: }
227: for(;;)
228: { long y;
229: y = x=ftell(b->ufd);
230: if(x<sizeof(buf)) x=0;
231: else x -= sizeof(buf);
232: (void) fseek(b->ufd,x,0);
233: n=fread(buf,1,(int)(y-x), b->ufd);
234: for(i=n-2;i>=0;i--)
235: {
236: if(buf[i]!='\n') continue;
237: (void) fseek(b->ufd,(long)(i+1-n),1);
238: return(0);
239: }
240: if(x==0)
241: {
242: (void) fseek(b->ufd, 0L, 0);
243: return(0);
244: }
245: else if(n<=0) err(a->aerr,(EOF),"backspace")
246: (void) fseek(b->ufd, x, 0);
247: }
248: }
249: ./ ADD NAME=libI77/close.c TIME=628440563
250: #include "f2c.h"
251: #include "fio.h"
252: integer f_clos(a) cllist *a;
253: { unit *b;
254: if(a->cunit >= MXUNIT) return(0);
255: b= &units[a->cunit];
256: if(b->ufd==NULL) return(0);
257: b->uend=0;
258: if(a->csta!=0)
259: switch(*a->csta)
260: {
261: default:
262: keep:
263: case 'k':
264: case 'K':
265: if(b->uwrt == 1) (void) t_runc((alist *)a);
266: (void) fclose(b->ufd); /* sys 5 has strange beliefs */
267: if(b->ufnm!=0) free(b->ufnm);
268: b->ufnm=NULL;
269: b->ufd=NULL;
270: return(0);
271: case 'd':
272: case 'D':
273: delete:
274: (void) fclose(b->ufd);
275: if(b->ufnm!=0)
276: { (void) unlink(b->ufnm); /*SYSDEP*/
277: free(b->ufnm);
278: }
279: b->ufnm=NULL;
280: b->ufd=NULL;
281: return(0);
282: }
283: else if(b->uscrtch==1) goto delete;
284: else goto keep;
285: }
286: void
287: f_exit()
288: { int i;
289: static cllist xx;
290: if (!xx.cerr) {
291: xx.cerr=1;
292: xx.csta=NULL;
293: for(i=0;i<MXUNIT;i++)
294: {
295: xx.cunit=i;
296: (void) f_clos(&xx);
297: }
298: }
299: }
300: flush_()
301: { int i;
302: for(i=0;i<MXUNIT;i++)
303: if(units[i].ufd != NULL) (void) fflush(units[i].ufd);
304: }
305: ./ ADD NAME=libI77/dfe.c TIME=629055520
306: #include "f2c.h"
307: #include "fio.h"
308: #include "fmt.h"
309: extern int rd_ed(),rd_ned(),y_getc(),y_putc(),y_err();
310: extern int y_rev(), y_rsk(), y_newrec();
311: extern int w_ed(),w_ned();
312: integer s_rdfe(a) cilist *a;
313: {
314: int n;
315: if(!init) f_init();
316: if(n=c_dfe(a))return(n);
317: reading=1;
318: if(curunit->uwrt && nowreading(curunit))
319: err(a->cierr,errno,"read start");
320: getn = y_getc;
321: doed = rd_ed;
322: doned = rd_ned;
323: dorevert = donewrec = y_err;
324: doend = y_rsk;
325: if(pars_f(fmtbuf)<0)
326: err(a->cierr,100,"read start");
327: fmt_bg();
328: return(0);
329: }
330: integer s_wdfe(a) cilist *a;
331: {
332: int n;
333: if(!init) f_init();
334: if(n=c_dfe(a)) return(n);
335: reading=0;
336: if(curunit->uwrt != 1 && nowwriting(curunit))
337: err(a->cierr,errno,"startwrt");
338: putn = y_putc;
339: doed = w_ed;
340: doned= w_ned;
341: dorevert = y_err;
342: donewrec = y_newrec;
343: doend = y_rev;
344: if(pars_f(fmtbuf)<0)
345: err(a->cierr,100,"startwrt");
346: fmt_bg();
347: return(0);
348: }
349: integer e_rdfe()
350: {
351: (void) en_fio();
352: return(0);
353: }
354: integer e_wdfe()
355: {
356: (void) en_fio();
357: return(0);
358: }
359: c_dfe(a) cilist *a;
360: {
361: sequential=0;
362: formatted=external=1;
363: elist=a;
364: cursor=scale=recpos=0;
365: if(a->ciunit>MXUNIT || a->ciunit<0)
366: err(a->cierr,101,"startchk");
367: curunit = &units[a->ciunit];
368: if(curunit->ufd==NULL && fk_open(DIR,FMT,a->ciunit))
369: err(a->cierr,104,"dfe");
370: cf=curunit->ufd;
371: if(!curunit->ufmt) err(a->cierr,102,"dfe")
372: if(!curunit->useek) err(a->cierr,104,"dfe")
373: fmtbuf=a->cifmt;
374: (void) fseek(cf,(long)curunit->url * (a->cirec-1),0);
375: curunit->uend = 0;
376: return(0);
377: }
378: y_rsk()
379: {
380: if(curunit->uend || curunit->url <= recpos
381: || curunit->url == 1) return 0;
382: do {
383: getc(cf);
384: } while(++recpos < curunit->url);
385: return 0;
386: }
387: y_getc()
388: {
389: int ch;
390: if(curunit->uend) return(-1);
391: if((ch=getc(cf))!=EOF)
392: {
393: recpos++;
394: if(curunit->url>=recpos ||
395: curunit->url==1)
396: return(ch);
397: else return(' ');
398: }
399: if(feof(cf))
400: {
401: curunit->uend=1;
402: errno=0;
403: return(-1);
404: }
405: err(elist->cierr,errno,"readingd");
406: }
407: y_putc(c)
408: {
409: recpos++;
410: if(recpos <= curunit->url || curunit->url==1)
411: putc(c,cf);
412: else
413: err(elist->cierr,110,"dout");
414: return(0);
415: }
416: y_rev()
417: { /*what about work done?*/
418: if(curunit->url==1 || recpos==curunit->url)
419: return(0);
420: while(recpos<curunit->url)
421: (*putn)(' ');
422: recpos=0;
423: return(0);
424: }
425: y_err()
426: {
427: err(elist->cierr, 110, "dfe");
428: }
429:
430: y_newrec()
431: {
432: if(curunit->url == 1 || recpos == curunit->url) {
433: hiwater = recpos = cursor = 0;
434: return(1);
435: }
436: if(hiwater > recpos)
437: recpos = hiwater;
438: y_rev();
439: hiwater = cursor = 0;
440: return(1);
441: }
442: ./ ADD NAME=libI77/due.c TIME=628440563
443: #include "f2c.h"
444: #include "fio.h"
445: integer s_rdue(a) cilist *a;
446: {
447: int n;
448: if(n=c_due(a)) return(n);
449: reading=1;
450: if(curunit->uwrt && nowreading(curunit))
451: err(a->cierr,errno,"read start");
452: return(0);
453: }
454: integer s_wdue(a) cilist *a;
455: {
456: int n;
457: if(n=c_due(a)) return(n);
458: reading=0;
459: if(curunit->uwrt != 1 && nowwriting(curunit))
460: err(a->cierr,errno,"write start");
461: return(0);
462: }
463: c_due(a) cilist *a;
464: {
465: if(!init) f_init();
466: if(a->ciunit>=MXUNIT || a->ciunit<0)
467: err(a->cierr,101,"startio");
468: recpos=sequential=formatted=0;
469: external=1;
470: curunit = &units[a->ciunit];
471: elist=a;
472: if(curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
473: cf=curunit->ufd;
474: if(curunit->ufmt) err(a->cierr,102,"cdue")
475: if(!curunit->useek) err(a->cierr,104,"cdue")
476: if(curunit->ufd==NULL) err(a->cierr,114,"cdue")
477: (void) fseek(cf,(long)(a->cirec-1)*curunit->url,0);
478: curunit->uend = 0;
479: return(0);
480: }
481: integer e_rdue()
482: {
483: if(curunit->url==1 || recpos==curunit->url)
484: return(0);
485: (void) fseek(cf,(long)(curunit->url-recpos),1);
486: if(ftell(cf)%curunit->url)
487: err(elist->cierr,200,"syserr");
488: return(0);
489: }
490: integer e_wdue()
491: {
492: return(e_rdue());
493: }
494: ./ ADD NAME=libI77/endfile.c TIME=628440563
495: #include "f2c.h"
496: #include "fio.h"
497: extern char *mktemp(), *strcpy();
498: integer f_end(a) alist *a;
499: {
500: unit *b;
501: if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
502: b = &units[a->aunit];
503: if(b->ufd==NULL) {
504: char nbuf[10];
505: (void) sprintf(nbuf,"fort.%ld",a->aunit);
506: close(creat(nbuf, 0666));
507: return(0);
508: }
509: b->uend=1;
510: return(b->useek ? t_runc(a) : 0);
511: }
512:
513: static int
514: copy(from, len, to)
515: char *from, *to;
516: register long len;
517: {
518: register int n;
519: int k, rc = 0, tmp;
520: char buf[BUFSIZ];
521:
522: if ((k = open(from, 0)) < 0)
523: return 1;
524: if ((tmp = creat(to,0666)) < 0)
525: return 1;
526: while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
527: if (write(tmp, buf, n) != n)
528: { rc = 1; break; }
529: if ((len -= n) <= 0)
530: break;
531: }
532: close(k);
533: close(tmp);
534: return n < 0 ? 1 : rc;
535: }
536:
537: t_runc(a) alist *a;
538: {
539: char nm[16];
540: long loc, len;
541: unit *b;
542: int rc = 0;
543:
544: b = &units[a->aunit];
545: if(b->url) return(0); /*don't truncate direct files*/
546: loc=ftell(b->ufd);
547: (void) fseek(b->ufd,0L,2);
548: len=ftell(b->ufd);
549: if (loc >= len || b->useek == 0 || b->ufnm == NULL)
550: return(0);
551: rewind(b->ufd); /* empty buffer */
552: if (!loc) {
553: if (close(creat(b->ufnm,0666)))
554: { rc = 1; goto done; }
555: if (b->uwrt)
556: b->uwrt = 1;
557: return 0;
558: }
559: (void) strcpy(nm,"tmp.FXXXXXX");
560: (void) mktemp(nm);
561: if (copy(b->ufnm, loc, nm)
562: || copy(nm, loc, b->ufnm))
563: rc = 1;
564: unlink(nm);
565: done:
566: fseek(b->ufd, loc, 0);
567: if (rc)
568: err(a->aerr,111,"endfile");
569: return 0;
570: }
571: ./ ADD NAME=libI77/err.c TIME=628473361
572: #include "sys/types.h"
573: #include "sys/stat.h"
574: #include "f2c.h"
575: #include "fio.h"
576:
577: extern FILE *fdopen();
578:
579: /*global definitions*/
580: unit units[MXUNIT]; /*unit table*/
581: flag init; /*0 on entry, 1 after initializations*/
582: cilist *elist; /*active external io list*/
583: flag reading; /*1 if reading, 0 if writing*/
584: flag cplus,cblank;
585: char *fmtbuf;
586: flag external; /*1 if external io, 0 if internal */
587: int (*doed)(),(*doned)();
588: int (*doend)(),(*donewrec)(),(*dorevert)();
589: flag sequential; /*1 if sequential io, 0 if direct*/
590: flag formatted; /*1 if formatted io, 0 if unformatted*/
591: int (*getn)(),(*putn)(); /*for formatted io*/
592: FILE *cf; /*current file*/
593: unit *curunit; /*current unit*/
594: int recpos; /*place in current record*/
595: int cursor,scale;
596:
597: /*error messages*/
598: char *F_err[] =
599: {
600: "error in format", /* 100 */
601: "illegal unit number", /* 101 */
602: "formatted io not allowed", /* 102 */
603: "unformatted io not allowed", /* 103 */
604: "direct io not allowed", /* 104 */
605: "sequential io not allowed", /* 105 */
606: "can't backspace file", /* 106 */
607: "null file name", /* 107 */
608: "can't stat file", /* 108 */
609: "unit not connected", /* 109 */
610: "off end of record", /* 110 */
611: "truncation failed in endfile", /* 111 */
612: "incomprehensible list input", /* 112 */
613: "out of free space", /* 113 */
614: "unit not connected", /* 114 */
615: "read unexpected character", /* 115 */
616: "blank logical input field", /* 116 */
617: "bad variable type", /* 117 */
618: "bad namelist name", /* 118 */
619: "variable not in namelist", /* 119 */
620: "no end record", /* 120 */
621: "variable count incorrect" /* 121 */
622: };
623: #define MAXERR (sizeof(F_err)/sizeof(char *)+100)
624: fatal(n,s) char *s;
625: {
626: if(n<100 && n>=0) perror(s); /*SYSDEP*/
627: else if(n >= (int)MAXERR || n < -1)
628: { fprintf(stderr,"%s: illegal error number %d\n",s,n);
629: }
630: else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
631: else
632: fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
633: fprintf(stderr,"apparent state: unit %d ",curunit-units);
634: fprintf(stderr, curunit->ufnm ? "named %s\n" : "(unnamed)\n",
635: curunit->ufnm);
636: if (fmtbuf)
637: fprintf(stderr,"last format: %s\n",fmtbuf);
638: fprintf(stderr,"lately %s %s %s %s IO\n",reading?"reading":"writing",
639: sequential?"sequential":"direct",formatted?"formatted":"unformatted",
640: external?"external":"internal");
641: _cleanup();
642: abort();
643: }
644: /*initialization routine*/
645: f_init()
646: { unit *p;
647:
648: init=1;
649: p= &units[0];
650: p->ufd=stderr;
651: p->useek=canseek(stderr);
652: #ifdef COMMENTED_OUT
653: if(isatty(fileno(stderr))) {
654: extern char *malloc();
655: setbuf(stderr, malloc(BUFSIZ));
656: /* setvbuf(stderr, _IOLBF, 0, 0); */
657: } /* wastes space, but win for debugging in windows */
658: #endif
659: #ifdef NON_UNIX_STDIO
660: {extern char *malloc(); setbuf(stderr, malloc(BUFSIZ));}
661: #else
662: stderr->_flag &= ~_IONBF;
663: #endif
664: p->ufmt=1;
665: p->uwrt=1;
666: p = &units[5];
667: p->ufd=stdin;
668: p->useek=canseek(stdin);
669: p->ufmt=1;
670: p->uwrt=0;
671: p= &units[6];
672: p->ufd=stdout;
673: p->useek=canseek(stdout);
674: /* IOLBUF and setvbuf only in system 5+ */
675: #ifdef COMMENTED_OUT
676: if(isatty(fileno(stdout))) {
677: extern char _sobuf[];
678: setbuf(stdout, _sobuf);
679: /* setvbuf(stdout, _IOLBF, 0, 0); /* the buf arg in setvbuf? */
680: p->useek = 1; /* only within a record no bigger than BUFSIZ */
681: }
682: #endif
683: p->ufmt=1;
684: p->uwrt=1;
685: }
686: canseek(f) FILE *f; /*SYSDEP*/
687: { struct stat x;
688: if(fstat(fileno(f),&x) < 0)
689: return(0);
690: switch(x.st_mode & S_IFMT) {
691: case S_IFDIR:
692: case S_IFREG:
693: if(x.st_nlink > 0) /* !pipe */
694: return(1);
695: else
696: return(0);
697: case S_IFCHR:
698: if(isatty(fileno(f)))
699: return(0);
700: return(1);
701: #ifdef S_IFBLK
702: case S_IFBLK:
703: return(1);
704: #endif
705: }
706: return(0); /* who knows what it is? */
707: }
708: nowreading(x) unit *x;
709: {
710: long loc;
711: x->uwrt=0;
712: loc=ftell(x->ufd);
713: if(freopen(x->ufnm,"r",x->ufd) == NULL)
714: return(1);
715: (void) fseek(x->ufd,loc,0);
716: return(0);
717: }
718: nowwriting(x) unit *x;
719: {
720: long loc;
721: int k;
722:
723: if (x->uwrt == 3) { /* just did write, rewind */
724: if (close(creat(x->ufnm,0666)))
725: return(1);
726: }
727: else {
728: loc=ftell(x->ufd);
729: if (fclose(x->ufd) < 0
730: || (k = x->uwrt == 2 ? creat(x->ufnm,0666) : open(x->ufnm,1)) < 0
731: || (x->ufd = fdopen(k,"w")) == NULL) {
732: x->ufd = NULL;
733: return(1);
734: }
735: (void) fseek(x->ufd,loc,0);
736: }
737: x->uwrt = 1;
738: return(0);
739: }
740: ./ ADD NAME=libI77/fio.h TIME=628474795
741: #include "stdio.h"
742: #ifndef NULL
743: /* ANSI C */
744: #include "stddef.h"
745: #endif
746:
747: /*units*/
748: typedef struct
749: { FILE *ufd; /*0=unconnected*/
750: char *ufnm;
751: long uinode;
752: int url; /*0=sequential*/
753: flag useek; /*true=can backspace, use dir, ...*/
754: flag ufmt;
755: flag uprnt;
756: flag ublnk;
757: flag uend;
758: flag uwrt; /*last io was write*/
759: flag uscrtch;
760: } unit;
761:
762: extern int errno;
763: extern flag init;
764: extern cilist *elist; /*active external io list*/
765: extern flag reading,external,sequential,formatted;
766: extern int (*getn)(),(*putn)(); /*for formatted io*/
767: extern FILE *cf; /*current file*/
768: extern unit *curunit; /*current unit*/
769: extern unit units[];
770: #define err(f,m,s) {if(f) errno= m; else fatal(m,s); return(m);}
771:
772: /*Table sizes*/
773: #define MXUNIT 100
774:
775: extern int recpos; /*position in current record*/
776: extern int cursor; /* offset to move to */
777: extern int hiwater; /* so TL doesn't confuse us */
778:
779: #define WRITE 1
780: #define READ 2
781: #define SEQ 3
782: #define DIR 4
783: #define FMT 5
784: #define UNF 6
785: #define EXT 7
786: #define INT 8
787:
788: #define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
789: ./ ADD NAME=libI77/fmt.c TIME=628440861
790: #include "f2c.h"
791: #include "fio.h"
792: #include "fmt.h"
793: #define skip(s) while(*s==' ') s++
794: #ifdef interdata
795: #define SYLMX 300
796: #endif
797: #ifdef pdp11
798: #define SYLMX 300
799: #endif
800: #ifdef vax
801: #define SYLMX 300
802: #endif
803: #ifndef SYLMX
804: #define SYLMX 300
805: #endif
806: #define GLITCH '\2'
807: /* special quote character for stu */
808: extern int cursor,scale;
809: extern flag cblank,cplus; /*blanks in I and compulsory plus*/
810: struct syl syl[SYLMX];
811: int parenlvl,pc,revloc;
812:
813: char *f_s(),*f_list(),*i_tem(),*gt_num();
814:
815: pars_f(s) char *s;
816: {
817: parenlvl=revloc=pc=0;
818: if(f_s(s,0) == NULL)
819: {
820: return(-1);
821: }
822: return(0);
823: }
824: char *f_s(s,curloc) char *s;
825: {
826: skip(s);
827: if(*s++!='(')
828: {
829: return(NULL);
830: }
831: if(parenlvl++ ==1) revloc=curloc;
832: if(op_gen(RET,curloc,0,0)<0 ||
833: (s=f_list(s))==NULL)
834: {
835: return(NULL);
836: }
837: skip(s);
838: return(s);
839: }
840: char *f_list(s) char *s;
841: {
842: for(;*s!=0;)
843: { skip(s);
844: if((s=i_tem(s))==NULL) return(NULL);
845: skip(s);
846: if(*s==',') s++;
847: else if(*s==')')
848: { if(--parenlvl==0)
849: {
850: (void) op_gen(REVERT,revloc,0,0);
851: return(++s);
852: }
853: (void) op_gen(GOTO,0,0,0);
854: return(++s);
855: }
856: }
857: return(NULL);
858: }
859: char *i_tem(s) char *s;
860: { char *t;
861: int n,curloc;
862: if(*s==')') return(s);
863: if(ne_d(s,&t)) return(t);
864: if(e_d(s,&t)) return(t);
865: s=gt_num(s,&n);
866: if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
867: return(f_s(s,curloc));
868: }
869: ne_d(s,p) char *s,**p;
870: { int n,x,sign=0;
871: char *ap_end();
872: struct syl *sp;
873: switch(*s)
874: {
875: default:
876: return(0);
877: case ':': (void) op_gen(COLON,0,0,0); break;
878: case '$':
879: (void) op_gen(NONL, 0, 0, 0); break;
880: case 'B':
881: case 'b':
882: if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
883: else (void) op_gen(BN,0,0,0);
884: break;
885: case 'S':
886: case 's':
887: if(*(s+1)=='s' || *(s+1) == 'S')
888: { x=SS;
889: s++;
890: }
891: else if(*(s+1)=='p' || *(s+1) == 'P')
892: { x=SP;
893: s++;
894: }
895: else x=S;
896: (void) op_gen(x,0,0,0);
897: break;
898: case '/': (void) op_gen(SLASH,0,0,0); break;
899: case '-': sign=1;
900: case '+': s++; /*OUTRAGEOUS CODING TRICK*/
901: case '0': case '1': case '2': case '3': case '4':
902: case '5': case '6': case '7': case '8': case '9':
903: s=gt_num(s,&n);
904: switch(*s)
905: {
906: default:
907: return(0);
908: case 'P':
909: case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
910: case 'X':
911: case 'x': (void) op_gen(X,n,0,0); break;
912: case 'H':
913: case 'h':
914: sp = &syl[op_gen(H,n,0,0)];
915: *(char **)&sp->p2 = s + 1;
916: s+=n;
917: break;
918: }
919: break;
920: case GLITCH:
921: case '"':
922: case '\'':
923: sp = &syl[op_gen(APOS,0,0,0)];
924: *(char **)&sp->p2 = s;
925: if((*p = ap_end(s)) == NULL)
926: return(0);
927: return(1);
928: case 'T':
929: case 't':
930: if(*(s+1)=='l' || *(s+1) == 'L')
931: { x=TL;
932: s++;
933: }
934: else if(*(s+1)=='r'|| *(s+1) == 'R')
935: { x=TR;
936: s++;
937: }
938: else x=T;
939: s=gt_num(s+1,&n);
940: s--;
941: (void) op_gen(x,n,0,0);
942: break;
943: case 'X':
944: case 'x': (void) op_gen(X,1,0,0); break;
945: case 'P':
946: case 'p': (void) op_gen(P,1,0,0); break;
947: }
948: s++;
949: *p=s;
950: return(1);
951: }
952: e_d(s,p) char *s,**p;
953: { int n,w,d,e,found=0,x=0;
954: char *sv=s;
955: s=gt_num(s,&n);
956: (void) op_gen(STACK,n,0,0);
957: switch(*s++)
958: {
959: default: break;
960: case 'E':
961: case 'e': x=1;
962: case 'G':
963: case 'g':
964: found=1;
965: s=gt_num(s,&w);
966: if(w==0) break;
967: if(*s=='.')
968: { s++;
969: s=gt_num(s,&d);
970: }
971: else d=0;
972: if(*s!='E' && *s != 'e')
973: (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */
974: else
975: { s++;
976: s=gt_num(s,&e);
977: (void) op_gen(x==1?EE:GE,w,d,e);
978: }
979: break;
980: case 'O':
981: case 'o':
982: found = 1;
983: s = gt_num(s, &w);
984: if(w==0) break;
985: (void) op_gen(O, w, 0, 0);
986: break;
987: case 'L':
988: case 'l':
989: found=1;
990: s=gt_num(s,&w);
991: if(w==0) break;
992: (void) op_gen(L,w,0,0);
993: break;
994: case 'A':
995: case 'a':
996: found=1;
997: skip(s);
998: if(*s>='0' && *s<='9')
999: { s=gt_num(s,&w);
1000: if(w==0) break;
1001: (void) op_gen(AW,w,0,0);
1002: break;
1003: }
1004: (void) op_gen(A,0,0,0);
1005: break;
1006: case 'F':
1007: case 'f':
1008: found=1;
1009: s=gt_num(s,&w);
1010: if(w==0) break;
1011: if(*s=='.')
1012: { s++;
1013: s=gt_num(s,&d);
1014: }
1015: else d=0;
1016: (void) op_gen(F,w,d,0);
1017: break;
1018: case 'D':
1019: case 'd':
1020: found=1;
1021: s=gt_num(s,&w);
1022: if(w==0) break;
1023: if(*s=='.')
1024: { s++;
1025: s=gt_num(s,&d);
1026: }
1027: else d=0;
1028: (void) op_gen(D,w,d,0);
1029: break;
1030: case 'I':
1031: case 'i':
1032: found=1;
1033: s=gt_num(s,&w);
1034: if(w==0) break;
1035: if(*s!='.')
1036: { (void) op_gen(I,w,0,0);
1037: break;
1038: }
1039: s++;
1040: s=gt_num(s,&d);
1041: (void) op_gen(IM,w,d,0);
1042: break;
1043: }
1044: if(found==0)
1045: { pc--; /*unSTACK*/
1046: *p=sv;
1047: return(0);
1048: }
1049: *p=s;
1050: return(1);
1051: }
1052: op_gen(a,b,c,d)
1053: { struct syl *p= &syl[pc];
1054: if(pc>=SYLMX)
1055: { fprintf(stderr,"format too complicated:\n%s\n",
1056: fmtbuf);
1057: abort();
1058: }
1059: p->op=a;
1060: p->p1=b;
1061: p->p2=c;
1062: p->p3=d;
1063: return(pc++);
1064: }
1065: char *gt_num(s,n) char *s; int *n;
1066: { int m=0,cnt=0;
1067: char c;
1068: for(c= *s;;c = *s)
1069: { if(c==' ')
1070: { s++;
1071: continue;
1072: }
1073: if(c>'9' || c<'0') break;
1074: m=10*m+c-'0';
1075: cnt++;
1076: s++;
1077: }
1078: if(cnt==0) *n=1;
1079: else *n=m;
1080: return(s);
1081: }
1082: #define STKSZ 10
1083: int cnt[STKSZ],ret[STKSZ],cp,rp;
1084: flag workdone, nonl;
1085:
1086: integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
1087: { struct syl *p;
1088: int n,i;
1089: for(i=0;i<*number;i++,ptr+=len)
1090: {
1091: loop: switch(type_f((p= &syl[pc])->op))
1092: {
1093: default:
1094: fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
1095: p->op,fmtbuf);
1096: err(elist->cierr,100,"do_fio");
1097: case NED:
1098: if((*doned)(p))
1099: { pc++;
1100: goto loop;
1101: }
1102: pc++;
1103: continue;
1104: case ED:
1105: if(cnt[cp]<=0)
1106: { cp--;
1107: pc++;
1108: goto loop;
1109: }
1110: if(ptr==NULL)
1111: return((*doend)());
1112: cnt[cp]--;
1113: workdone=1;
1114: if((n=(*doed)(p,ptr,len))>0) err(elist->cierr,errno,"fmt");
1115: if(n<0) err(elist->ciend,(EOF),"fmt");
1116: continue;
1117: case STACK:
1118: cnt[++cp]=p->p1;
1119: pc++;
1120: goto loop;
1121: case RET:
1122: ret[++rp]=p->p1;
1123: pc++;
1124: goto loop;
1125: case GOTO:
1126: if(--cnt[cp]<=0)
1127: { cp--;
1128: rp--;
1129: pc++;
1130: goto loop;
1131: }
1132: pc=1+ret[rp--];
1133: goto loop;
1134: case REVERT:
1135: rp=cp=0;
1136: pc = p->p1;
1137: if(ptr==NULL)
1138: return((*doend)());
1139: if(!workdone) return(0);
1140: if((n=(*dorevert)()) != 0) return(n);
1141: goto loop;
1142: case COLON:
1143: if(ptr==NULL)
1144: return((*doend)());
1145: pc++;
1146: goto loop;
1147: case NONL:
1148: nonl = 1;
1149: pc++;
1150: goto loop;
1151: case S:
1152: case SS:
1153: cplus=0;
1154: pc++;
1155: goto loop;
1156: case SP:
1157: cplus = 1;
1158: pc++;
1159: goto loop;
1160: case P: scale=p->p1;
1161: pc++;
1162: goto loop;
1163: case BN:
1164: cblank=0;
1165: pc++;
1166: goto loop;
1167: case BZ:
1168: cblank=1;
1169: pc++;
1170: goto loop;
1171: }
1172: }
1173: return(0);
1174: }
1175: en_fio()
1176: { ftnint one=1;
1177: return(do_fio(&one,(char *)NULL,0l));
1178: }
1179: fmt_bg()
1180: {
1181: workdone=cp=rp=pc=cursor=0;
1182: cnt[0]=ret[0]=0;
1183: }
1184: type_f(n)
1185: {
1186: switch(n)
1187: {
1188: default:
1189: return(n);
1190: case RET:
1191: return(RET);
1192: case REVERT: return(REVERT);
1193: case GOTO: return(GOTO);
1194: case STACK: return(STACK);
1195: case X:
1196: case SLASH:
1197: case APOS: case H:
1198: case T: case TL: case TR:
1199: return(NED);
1200: case F:
1201: case I:
1202: case IM:
1203: case A: case AW:
1204: case O:
1205: case L:
1206: case E: case EE: case D:
1207: case G: case GE:
1208: return(ED);
1209: }
1210: }
1211: char *ap_end(s) char *s;
1212: { char quote;
1213: quote= *s++;
1214: for(;*s;s++)
1215: { if(*s!=quote) continue;
1216: if(*++s!=quote) return(s);
1217: }
1218: if(elist->cierr) {
1219: errno = 100;
1220: return(NULL);
1221: }
1222: fatal(100, "bad string");
1223: /*NOTREACHED*/ return 0;
1224: }
1225: ./ ADD NAME=libI77/fmt.h TIME=628555644
1226: struct syl
1227: { int op,p1,p2,p3;
1228: };
1229: #define RET 1
1230: #define REVERT 2
1231: #define GOTO 3
1232: #define X 4
1233: #define SLASH 5
1234: #define STACK 6
1235: #define I 7
1236: #define ED 8
1237: #define NED 9
1238: #define IM 10
1239: #define APOS 11
1240: #define H 12
1241: #define TL 13
1242: #define TR 14
1243: #define T 15
1244: #define COLON 16
1245: #define S 17
1246: #define SP 18
1247: #define SS 19
1248: #define P 20
1249: #define BN 21
1250: #define BZ 22
1251: #define F 23
1252: #define E 24
1253: #define EE 25
1254: #define D 26
1255: #define G 27
1256: #define GE 28
1257: #define L 29
1258: #define A 30
1259: #define AW 31
1260: #define O 32
1261: #define NONL 33
1262: extern struct syl syl[];
1263: extern int pc,parenlvl,revloc;
1264: extern int (*doed)(),(*doned)();
1265: extern int (*dorevert)(),(*donewrec)(),(*doend)();
1266: extern flag cblank,cplus,workdone, nonl;
1267: extern int dummy();
1268: extern char *fmtbuf;
1269: extern int scale;
1270: typedef union
1271: { real pf;
1272: doublereal pd;
1273: } ufloat;
1274: typedef union
1275: { short is;
1276: char ic;
1277: long il;
1278: } uint;
1279: #define GET(x) if((x=(*getn)())<0) return(x)
1280: #define VAL(x) (x!='\n'?x:' ')
1281: #define PUT(x) (*putn)(x)
1282: extern int cursor;
1283: ./ ADD NAME=libI77/fmtlib.c TIME=628440563
1284: /* @(#)fmtlib.c 1.2 */
1285: #define MAXINTLENGTH 23
1286: char *icvt(value,ndigit,sign, base) long value; int *ndigit,*sign;
1287: register int base;
1288: { static char buf[MAXINTLENGTH+1];
1289: register int i;
1290: if(value>0) *sign=0;
1291: else if(value<0)
1292: { value = -value;
1293: *sign= 1;
1294: }
1295: else
1296: { *sign=0;
1297: *ndigit=1;
1298: buf[MAXINTLENGTH]='0';
1299: return(&buf[MAXINTLENGTH]);
1300: }
1301: for(i=MAXINTLENGTH-1;value>0;i--)
1302: { *(buf+i)=(int)(value%base)+'0';
1303: value /= base;
1304: }
1305: *ndigit=MAXINTLENGTH-1-i;
1306: return(&buf[i+1]);
1307: }
1308: ./ ADD NAME=libI77/fp.h TIME=580998005
1309: #define FMAX 40
1310: #define EXPMAXDIGS 8
1311: #define EXPMAX 99999999
1312: /* FMAX = max number of nonzero digits passed to atof() */
1313: /* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */
1314:
1315: #include "local.h"
1316:
1317: /* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily
1318: tight) on the maximum number of digits to the right and left of
1319: * the decimal point.
1320: */
1321:
1322: #ifdef VAX
1323: #define MAXFRACDIGS 56
1324: #define MAXINTDIGS 38
1325: #else
1326: #ifdef CRAY
1327: #define MAXFRACDIGS 9880
1328: #define MAXINTDIGS 9864
1329: #else
1330: /* values that suffice for IEEE double */
1331: #define MAXFRACDIGS 344
1332: #define MAXINTDIGS 308
1333: #endif
1334: #endif
1335: ./ ADD NAME=libI77/iio.c TIME=629054420
1336: #include "f2c.h"
1337: #include "fio.h"
1338: #include "fmt.h"
1339: extern char *icptr;
1340: char *icend;
1341: extern icilist *svic;
1342: extern int rd_ed(),rd_ned(),w_ed(),w_ned(),y_ierr();
1343: extern int z_wnew();
1344: int icnum;
1345: extern int hiwater;
1346: z_getc()
1347: {
1348: if(icptr >= icend) err(svic->iciend,(EOF),"endfile");
1349: if(recpos++ < svic->icirlen)
1350: return(*icptr++);
1351: else err(svic->icierr,110,"recend");
1352: }
1353: z_putc(c)
1354: {
1355: if(icptr >= icend) err(svic->icierr,110,"inwrite");
1356: if(recpos++ < svic->icirlen)
1357: *icptr++ = c;
1358: else err(svic->icierr,110,"recend");
1359: return 0;
1360: }
1361: z_rnew()
1362: {
1363: icptr = svic->iciunit + (++icnum)*svic->icirlen;
1364: recpos = 0;
1365: cursor = 0;
1366: hiwater = 0;
1367: return 1;
1368: }
1369: integer s_rsfi(a) icilist *a;
1370: { int n;
1371: if(n=c_si(a)) return(n);
1372: reading=1;
1373: doed=rd_ed;
1374: doned=rd_ned;
1375: getn=z_getc;
1376: dorevert = y_ierr;
1377: donewrec = doend = z_rnew;
1378: return(0);
1379: }
1380: integer s_wsfi(a) icilist *a;
1381: { int n;
1382: if(n=c_si(a)) return(n);
1383: reading=0;
1384: doed=w_ed;
1385: doned=w_ned;
1386: putn=z_putc;
1387: dorevert = y_ierr;
1388: donewrec = doend = z_wnew;
1389: return(0);
1390: }
1391: c_si(a) icilist *a;
1392: {
1393: fmtbuf=a->icifmt;
1394: if(pars_f(fmtbuf)<0)
1395: err(a->icierr,100,"startint");
1396: fmt_bg();
1397: sequential=formatted=1;
1398: external=0;
1399: cblank=cplus=scale=0;
1400: svic=a;
1401: icnum=recpos=0;
1402: cursor = 0;
1403: hiwater = 0;
1404: icptr=svic->iciunit;
1405: icend=icptr+svic->icirlen*svic->icirnum;
1406: return(0);
1407: }
1408: z_wnew()
1409: {
1410: while(recpos++ < svic->icirlen)
1411: *icptr++ = ' ';
1412: recpos = 0;
1413: cursor = 0;
1414: hiwater = 0;
1415: icnum++;
1416: return 1;
1417: }
1418: integer e_rsfi()
1419: { int n;
1420: n = en_fio();
1421: fmtbuf = NULL;
1422: return(n);
1423: }
1424: integer e_wsfi()
1425: {
1426: int n;
1427: n = en_fio();
1428: fmtbuf = NULL;
1429: if(icnum >= svic->icirnum)
1430: return(n);
1431: while(recpos++ < svic->icirlen)
1432: *icptr++ = ' ';
1433: return(n);
1434: }
1435: y_ierr()
1436: {
1437: err(elist->cierr, 110, "iio");
1438: }
1439: ./ ADD NAME=libI77/inquire.c TIME=628440563
1440: #include "f2c.h"
1441: #include "fio.h"
1442: integer f_inqu(a) inlist *a;
1443: { flag byfile;
1444: int i;
1445: unit *p;
1446: char buf[256];
1447: long x;
1448: if(a->infile!=NULL)
1449: { byfile=1;
1450: g_char(a->infile,a->infilen,buf);
1451: x=inode(buf);
1452: for(i=0,p=NULL;i<MXUNIT;i++)
1453: if(units[i].uinode==x && units[i].ufd!=NULL)
1454: p = &units[i];
1455: }
1456: else
1457: {
1458: byfile=0;
1459: if(a->inunit<MXUNIT && a->inunit>=0)
1460: {
1461: p= &units[a->inunit];
1462: }
1463: else
1464: {
1465: p=NULL;
1466: }
1467: }
1468: if(a->inex!=NULL)
1469: if(byfile && x != -1 || !byfile && p!=NULL)
1470: *a->inex=1;
1471: else *a->inex=0;
1472: if(a->inopen!=NULL)
1473: if(byfile) *a->inopen=(p!=NULL);
1474: else *a->inopen=(p!=NULL && p->ufd!=NULL);
1475: if(a->innum!=NULL) *a->innum= p-units;
1476: if(a->innamed!=NULL)
1477: if(byfile || p!=NULL && p->ufnm!=NULL)
1478: *a->innamed=1;
1479: else *a->innamed=0;
1480: if(a->inname!=NULL)
1481: if(byfile)
1482: b_char(buf,a->inname,a->innamlen);
1483: else if(p!=NULL && p->ufnm!=NULL)
1484: b_char(p->ufnm,a->inname,a->innamlen);
1485: if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
1486: if(p->url)
1487: b_char("DIRECT",a->inacc,a->inacclen);
1488: else b_char("SEQUENTIAL",a->inacc,a->inacclen);
1489: if(a->inseq!=NULL)
1490: if(p!=NULL && p->url)
1491: b_char("NO",a->inseq,a->inseqlen);
1492: else b_char("YES",a->inseq,a->inseqlen);
1493: if(a->indir!=NULL)
1494: if(p==NULL || p->url)
1495: b_char("YES",a->indir,a->indirlen);
1496: else b_char("NO",a->indir,a->indirlen);
1497: if(a->infmt!=NULL)
1498: if(p!=NULL && p->ufmt==0)
1499: b_char("UNFORMATTED",a->infmt,a->infmtlen);
1500: else b_char("FORMATTED",a->infmt,a->infmtlen);
1501: if(a->inform!=NULL)
1502: if(p!=NULL && p->ufmt==0)
1503: b_char("NO",a->inform,a->informlen);
1504: else b_char("YES",a->inform,a->informlen);
1505: if(a->inunf)
1506: if(p!=NULL && p->ufmt==0)
1507: b_char("YES",a->inunf,a->inunflen);
1508: else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
1509: else b_char("UNKNOWN",a->inunf,a->inunflen);
1510: if(a->inrecl!=NULL && p!=NULL)
1511: *a->inrecl=p->url;
1512: if(a->innrec!=NULL && p!=NULL && p->url>0)
1513: *a->innrec=ftell(p->ufd)/p->url+1;
1514: if(a->inblank && p!=NULL && p->ufmt)
1515: if(p->ublnk)
1516: b_char("ZERO",a->inblank,a->inblanklen);
1517: else b_char("NULL",a->inblank,a->inblanklen);
1518: return(0);
1519: }
1520: ./ ADD NAME=libI77/lio.c TIME=628950337
1521: #include "f2c.h"
1522: #include "fio.h"
1523: #include "fmt.h"
1524: #include "lio.h"
1525: extern int l_write();
1526: int t_putc();
1527:
1528: integer s_wsle(a) cilist *a;
1529: {
1530: int n;
1531: if(!init) f_init();
1532: if(n=c_le(a)) return(n);
1533: reading=0;
1534: external=1;
1535: formatted=1;
1536: putn = t_putc;
1537: lioproc = l_write;
1538: if(curunit->uwrt != 1 && nowwriting(curunit))
1539: err(a->cierr, errno, "list output start");
1540: return(0);
1541: }
1542: integer e_wsle()
1543: {
1544: t_putc('\n');
1545: recpos=0;
1546: if (cf == stdout)
1547: fflush(stdout);
1548: else if (cf == stderr)
1549: fflush(stderr);
1550: return(0);
1551: }
1552: t_putc(c)
1553: {
1554: recpos++;
1555: putc(c,cf);
1556: return(0);
1557: }
1558: lwrt_I(n) ftnint n;
1559: {
1560: char buf[LINTW],*p;
1561: (void) sprintf(buf," %ld",(long)n);
1562: if(recpos+strlen(buf)>=LINE)
1563: { t_putc('\n');
1564: recpos=0;
1565: }
1566: for(p=buf;*p;t_putc(*p++));
1567: }
1568: lwrt_L(n, len) ftnint n; ftnlen len;
1569: {
1570: if(recpos+LLOGW>=LINE)
1571: { t_putc('\n');
1572: recpos=0;
1573: }
1574: (void) wrt_L((uint *)&n,LLOGW, len);
1575: }
1576: lwrt_A(p,len) char *p; ftnlen len;
1577: {
1578: int i;
1579: if(recpos+len>=LINE)
1580: {
1581: t_putc('\n');
1582: recpos=0;
1583: }
1584: if (!recpos)
1585: { t_putc(' '); ++recpos; }
1586: for(i=0;i<len;i++) t_putc(*p++);
1587: }
1588: lwrt_F(absn) double absn;
1589: {
1590: doublereal n;
1591:
1592: n = absn;
1593: if (absn < 0)
1594: absn = -absn;
1595: if (LLOW <= absn && absn < LHIGH)
1596: {
1597: if(recpos+LFW>=LINE)
1598: {
1599: t_putc('\n');
1600: recpos=0;
1601: }
1602: scale=0;
1603: (void) wrt_F((ufloat *)&n,LFW,LFD,(ftnlen)sizeof(n));
1604: }
1605: else
1606: {
1607: if(recpos+LEW>=LINE)
1608: { t_putc('\n');
1609: recpos=0;
1610: }
1611: scale = 1;
1612: (void) wrt_E((ufloat *)&n,LEW,LED,-1,(ftnlen)sizeof(n));
1613: }
1614: }
1615: lwrt_C(a,b) double a,b;
1616: {
1617: if(recpos+2*LFW+3>=LINE)
1618: { t_putc('\n');
1619: recpos=0;
1620: }
1621: t_putc(' ');
1622: t_putc('(');
1623: lwrt_F(a);
1624: t_putc(',');
1625: lwrt_F(b);
1626: t_putc(')');
1627: }
1628: l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
1629: {
1630: #define Ptr ((flex *)ptr)
1631: int i;
1632: ftnint x;
1633: double y,z;
1634: real *xx;
1635: doublereal *yy;
1636: for(i=0;i< *number; i++)
1637: {
1638: switch((int)type)
1639: {
1640: default: fatal(204,"unknown type in lio");
1641: case TYSHORT:
1642: x=Ptr->flshort;
1643: goto xint;
1644: case TYLONG:
1645: x=Ptr->flint;
1646: xint: lwrt_I(x);
1647: break;
1648: case TYREAL:
1649: y=Ptr->flreal;
1650: goto xfloat;
1651: case TYDREAL:
1652: y=Ptr->fldouble;
1653: xfloat: lwrt_F(y);
1654: break;
1655: case TYCOMPLEX:
1656: xx= &Ptr->flreal;
1657: y = *xx++;
1658: z = *xx;
1659: goto xcomplex;
1660: case TYDCOMPLEX:
1661: yy = &Ptr->fldouble;
1662: y= *yy++;
1663: z = *yy;
1664: xcomplex:
1665: lwrt_C(y,z);
1666: break;
1667: case TYLOGICAL:
1668: lwrt_L(Ptr->flint, len);
1669: break;
1670: case TYCHAR:
1671: lwrt_A(ptr,len);
1672: break;
1673: }
1674: ptr += len;
1675: }
1676: return(0);
1677: }
1678: ./ ADD NAME=libI77/lio.h TIME=628801084
1679: /* copy of ftypes from the compiler */
1680: /* variable types
1681: * numeric assumptions:
1682: * int < reals < complexes
1683: * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
1684: */
1685:
1686: #define TYUNKNOWN 0
1687: #define TYADDR 1
1688: #define TYSHORT 2
1689: #define TYLONG 3
1690: #define TYREAL 4
1691: #define TYDREAL 5
1692: #define TYCOMPLEX 6
1693: #define TYDCOMPLEX 7
1694: #define TYLOGICAL 8
1695: #define TYCHAR 9
1696: #define TYSUBR 10
1697: #define TYERROR 11
1698:
1699: #define NTYPES (TYERROR+1)
1700:
1701: #define LINTW 12
1702: #define LINE 80
1703: #define LLOGW 2
1704: #define LLOW 1.0
1705: #define LHIGH 10.0
1706: #define LFW 12
1707: #define LFD 8
1708: #define LEW 16
1709: #define LED 8
1710:
1711: typedef union
1712: { short flshort;
1713: ftnint flint;
1714: real flreal;
1715: doublereal fldouble;
1716: } flex;
1717: extern int scale;
1718: extern int (*lioproc)();
1719: ./ ADD NAME=libI77/lread.c TIME=628950338
1720: #include "f2c.h"
1721: #include "fio.h"
1722: #include "fmt.h"
1723: #include "lio.h"
1724: #include "ctype.h"
1725: #include "fp.h"
1726:
1727: extern char *fmtbuf;
1728: extern char *malloc(), *realloc();
1729: int (*lioproc)();
1730:
1731: #define isblnk(x) (ltab[x+1]&B)
1732: #define issep(x) (ltab[x+1]&SX)
1733: #define isapos(x) (ltab[x+1]&AX)
1734: #define isexp(x) (ltab[x+1]&EX)
1735: #define issign(x) (ltab[x+1]&SG)
1736: #define SX 1
1737: #define B 2
1738: #define AX 4
1739: #define EX 8
1740: #define SG 16
1741: char ltab[128+1] = { /* offset one for EOF */
1742: 0,
1743: 0,0,AX,0,0,0,0,0,0,0,SX,0,0,0,0,0,
1744: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1745: SX|B,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
1746: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1747: 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
1748: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
1749: AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
1750: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
1751: };
1752:
1753: t_getc()
1754: { int ch;
1755: if(curunit->uend) return(EOF);
1756: if((ch=getc(cf))!=EOF) return(ch);
1757: if(feof(cf)) curunit->uend = 1;
1758: return(EOF);
1759: }
1760: integer e_rsle()
1761: {
1762: int ch;
1763: if(curunit->uend) return(0);
1764: while((ch=t_getc())!='\n' && ch!=EOF);
1765: return(0);
1766: }
1767:
1768: flag lquit;
1769: int lcount,ltype;
1770: char *lchar;
1771: double lx,ly;
1772: #define ERR(x) if(n=(x)) return(n)
1773: #define GETC(x) (x=t_getc())
1774:
1775: l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
1776: {
1777: #define Ptr ((flex *)ptr)
1778: int i,n,ch;
1779: doublereal *yy;
1780: real *xx;
1781: for(i=0;i<*number;i++)
1782: {
1783: if(lquit) return(0);
1784: if(curunit->uend) err(elist->ciend, EOF, "list in")
1785: if(lcount == 0) {
1786: ltype = 0;
1787: for(;;) {
1788: GETC(ch);
1789: switch(ch) {
1790: case EOF:
1791: goto loopend;
1792: case ' ':
1793: case '\n':
1794: continue;
1795: case '/':
1796: lquit = 1;
1797: goto loopend;
1798: case ',':
1799: lcount = 1;
1800: goto loopend;
1801: default:
1802: (void) ungetc(ch, cf);
1803: goto rddata;
1804: }
1805: }
1806: }
1807: rddata:
1808: switch((int)type)
1809: {
1810: case TYSHORT:
1811: case TYLONG:
1812: case TYREAL:
1813: case TYDREAL:
1814: ERR(l_R());
1815: break;
1816: case TYCOMPLEX:
1817: case TYDCOMPLEX:
1818: ERR(l_C());
1819: break;
1820: case TYLOGICAL:
1821: ERR(l_L());
1822: break;
1823: case TYCHAR:
1824: ERR(l_CHAR());
1825: break;
1826: }
1827: while ((ch=t_getc())==' '); if (ch!=',') ungetc(ch,cf);
1828: loopend:
1829: if(lquit) return(0);
1830: if(feof(cf)) err(elist->ciend,(EOF),"list in")
1831: else if(ferror(cf))
1832: { clearerr(cf);
1833: err(elist->cierr,errno,"list in")
1834: }
1835: if(ltype==0) goto bump;
1836: switch((int)type)
1837: {
1838: case TYSHORT:
1839: Ptr->flshort=lx;
1840: break;
1841: case TYLOGICAL:
1842: case TYLONG:
1843: Ptr->flint=lx;
1844: break;
1845: case TYREAL:
1846: Ptr->flreal=lx;
1847: break;
1848: case TYDREAL:
1849: Ptr->fldouble=lx;
1850: break;
1851: case TYCOMPLEX:
1852: xx=(real *)ptr;
1853: *xx++ = lx;
1854: *xx = ly;
1855: break;
1856: case TYDCOMPLEX:
1857: yy=(doublereal *)ptr;
1858: *yy++ = lx;
1859: *yy = ly;
1860: break;
1861: case TYCHAR:
1862: b_char(lchar,ptr,len);
1863: break;
1864: }
1865: bump:
1866: if(lcount>0) lcount--;
1867: ptr += len;
1868: }
1869: return(0);
1870: #undef Ptr
1871: }
1872: l_R()
1873: {
1874: char s[FMAX+EXPMAXDIGS+4];
1875: register int ch;
1876: register char *sp, *spe, *sp1;
1877: long e, exp;
1878: double atof();
1879: int havenum, poststar, se;
1880:
1881: if (lcount > 0)
1882: return(0);
1883: ltype = 0;
1884: lcount = 1;
1885: exp = 0;
1886: poststar = 0;
1887: retry:
1888: sp1 = sp = s;
1889: spe = sp + FMAX;
1890: havenum = 0;
1891:
1892: switch(GETC(ch)) {
1893: case '-': *sp++ = ch; sp1++; spe++;
1894: case '+':
1895: GETC(ch);
1896: }
1897: while(ch == '0') {
1898: ++havenum;
1899: GETC(ch);
1900: }
1901: while(isdigit(ch)) {
1902: if (sp < spe) *sp++ = ch;
1903: else ++exp;
1904: GETC(ch);
1905: }
1906: if (ch == '*' && !poststar) {
1907: if (sp == sp1 || exp || *s == '-') {
1908: err(elist->cierr,112,"bad repetition count")
1909: }
1910: poststar = 1;
1911: *sp = 0;
1912: lcount = atoi(s);
1913: goto retry;
1914: }
1915: if (ch == '.') {
1916: GETC(ch);
1917: if (sp == sp1)
1918: while(ch == '0') {
1919: ++havenum;
1920: --exp;
1921: GETC(ch);
1922: }
1923: while(isdigit(ch)) {
1924: if (sp < spe)
1925: { *sp++ = ch; --exp; }
1926: GETC(ch);
1927: }
1928: }
1929: se = 0;
1930: if (issign(ch))
1931: goto signonly;
1932: if (isexp(ch)) {
1933: GETC(ch);
1934: if (issign(ch)) {
1935: signonly:
1936: if (ch == '-') se = 1;
1937: GETC(ch);
1938: }
1939: if (!isdigit(ch)) {
1940: bad:
1941: err(elist->cierr,112,"exponent field")
1942: }
1943:
1944: e = ch - '0';
1945: while(isdigit(GETC(ch))) {
1946: e = 10*e + ch - '0';
1947: if (e > EXPMAX)
1948: goto bad;
1949: }
1950: if (se)
1951: exp -= e;
1952: else
1953: exp += e;
1954: }
1955: (void) ungetc(ch, cf);
1956: if (sp > sp1) {
1957: ++havenum;
1958: while(*--sp == '0')
1959: ++exp;
1960: if (exp)
1961: sprintf(sp+1, "e%ld", exp);
1962: else
1963: sp[1] = 0;
1964: lx = atof(s);
1965: }
1966: else
1967: lx = 0.;
1968: if (havenum)
1969: ltype = TYLONG;
1970: else
1971: switch(ch) {
1972: case ',':
1973: case '/':
1974: break;
1975: default:
1976: err(elist->cierr,112,"invalid number")
1977: }
1978: return 0;
1979: }
1980:
1981: l_C()
1982: { int ch;
1983: if(lcount>0) return(0);
1984: ltype=0;
1985: GETC(ch);
1986: if(ch!='(')
1987: {
1988: (void) ungetc(ch,cf);
1989: if(fscanf(cf,"%d",&lcount)!=1)
1990: if(!feof(cf)) err(elist->cierr,112,"complex format")
1991: else err(elist->cierr,(EOF),"lread");
1992: if(GETC(ch)!='*')
1993: {
1994: if(!feof(cf)) err(elist->cierr,112,"no star")
1995: else err(elist->cierr,(EOF),"lread");
1996: }
1997: if(GETC(ch)!='(')
1998: { (void) ungetc(ch,cf);
1999: return(0);
2000: }
2001: }
2002: lcount = 1;
2003: ltype=TYLONG;
2004: (void) fscanf(cf,"%lf",&lx);
2005: while(isblnk(GETC(ch)) || (ch == '\n'));
2006: if(ch!=',')
2007: { (void) ungetc(ch,cf);
2008: err(elist->cierr,112,"no comma");
2009: }
2010: while(isblnk(GETC(ch)));
2011: (void) ungetc(ch,cf);
2012: (void) fscanf(cf,"%lf",&ly);
2013: while(isblnk(GETC(ch)));
2014: if(ch!=')') err(elist->cierr,112,"no )");
2015: return(0);
2016: }
2017: l_L()
2018: {
2019: int ch;
2020: if(lcount>0) return(0);
2021: ltype=0;
2022: GETC(ch);
2023: if(isdigit(ch))
2024: { (void) ungetc(ch,cf);
2025: (void) fscanf(cf,"%d",&lcount);
2026: if(GETC(ch)!='*')
2027: if(!feof(cf)) err(elist->cierr,112,"no star")
2028: else err(elist->cierr,(EOF),"lread");
2029: }
2030: else (void) ungetc(ch,cf);
2031: if(GETC(ch)=='.') GETC(ch);
2032: switch(ch)
2033: {
2034: case 't':
2035: case 'T':
2036: lx=1;
2037: break;
2038: case 'f':
2039: case 'F':
2040: lx=0;
2041: break;
2042: default:
2043: if(isblnk(ch) || issep(ch) || ch==EOF)
2044: { (void) ungetc(ch,cf);
2045: return(0);
2046: }
2047: else err(elist->cierr,112,"logical");
2048: }
2049: ltype=TYLONG;
2050: lcount = 1;
2051: while(!issep(GETC(ch)) && ch!=EOF);
2052: (void) ungetc(ch, cf);
2053: return(0);
2054: }
2055: #define BUFSIZE 128
2056: l_CHAR()
2057: { int ch,size,i;
2058: char quote,*p;
2059: if(lcount>0) return(0);
2060: ltype=0;
2061:
2062: GETC(ch);
2063: if(isdigit(ch))
2064: { (void) ungetc(ch,cf);
2065: (void) fscanf(cf,"%d",&lcount);
2066: if(GETC(ch)!='*') err(elist->cierr,112,"no star");
2067: }
2068: else (void) ungetc(ch,cf);
2069: if(GETC(ch)=='\'' || ch=='"') quote=ch;
2070: else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
2071: { (void) ungetc(ch,cf);
2072: return(0);
2073: }
2074: else err(elist->cierr,112,"no quote");
2075: ltype=TYCHAR;
2076: if(lchar!=NULL) free(lchar);
2077: size=BUFSIZE;
2078: p=lchar=malloc((unsigned int)size);
2079: if(lchar==NULL) err(elist->cierr,113,"no space");
2080: for(i=0;;)
2081: { while(GETC(ch)!=quote && ch!='\n'
2082: && ch!=EOF && ++i<size) *p++ = ch;
2083: if(i==size)
2084: {
2085: newone:
2086: lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
2087: p=lchar+i-1;
2088: *p++ = ch;
2089: }
2090: else if(ch==EOF) return(EOF);
2091: else if(ch=='\n')
2092: { if(*(p-1) != '\\') continue;
2093: i--;
2094: p--;
2095: if(++i<size) *p++ = ch;
2096: else goto newone;
2097: }
2098: else if(GETC(ch)==quote)
2099: { if(++i<size) *p++ = ch;
2100: else goto newone;
2101: }
2102: else
2103: { (void) ungetc(ch,cf);
2104: *p = 0;
2105: return(0);
2106: }
2107: }
2108: }
2109: integer s_rsle(a) cilist *a;
2110: {
2111: int n;
2112: if(!init) f_init();
2113: if(n=c_le(a)) return(n);
2114: reading=1;
2115: external=1;
2116: formatted=1;
2117: lioproc = l_read;
2118: lquit = 0;
2119: lcount = 0;
2120: if(curunit->uwrt && nowreading(curunit))
2121: err(a->cierr,errno,"read start");
2122: return(0);
2123: }
2124: c_le(a) cilist *a;
2125: {
2126: fmtbuf="list io";
2127: if(a->ciunit>=MXUNIT || a->ciunit<0)
2128: err(a->cierr,101,"stler");
2129: scale=recpos=0;
2130: elist=a;
2131: curunit = &units[a->ciunit];
2132: if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
2133: err(a->cierr,102,"lio");
2134: cf=curunit->ufd;
2135: if(!curunit->ufmt) err(a->cierr,103,"lio")
2136: return(0);
2137: }
2138: integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
2139: {
2140: return((*lioproc)(number,ptr,len,*type));
2141: }
2142: ./ ADD NAME=libI77/open.c TIME=628440564
2143: #include "sys/types.h"
2144: #include "sys/stat.h"
2145: #include "f2c.h"
2146: #include "fio.h"
2147: extern char *mktemp(), *malloc(), *strcpy();
2148: extern FILE *fdopen();
2149: extern integer f_clos();
2150:
2151: integer f_open(a) olist *a;
2152: { unit *b;
2153: int n;
2154: char buf[256];
2155: cllist x;
2156: if(a->ounit>=MXUNIT || a->ounit<0)
2157: err(a->oerr,101,"open")
2158: curunit = b = &units[a->ounit];
2159: if(b->ufd) {
2160: if(a->ofnm==0)
2161: {
2162: same: if(a->oblnk!= 0) b->ublnk= *a->oblnk== 'z'?1:0;
2163: return(0);
2164: }
2165: g_char(a->ofnm,a->ofnmlen,buf);
2166: if(inode(buf)==b->uinode) goto same;
2167: x.cunit=a->ounit;
2168: x.csta=0;
2169: x.cerr=a->oerr;
2170: if((n=f_clos(&x))!=0) return(n);
2171: }
2172: b->url=a->orl;
2173: if(a->oblnk && (*a->oblnk=='z' || *a->oblnk == 'Z')) b->ublnk=1;
2174: else b->ublnk=0;
2175: if(a->ofm==0)
2176: { if(b->url>0) b->ufmt=0;
2177: else b->ufmt=1;
2178: }
2179: else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
2180: else b->ufmt=0;
2181: if (a->ofnm) {
2182: g_char(a->ofnm,a->ofnmlen,buf);
2183: if (!buf[0])
2184: err(a->oerr,107,"open")
2185: }
2186: else
2187: sprintf(buf, "fort.%ld", a->ounit);
2188: b->uscrtch = 0;
2189: switch(a->osta ? *a->osta : 'u')
2190: {
2191: case 'o':
2192: case 'O':
2193: if(!a->ofnm) err(a->oerr,107,"open")
2194: if(access(buf,0))
2195: err(a->oerr,errno,"open")
2196: break;
2197: case 's':
2198: case 'S':
2199: b->uscrtch=1;
2200: (void) strcpy(buf,"tmp.FXXXXXX");
2201: (void) mktemp(buf);
2202: (void) close(creat(buf, 0666));
2203: break;
2204: case 'n':
2205: case 'N':
2206: if(a->ofnm==0) err(a->oerr,107,"open")
2207: (void) close(creat(buf, 0666));
2208: break;
2209: }
2210: done:
2211: b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
2212: if(b->ufnm==NULL) err(a->oerr,113,"no space");
2213: (void) strcpy(b->ufnm,buf);
2214: b->uend=0;
2215: if(isdev(buf))
2216: { b->ufd = fopen(buf,"r");
2217: if(b->ufd==NULL) err(a->oerr,errno,buf)
2218: else b->uwrt = 0;
2219: }
2220: else {
2221: b->uwrt = 0;
2222: if((b->ufd = fopen(buf, "r")) == NULL) {
2223: if ((n = open(buf,1)) >= 0) {
2224: b->uwrt = 2;
2225: }
2226: else {
2227: n = creat(buf, 0666);
2228: b->uwrt = 1;
2229: }
2230: if (n < 0
2231: || (b->ufd = fdopen(n, "w")) == NULL)
2232: err(a->oerr, errno, "open");
2233: }
2234: if(b->url > 0) /* one can more easily find the end */
2235: (void) fseek(b->ufd, 0L, 0);
2236: }
2237: b->useek=canseek(b->ufd);
2238: if((b->uinode=inode(buf))==-1)
2239: err(a->oerr,108,"open")
2240: if(a->orl && b->useek) rewind(b->ufd);
2241: return(0);
2242: }
2243: fk_open(seq,fmt,n) ftnint n;
2244: { char nbuf[10];
2245: olist a;
2246: (void) sprintf(nbuf,"fort.%ld",n);
2247: a.oerr=1;
2248: a.ounit=n;
2249: a.ofnm=nbuf;
2250: a.ofnmlen=strlen(nbuf);
2251: a.osta=NULL;
2252: a.oacc= seq==SEQ?"s":"d";
2253: a.ofm = fmt==FMT?"f":"u";
2254: a.orl = seq==DIR?1:0;
2255: a.oblnk=NULL;
2256: return(f_open(&a));
2257: }
2258: isdev(s) char *s;
2259: { struct stat x;
2260: int j;
2261: if(stat(s, &x) == -1) return(0);
2262: if((j = (x.st_mode&S_IFMT)) == S_IFREG || j == S_IFDIR) return(0);
2263: else return(1);
2264: }
2265: ./ ADD NAME=libI77/rdfmt.c TIME=629051101
2266: #include "f2c.h"
2267: #include "fio.h"
2268: #include "fmt.h"
2269: #include "fp.h"
2270:
2271: extern int cursor;
2272: rd_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
2273: { int ch;
2274: for(;cursor>0;cursor--) if((ch=(*getn)())<0) return(ch);
2275: if(cursor<0)
2276: { if(recpos+cursor < 0) /*err(elist->cierr,110,"fmt")*/
2277: cursor = -recpos; /* is this in the standard? */
2278: if(external == 0) {
2279: extern char *icptr;
2280: icptr += cursor;
2281: }
2282: else if(curunit->useek) (void) fseek(cf,(long) cursor,1);
2283: else err(elist->cierr,106,"fmt");
2284: recpos += cursor;
2285: cursor=0;
2286: }
2287: switch(p->op)
2288: {
2289: default: fprintf(stderr,"rd_ed, unexpected code: %d\n%s\n",
2290: p->op,fmtbuf);
2291: abort();
2292: case I: ch = (rd_I((uint *)ptr,p->p1,len, 10));
2293: break;
2294: case IM: ch = (rd_I((uint *)ptr,p->p1,len, 10));
2295: break;
2296: case O: ch = (rd_I((uint *)ptr, p->p1, len, 8));
2297: break;
2298: case L: ch = (rd_L((ftnint *)ptr,p->p1));
2299: break;
2300: case A: ch = (rd_A(ptr,len));
2301: break;
2302: case AW:
2303: ch = (rd_AW(ptr,p->p1,len));
2304: break;
2305: case E: case EE:
2306: case D:
2307: case G:
2308: case GE:
2309: case F: ch = (rd_F((ufloat *)ptr,p->p1,p->p2,len));
2310: break;
2311: }
2312: if(ch == 0) return(ch);
2313: else if(ch == EOF) return(EOF);
2314: clearerr(cf);
2315: return(errno);
2316: }
2317: rd_ned(p) struct syl *p;
2318: {
2319: switch(p->op)
2320: {
2321: default: fprintf(stderr,"rd_ned, unexpected code: %d\n%s\n",
2322: p->op,fmtbuf);
2323: abort();
2324: case APOS:
2325: return(rd_POS(*(char **)&p->p2));
2326: case H: return(rd_H(p->p1,*(char **)&p->p2));
2327: case SLASH: return((*donewrec)());
2328: case TR:
2329: case X: cursor += p->p1;
2330: return(1);
2331: case T: cursor=p->p1-recpos - 1;
2332: return(1);
2333: case TL: cursor -= p->p1;
2334: if(cursor < -recpos) /* TL1000, 1X */
2335: cursor = -recpos;
2336: return(1);
2337: }
2338: }
2339: rd_I(n,w,len, base) ftnlen len; uint *n; register int base;
2340: { long x;
2341: int sign,ch;
2342: char s[84], *ps;
2343: ps=s; x=0;
2344: while (w)
2345: {
2346: GET(ch);
2347: if (ch==',' || ch=='\n') break;
2348: *ps=ch; ps++; w--;
2349: }
2350: *ps='\0';
2351: ps=s;
2352: while (*ps==' ') ps++;
2353: if (*ps=='-') { sign=1; ps++; }
2354: else { sign=0; if (*ps=='+') ps++; }
2355: loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
2356: if (*ps==' ') {if (cblank) x *= base; ps++; goto loop;}
2357: if(sign) x = -x;
2358: if(len==sizeof(integer)) n->il=x;
2359: else if(len == sizeof(char)) n->ic = x;
2360: else n->is=x;
2361: if (*ps) return(errno=115); else return(0);
2362: }
2363: rd_L(n,w) ftnint *n;
2364: { int ch;
2365: char s[84], *ps;
2366: ps=s;
2367: while (w) {
2368: GET(ch);
2369: if (ch==','||ch=='\n') break;
2370: *ps=ch;
2371: ps++; w--;
2372: }
2373: *ps='\0';
2374: ps=s; while (*ps==' ') ps++;
2375: if (*ps=='.') ps++;
2376: if (*ps=='t' || *ps == 'T') { *n=1; return(0); }
2377: else if (*ps='f' || *ps == 'F') { *n=0; return(0); }
2378: else return(errno=116);
2379: }
2380:
2381: #include "ctype.h"
2382:
2383: rd_F(p, w, d, len)
2384: ftnlen len;
2385: ufloat *p;
2386: {
2387: char s[FMAX+EXPMAXDIGS+4];
2388: register int ch;
2389: register char *sp, *spe, *sp1;
2390: double atof(), x;
2391: int scale1, se;
2392: long e, exp;
2393:
2394: sp1 = sp = s;
2395: spe = sp + FMAX;
2396: exp = -d;
2397: x = 0.;
2398:
2399: do {
2400: GET(ch);
2401: w--;
2402: } while (ch == ' ' && w);
2403: switch(ch) {
2404: case '-': *sp++ = ch; sp1++; spe++;
2405: case '+':
2406: if (!w) goto zero;
2407: --w;
2408: GET(ch);
2409: }
2410: while(ch == ' ') {
2411: blankdrop:
2412: if (!w--) goto zero; GET(ch); }
2413: while(ch == '0')
2414: { if (!w--) goto zero; GET(ch); }
2415: if (ch == ' ' && cblank)
2416: goto blankdrop;
2417: scale1 = scale;
2418: while(isdigit(ch)) {
2419: digloop1:
2420: if (sp < spe) *sp++ = ch;
2421: else ++exp;
2422: digloop1e:
2423: if (!w--) goto done;
2424: GET(ch);
2425: }
2426: if (ch == ' ') {
2427: if (cblank)
2428: { ch = '0'; goto digloop1; }
2429: goto digloop1e;
2430: }
2431: if (ch == '.') {
2432: exp += d;
2433: if (!w--) goto done;
2434: GET(ch);
2435: if (sp == sp1) { /* no digits yet */
2436: while(ch == '0') {
2437: skip01:
2438: --exp;
2439: skip0:
2440: if (!w--) goto done;
2441: GET(ch);
2442: }
2443: if (ch == ' ') {
2444: if (cblank) goto skip01;
2445: goto skip0;
2446: }
2447: }
2448: while(isdigit(ch)) {
2449: digloop2:
2450: if (sp < spe)
2451: { *sp++ = ch; --exp; }
2452: digloop2e:
2453: if (!w--) goto done;
2454: GET(ch);
2455: }
2456: if (ch == ' ') {
2457: if (cblank)
2458: { ch = '0'; goto digloop2; }
2459: goto digloop2e;
2460: }
2461: }
2462: switch(ch) {
2463: default:
2464: break;
2465: case '-': se = 1; goto signonly;
2466: case '+': se = 0; goto signonly;
2467: case 'e':
2468: case 'E':
2469: case 'd':
2470: case 'D':
2471: if (!w--)
2472: goto bad;
2473: GET(ch);
2474: while(ch == ' ') {
2475: if (!w--)
2476: goto bad;
2477: GET(ch);
2478: }
2479: se = 0;
2480: switch(ch) {
2481: case '-': se = 1;
2482: case '+':
2483: signonly:
2484: if (!w--)
2485: goto bad;
2486: GET(ch);
2487: }
2488: while(ch == ' ') {
2489: if (!w--)
2490: goto bad;
2491: GET(ch);
2492: }
2493: if (!isdigit(ch))
2494: goto bad;
2495:
2496: e = ch - '0';
2497: for(;;) {
2498: if (!w--)
2499: { ch = '\n'; break; }
2500: GET(ch);
2501: if (!isdigit(ch)) {
2502: if (ch == ' ') {
2503: if (cblank)
2504: ch = '0';
2505: else continue;
2506: }
2507: else
2508: break;
2509: }
2510: e = 10*e + ch - '0';
2511: if (e > EXPMAX && sp > sp1)
2512: goto bad;
2513: }
2514: if (se)
2515: exp -= e;
2516: else
2517: exp += e;
2518: scale1 = 0;
2519: }
2520: switch(ch) {
2521: case '\n':
2522: case ',':
2523: break;
2524: default:
2525: bad:
2526: return (errno = 115);
2527: }
2528: done:
2529: if (sp > sp1) {
2530: while(*--sp == '0')
2531: ++exp;
2532: if (exp -= scale1)
2533: sprintf(sp+1, "e%ld", exp);
2534: else
2535: sp[1] = 0;
2536: x = atof(s);
2537: }
2538: zero:
2539: if (len == sizeof(real))
2540: p->pf = x;
2541: else
2542: p->pd = x;
2543: return(0);
2544: }
2545:
2546:
2547: rd_A(p,len) char *p; ftnlen len;
2548: { int i,ch;
2549: for(i=0;i<len;i++)
2550: { GET(ch);
2551: *p++=VAL(ch);
2552: }
2553: return(0);
2554: }
2555: rd_AW(p,w,len) char *p; ftnlen len;
2556: { int i,ch;
2557: if(w>=len)
2558: { for(i=0;i<w-len;i++)
2559: GET(ch);
2560: for(i=0;i<len;i++)
2561: { GET(ch);
2562: *p++=VAL(ch);
2563: }
2564: return(0);
2565: }
2566: for(i=0;i<w;i++)
2567: { GET(ch);
2568: *p++=VAL(ch);
2569: }
2570: for(i=0;i<len-w;i++) *p++=' ';
2571: return(0);
2572: }
2573: rd_H(n,s) char *s;
2574: { int i,ch;
2575: for(i=0;i<n;i++)
2576: if((ch=(*getn)())<0) return(ch);
2577: else *s++ = ch=='\n'?' ':ch;
2578: return(1);
2579: }
2580: rd_POS(s) char *s;
2581: { char quote;
2582: int ch;
2583: quote= *s++;
2584: for(;*s;s++)
2585: if(*s==quote && *(s+1)!=quote) break;
2586: else if((ch=(*getn)())<0) return(ch);
2587: else *s = ch=='\n'?' ':ch;
2588: return(1);
2589: }
2590: ./ ADD NAME=libI77/rewind.c TIME=628440564
2591: #include "f2c.h"
2592: #include "fio.h"
2593: integer f_rew(a) alist *a;
2594: {
2595: unit *b;
2596: if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"rewind");
2597: b = &units[a->aunit];
2598: if(b->ufd == NULL) return(0);
2599: if(!b->useek) err(a->aerr,106,"rewind")
2600: if(b->uwrt) {
2601: (void) t_runc(a);
2602: b->uwrt = 3;
2603: }
2604: rewind(b->ufd);
2605: b->uend=0;
2606: return(0);
2607: }
2608: ./ ADD NAME=libI77/rsfe.c TIME=628440564
2609: /* read sequential formatted external */
2610: #include "f2c.h"
2611: #include "fio.h"
2612: #include "fmt.h"
2613: extern int x_getc(),rd_ed(),rd_ned();
2614: extern int x_endp(),x_rev(),xrd_SL();
2615: integer s_rsfe(a) cilist *a; /* start */
2616: { int n;
2617: if(!init) f_init();
2618: if(n=c_sfe(a)) return(n);
2619: reading=1;
2620: sequential=1;
2621: formatted=1;
2622: external=1;
2623: elist=a;
2624: cursor=recpos=0;
2625: scale=0;
2626: fmtbuf=a->cifmt;
2627: curunit= &units[a->ciunit];
2628: cf=curunit->ufd;
2629: if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
2630: getn= x_getc;
2631: doed= rd_ed;
2632: doned= rd_ned;
2633: fmt_bg();
2634: doend=x_endp;
2635: donewrec=xrd_SL;
2636: dorevert=x_rev;
2637: cblank=curunit->ublnk;
2638: cplus=0;
2639: if(curunit->uwrt && nowreading(curunit))
2640: err(a->cierr,errno,"read start");
2641: return(0);
2642: }
2643: xrd_SL()
2644: { int ch;
2645: if(!curunit->uend)
2646: while((ch=getc(cf))!='\n' && ch!=EOF);
2647: cursor=recpos=0;
2648: return(1);
2649: }
2650: x_getc()
2651: { int ch;
2652: if(curunit->uend) return(EOF);
2653: ch = getc(cf);
2654: if(ch!=EOF && ch!='\n')
2655: { recpos++;
2656: return(ch);
2657: }
2658: if(ch=='\n')
2659: { (void) ungetc(ch,cf);
2660: return(ch);
2661: }
2662: if(curunit->uend || feof(cf))
2663: { errno=0;
2664: curunit->uend=1;
2665: return(-1);
2666: }
2667: return(-1);
2668: }
2669: x_endp()
2670: {
2671: (void) xrd_SL();
2672: return(0);
2673: }
2674: x_rev()
2675: {
2676: (void) xrd_SL();
2677: return(0);
2678: }
2679: ./ ADD NAME=libI77/sfe.c TIME=628440564
2680: /* sequential formatted external common routines*/
2681: #include "f2c.h"
2682: #include "fio.h"
2683:
2684: extern char *fmtbuf;
2685:
2686: integer e_rsfe()
2687: { int n;
2688: n=en_fio();
2689: if (cf == stdout)
2690: fflush(stdout);
2691: else if (cf == stderr)
2692: fflush(stderr);
2693: fmtbuf=NULL;
2694: return(n);
2695: }
2696: c_sfe(a) cilist *a; /* check */
2697: { unit *p;
2698: if(a->ciunit >= MXUNIT || a->ciunit<0)
2699: err(a->cierr,101,"startio");
2700: p = &units[a->ciunit];
2701: if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
2702: if(!p->ufmt) err(a->cierr,102,"sfe")
2703: return(0);
2704: }
2705: integer e_wsfe()
2706: { return(e_rsfe());
2707: }
2708: ./ ADD NAME=libI77/sue.c TIME=628440564
2709: #include "f2c.h"
2710: #include "fio.h"
2711: extern int reclen;
2712: long recloc;
2713:
2714: integer s_rsue(a) cilist *a;
2715: {
2716: int n;
2717: if(!init) f_init();
2718: reading=1;
2719: if(n=c_sue(a)) return(n);
2720: recpos=0;
2721: if(curunit->uwrt && nowreading(curunit))
2722: err(a->cierr, errno, "read start");
2723: if(fread((char *)&reclen,sizeof(int),1,cf)
2724: != 1)
2725: { if(feof(cf))
2726: { curunit->uend = 1;
2727: err(a->ciend, EOF, "start");
2728: }
2729: clearerr(cf);
2730: err(a->cierr, errno, "start");
2731: }
2732: return(0);
2733: }
2734: integer s_wsue(a) cilist *a;
2735: {
2736: int n;
2737: if(!init) f_init();
2738: if(n=c_sue(a)) return(n);
2739: reading=0;
2740: reclen=0;
2741: if(curunit->uwrt != 1 && nowwriting(curunit))
2742: err(a->cierr, errno, "write start");
2743: recloc=ftell(cf);
2744: (void) fseek(cf,(long)sizeof(int),1);
2745: return(0);
2746: }
2747: c_sue(a) cilist *a;
2748: {
2749: if(a->ciunit >= MXUNIT || a->ciunit < 0)
2750: err(a->cierr,101,"startio");
2751: external=sequential=1;
2752: formatted=0;
2753: curunit = &units[a->ciunit];
2754: elist=a;
2755: if(curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
2756: err(a->cierr,114,"sue");
2757: cf=curunit->ufd;
2758: if(curunit->ufmt) err(a->cierr,103,"sue")
2759: if(!curunit->useek) err(a->cierr,103,"sue")
2760: return(0);
2761: }
2762: integer e_wsue()
2763: { long loc;
2764: (void) fwrite((char *)&reclen,sizeof(int),1,cf);
2765: loc=ftell(cf);
2766: (void) fseek(cf,recloc,0);
2767: (void) fwrite((char *)&reclen,sizeof(int),1,cf);
2768: (void) fseek(cf,loc,0);
2769: return(0);
2770: }
2771: integer e_rsue()
2772: {
2773: (void) fseek(cf,(long)(reclen-recpos+sizeof(int)),1);
2774: return(0);
2775: }
2776: ./ ADD NAME=libI77/uio.c TIME=628440564
2777: #include "f2c.h"
2778: #include "fio.h"
2779: int reclen;
2780: do_us(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
2781: {
2782: if(reading)
2783: {
2784: recpos += *number * len;
2785: if(recpos>reclen)
2786: {
2787: err(elist->ciend,(-1), "eof/uio");
2788: }
2789: (void) fread(ptr,(int)len,(int)(*number),cf);
2790: return(0);
2791: }
2792: else
2793: {
2794: reclen += *number * len;
2795: (void) fwrite(ptr,(int)len,(int)(*number),cf);
2796: return(0);
2797: }
2798: }
2799: integer do_uio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
2800: {
2801: if(sequential)
2802: return(do_us(number,ptr,len));
2803: else return(do_ud(number,ptr,len));
2804: }
2805: do_ud(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
2806: {
2807: recpos += *number * len;
2808: if(recpos > curunit->url && curunit->url!=1)
2809: err(elist->cierr,110,"eof/uio");
2810: if(reading)
2811: {
2812: if(fread(ptr,(int)len,(int)(*number),cf)
2813: != *number)
2814: err(elist->cierr,27,"eof/uio")
2815: else return(0);
2816: }
2817: (void) fwrite(ptr,(int)len,(int)(*number),cf);
2818: return(0);
2819: }
2820: ./ ADD NAME=libI77/util.c TIME=628473389
2821: #include "sys/types.h"
2822: #include "sys/stat.h"
2823: #include "f2c.h"
2824: #include "fio.h"
2825:
2826: g_char(a,alen,b) char *a,*b; ftnlen alen;
2827: { char *x=a+alen-1,*y=b+alen-1;
2828: *(y+1)=0;
2829: for(;x>=a && *x==' ';x--) *y--=0;
2830: for(;x>=a;*y--= *x--);
2831: }
2832: b_char(a,b,blen) char *a,*b; ftnlen blen;
2833: { int i;
2834: for(i=0;i<blen && *a!=0;i++) *b++= *a++;
2835: for(;i<blen;i++) *b++=' ';
2836: }
2837: inode(a) char *a;
2838: { struct stat x;
2839: if(stat(a,&x)<0) return(-1);
2840: return(x.st_ino);
2841: }
2842: #define DONE {*bufpos++=0; (void) close(file); return;}
2843: #define INTBOUND sizeof(int)-1
2844: mvgbt(n,len,a,b) char *a,*b;
2845: { register int num=n*len;
2846: if( ((int)a&INTBOUND)==0 && ((int)b&INTBOUND)==0 && (num&INTBOUND)==0 )
2847: { register int *x=(int *)a,*y=(int *)b;
2848: num /= sizeof(int);
2849: if(x>y) for(;num>0;num--) *y++= *x++;
2850: else for(num--;num>=0;num--) *(y+num)= *(x+num);
2851: }
2852: else
2853: { register char *x=a,*y=b;
2854: if(x>y) for(;num>0;num--) *y++= *x++;
2855: else for(num--;num>=0;num--) *(y+num)= *(x+num);
2856: }
2857: }
2858: ./ ADD NAME=libI77/wref.c TIME=628965453
2859: #include "f2c.h"
2860: #include "fio.h"
2861: #include "fmt.h"
2862: #include "fp.h"
2863: #ifndef VAX
2864: #include "ctype.h"
2865: #endif
2866:
2867: wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
2868: {
2869: char buf[FMAX+EXPMAXDIGS+4], *s, *se;
2870: int d1, delta, e1, i, sign, signspace;
2871: double dd;
2872: #ifndef VAX
2873: int e0 = e;
2874: #endif
2875:
2876: if(e <= 0)
2877: e = 2;
2878: if(scale) {
2879: if(scale >= d + 2 || scale <= -d)
2880: goto nogood;
2881: }
2882: if(scale <= 0)
2883: --d;
2884: if (len == sizeof(real))
2885: dd = p->pf;
2886: else
2887: dd = p->pd;
2888: if (dd >= 0.) {
2889: sign = 0;
2890: signspace = cplus;
2891: #ifndef VAX
2892: if (!dd)
2893: dd = 0.; /* avoid -0 */
2894: #endif
2895: }
2896: else {
2897: signspace = sign = 1;
2898: dd = -dd;
2899: }
2900: delta = w - (2 /* for the . and the d adjustment above */
2901: + 2 /* for the E+ */ + signspace + d + e);
2902: if (delta < 0) {
2903: nogood:
2904: while(--w >= 0)
2905: PUT('*');
2906: return(0);
2907: }
2908: if (scale < 0)
2909: d += scale;
2910: if (d > FMAX) {
2911: d1 = d - FMAX;
2912: d = FMAX;
2913: }
2914: else
2915: d1 = 0;
2916: sprintf(buf,"%#.*E", d, dd);
2917: #ifndef VAX
2918: /* check for NaN, Infinity */
2919: if (!isdigit(buf[0])) {
2920: delta = w - strlen(buf) - signspace;
2921: if (delta < 0)
2922: goto nogood;
2923: while(--delta >= 0)
2924: PUT(' ');
2925: if (signspace)
2926: PUT(sign ? '-' : '+');
2927: for(s = buf; *s; s++)
2928: PUT(*s);
2929: return 0;
2930: }
2931: #endif
2932: se = buf + d + 3;
2933: if (scale != 1 && dd)
2934: sprintf(se, "%+.2d", atoi(se) + 1 - scale);
2935: s = ++se;
2936: if (e < 2) {
2937: if (*s != '0')
2938: goto nogood;
2939: }
2940: #ifndef VAX
2941: /* accommodate 3 significant digits in exponent */
2942: if (s[2]) {
2943: #ifdef Pedantic
2944: if (!e0 && !s[3])
2945: for(s -= 2, e1 = 2; s[0] = s[1]; s++);
2946:
2947: /* Pedantic gives the behavior that Fortran 77 specifies, */
2948: /* i.e., requires that E be specified for exponent fields */
2949: /* of more than 3 digits. With Pedantic undefined, we get */
2950: /* the behavior that Cray displays -- you get a bigger */
2951: /* exponent field if it fits. */
2952: #else
2953: if (!e0) {
2954: for(s -= 2, e1 = 2; s[0] = s[1]; s++)
2955: #ifdef CRAY
2956: delta--;
2957: if ((delta += 4) < 0)
2958: goto nogood
2959: #endif
2960: ;
2961: }
2962: #endif
2963: else if (e0 >= 0)
2964: goto shift;
2965: else
2966: e1 = e;
2967: }
2968: else
2969: shift:
2970: #endif
2971: for(s += 2, e1 = 2; *s; ++e1, ++s)
2972: if (e1 >= e)
2973: goto nogood;
2974: while(--delta >= 0)
2975: PUT(' ');
2976: if (signspace)
2977: PUT(sign ? '-' : '+');
2978: s = buf;
2979: i = scale;
2980: if (scale <= 0) {
2981: PUT('.');
2982: for(; i < 0; ++i)
2983: PUT('0');
2984: PUT(*s);
2985: s += 2;
2986: }
2987: else if (scale > 1) {
2988: PUT(*s);
2989: s += 2;
2990: while(--i > 0)
2991: PUT(*s++);
2992: PUT('.');
2993: }
2994: if (d1) {
2995: se -= 2;
2996: while(s < se) PUT(*s++);
2997: se += 2;
2998: do PUT('0'); while(--d1 > 0);
2999: }
3000: while(s < se)
3001: PUT(*s++);
3002: if (e < 2)
3003: PUT(s[1]);
3004: else {
3005: while(++e1 <= e)
3006: PUT('0');
3007: while(*s)
3008: PUT(*s++);
3009: }
3010: return 0;
3011: }
3012:
3013: wrt_F(p,w,d,len) ufloat *p; ftnlen len;
3014: {
3015: int d1, sign, n;
3016: double x;
3017: char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
3018:
3019: x= (len==sizeof(real)?p->pf:p->pd);
3020: if (d < MAXFRACDIGS)
3021: d1 = 0;
3022: else {
3023: d1 = d - MAXFRACDIGS;
3024: d = MAXFRACDIGS;
3025: }
3026: if (x < 0.)
3027: { x = -x; sign = 1; }
3028: else {
3029: sign = 0;
3030: #ifndef VAX
3031: if (!x)
3032: x = 0.;
3033: #endif
3034: }
3035:
3036: if (n = scale)
3037: if (n > 0)
3038: do x *= 10.; while(--n > 0);
3039: else
3040: do x *= 0.1; while(++n < 0);
3041:
3042: #ifdef USE_STRLEN
3043: sprintf(b = buf, "%#.*f", d, x);
3044: n = strlen(b) + d1;
3045: #else
3046: n = sprintf(b = buf, "%#.*f", d, x) + d1;
3047: #endif
3048:
3049: if (buf[0] == '0' && d)
3050: { ++b; --n; }
3051: if (sign) {
3052: /* check for all zeros */
3053: for(s = b;;) {
3054: while(*s == '0') s++;
3055: switch(*s) {
3056: case '.':
3057: s++; continue;
3058: case 0:
3059: sign = 0;
3060: }
3061: break;
3062: }
3063: }
3064: if (sign || cplus)
3065: ++n;
3066: if (n > w) {
3067: while(--w >= 0)
3068: PUT('*');
3069: return 0;
3070: }
3071: for(w -= n; --w >= 0; )
3072: PUT(' ');
3073: if (sign)
3074: PUT('-');
3075: else if (cplus)
3076: PUT('+');
3077: while(n = *b++)
3078: PUT(n);
3079: while(--d1 >= 0)
3080: PUT('0');
3081: return 0;
3082: }
3083: ./ ADD NAME=libI77/wrtfmt.c TIME=629040813
3084: #include "f2c.h"
3085: #include "fio.h"
3086: #include "fmt.h"
3087: extern int cursor;
3088: extern char *icvt(), *ecvt();
3089: int hiwater;
3090: icilist *svic;
3091: char *icptr;
3092: mv_cur() /* shouldn't use fseek because it insists on calling fflush */
3093: /* instead we know too much about stdio */
3094: {
3095: if(external == 0) {
3096: if(cursor < 0) {
3097: if(hiwater < recpos)
3098: hiwater = recpos;
3099: recpos += cursor;
3100: icptr += cursor;
3101: cursor = 0;
3102: if(recpos < 0)
3103: err(elist->cierr, 110, "left off");
3104: }
3105: else if(cursor > 0) {
3106: if(recpos + cursor >= svic->icirlen)
3107: err(elist->cierr, 110, "recend");
3108: if(hiwater <= recpos)
3109: for(; cursor > 0; cursor--)
3110: (*putn)(' ');
3111: else if(hiwater <= recpos + cursor) {
3112: cursor -= hiwater - recpos;
3113: icptr += hiwater - recpos;
3114: recpos = hiwater;
3115: for(; cursor > 0; cursor--)
3116: (*putn)(' ');
3117: }
3118: else {
3119: icptr += cursor;
3120: recpos += cursor;
3121: }
3122: cursor = 0;
3123: }
3124: return(0);
3125: }
3126: if(cursor > 0) {
3127: if(hiwater <= recpos)
3128: for(;cursor>0;cursor--) (*putn)(' ');
3129: else if(hiwater <= recpos + cursor) {
3130: #ifndef NON_UNIX_STDIO
3131: if(cf->_ptr + hiwater - recpos < buf_end(cf))
3132: cf->_ptr += hiwater - recpos;
3133: else
3134: #endif
3135: (void) fseek(cf, (long) (hiwater - recpos), 1);
3136: cursor -= hiwater - recpos;
3137: recpos = hiwater;
3138: for(; cursor > 0; cursor--)
3139: (*putn)(' ');
3140: }
3141: else {
3142: #ifndef NON_UNIX_STDIO
3143: if(cf->_ptr + cursor < buf_end(cf))
3144: cf->_ptr += cursor;
3145: else
3146: #endif
3147: (void) fseek(cf, (long)cursor, 1);
3148: recpos += cursor;
3149: }
3150: }
3151: if(cursor<0)
3152: {
3153: if(cursor+recpos<0) err(elist->cierr,110,"left off");
3154: #ifndef NON_UNIX_STDIO
3155: if(cf->_ptr + cursor >= cf->_base)
3156: cf->_ptr += cursor;
3157: else
3158: #endif
3159: if(curunit->useek) (void) fseek(cf,(long)cursor,1);
3160: else err(elist->cierr,106,"fmt");
3161: if(hiwater < recpos)
3162: hiwater = recpos;
3163: recpos += cursor;
3164: cursor=0;
3165: }
3166: return(0);
3167: }
3168: w_ed(p,ptr,len) char *ptr; struct syl *p; ftnlen len;
3169: {
3170: if(cursor && mv_cur()) return(mv_cur());
3171: switch(p->op)
3172: {
3173: default:
3174: fprintf(stderr,"w_ed, unexpected code: %d\n%s\n",
3175: p->op,fmtbuf);
3176: abort();
3177: case I: return(wrt_I((uint *)ptr,p->p1,len, 10));
3178: case IM:
3179: return(wrt_IM((uint *)ptr,p->p1,p->p2,len));
3180: case O: return(wrt_I((uint *)ptr, p->p1, len, 8));
3181: case L: return(wrt_L((uint *)ptr,p->p1, len));
3182: case A: return(wrt_A(ptr,len));
3183: case AW:
3184: return(wrt_AW(ptr,p->p1,len));
3185: case D:
3186: case E:
3187: case EE:
3188: return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
3189: case G:
3190: case GE:
3191: return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
3192: case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
3193: }
3194: }
3195: w_ned(p) struct syl *p;
3196: {
3197: switch(p->op)
3198: {
3199: default: fprintf(stderr,"w_ned, unexpected code: %d\n%s\n",
3200: p->op,fmtbuf);
3201: abort();
3202: case SLASH:
3203: return((*donewrec)());
3204: case T: cursor = p->p1-recpos - 1;
3205: return(1);
3206: case TL: cursor -= p->p1;
3207: if(cursor < -recpos) /* TL1000, 1X */
3208: cursor = -recpos;
3209: return(1);
3210: case TR:
3211: case X:
3212: cursor += p->p1;
3213: return(1);
3214: case APOS:
3215: return(wrt_AP(*(char **)&p->p2));
3216: case H:
3217: return(wrt_H(p->p1,*(char **)&p->p2));
3218: }
3219: }
3220: wrt_I(n,w,len, base) uint *n; ftnlen len; register int base;
3221: { int ndigit,sign,spare,i;
3222: long x;
3223: char *ans;
3224: if(len==sizeof(integer)) x=n->il;
3225: else if(len == sizeof(char)) x = n->ic;
3226: else x=n->is;
3227: ans=icvt(x,&ndigit,&sign, base);
3228: spare=w-ndigit;
3229: if(sign || cplus) spare--;
3230: if(spare<0)
3231: for(i=0;i<w;i++) (*putn)('*');
3232: else
3233: { for(i=0;i<spare;i++) (*putn)(' ');
3234: if(sign) (*putn)('-');
3235: else if(cplus) (*putn)('+');
3236: for(i=0;i<ndigit;i++) (*putn)(*ans++);
3237: }
3238: return(0);
3239: }
3240: wrt_IM(n,w,m,len) uint *n; ftnlen len;
3241: { int ndigit,sign,spare,i,xsign;
3242: long x;
3243: char *ans;
3244: if(sizeof(integer)==len) x=n->il;
3245: else if(len == sizeof(char)) x = n->ic;
3246: else x=n->is;
3247: ans=icvt(x,&ndigit,&sign, 10);
3248: if(sign || cplus) xsign=1;
3249: else xsign=0;
3250: if(ndigit+xsign>w || m+xsign>w)
3251: { for(i=0;i<w;i++) (*putn)('*');
3252: return(0);
3253: }
3254: if(x==0 && m==0)
3255: { for(i=0;i<w;i++) (*putn)(' ');
3256: return(0);
3257: }
3258: if(ndigit>=m)
3259: spare=w-ndigit-xsign;
3260: else
3261: spare=w-m-xsign;
3262: for(i=0;i<spare;i++) (*putn)(' ');
3263: if(sign) (*putn)('-');
3264: else if(cplus) (*putn)('+');
3265: for(i=0;i<m-ndigit;i++) (*putn)('0');
3266: for(i=0;i<ndigit;i++) (*putn)(*ans++);
3267: return(0);
3268: }
3269: wrt_AP(s)
3270: char *s;
3271: { char quote;
3272: if(cursor && mv_cur()) return(mv_cur());
3273: quote = *s++;
3274: for(;*s;s++)
3275: { if(*s!=quote) (*putn)(*s);
3276: else if(*++s==quote) (*putn)(*s);
3277: else return(1);
3278: }
3279: return(1);
3280: }
3281: wrt_H(a,s)
3282: char *s;
3283: {
3284: if(cursor && mv_cur()) return(mv_cur());
3285: while(a--) (*putn)(*s++);
3286: return(1);
3287: }
3288: wrt_L(n,len, sz) uint *n; ftnlen sz;
3289: { int i;
3290: long x;
3291: if(sizeof(integer)==sz) x=n->il;
3292: else if(sz == sizeof(char)) x = n->ic;
3293: else x=n->is;
3294: for(i=0;i<len-1;i++)
3295: (*putn)(' ');
3296: if(x) (*putn)('T');
3297: else (*putn)('F');
3298: return(0);
3299: }
3300: wrt_A(p,len) char *p; ftnlen len;
3301: {
3302: while(len-- > 0) (*putn)(*p++);
3303: return(0);
3304: }
3305: wrt_AW(p,w,len) char * p; ftnlen len;
3306: {
3307: while(w>len)
3308: { w--;
3309: (*putn)(' ');
3310: }
3311: while(w-- > 0)
3312: (*putn)(*p++);
3313: return(0);
3314: }
3315:
3316: wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
3317: { double up = 1,x;
3318: int i,oldscale=scale,n,j;
3319: x= len==sizeof(real)?p->pf:p->pd;
3320: if(x < 0 ) x = -x;
3321: if(x<.1) return(wrt_E(p,w,d,e,len));
3322: for(i=0;i<=d;i++,up*=10)
3323: { if(x>=up) continue;
3324: scale=0;
3325: if(e==0) n=4;
3326: else n=e+2;
3327: i=wrt_F(p,w-n,d-i,len);
3328: for(j=0;j<n;j++) (*putn)(' ');
3329: scale=oldscale;
3330: return(i);
3331: }
3332: return(wrt_E(p,w,d,e,len));
3333: }
3334: ./ ADD NAME=libI77/wsfe.c TIME=628440564
3335: /*write sequential formatted external*/
3336: #include "f2c.h"
3337: #include "fio.h"
3338: #include "fmt.h"
3339: extern int x_putc(),w_ed(),w_ned();
3340: extern int xw_end(),xw_rev(),x_wSL();
3341: extern int hiwater;
3342: integer s_wsfe(a) cilist *a; /*start*/
3343: { int n;
3344: if(!init) f_init();
3345: if(n=c_sfe(a)) return(n);
3346: reading=0;
3347: sequential=1;
3348: formatted=1;
3349: external=1;
3350: elist=a;
3351: hiwater = cursor=recpos=0;
3352: nonl = 0;
3353: scale=0;
3354: fmtbuf=a->cifmt;
3355: curunit = &units[a->ciunit];
3356: cf=curunit->ufd;
3357: if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
3358: putn= x_putc;
3359: doed= w_ed;
3360: doned= w_ned;
3361: doend=xw_end;
3362: dorevert=xw_rev;
3363: donewrec=x_wSL;
3364: fmt_bg();
3365: cplus=0;
3366: cblank=curunit->ublnk;
3367: if(curunit->uwrt != 1 && nowwriting(curunit))
3368: err(a->cierr,errno,"write start");
3369: return(0);
3370: }
3371: x_putc(c)
3372: {
3373: /* this uses \n as an indicator of record-end */
3374: if(c == '\n' && recpos < hiwater) { /* fseek calls fflush, a loss */
3375: #ifndef NON_UNIX_STDIO
3376: if(cf->_ptr + hiwater - recpos < buf_end(cf))
3377: cf->_ptr += hiwater - recpos;
3378: else
3379: #endif
3380: (void) fseek(cf, (long)(hiwater - recpos), 1);
3381: }
3382: putc(c,cf);
3383: recpos++;
3384: }
3385: pr_put(c)
3386: { static flag new = 1;
3387: recpos++;
3388: if(c=='\n')
3389: { new=1;
3390: putc(c,cf);
3391: }
3392: else if(new==1)
3393: { new=0;
3394: if(c=='0') putc('\n',cf);
3395: else if(c=='1') putc('\f',cf);
3396: }
3397: else putc(c,cf);
3398: }
3399: x_wSL()
3400: {
3401: (*putn)('\n');
3402: recpos=0;
3403: cursor = 0;
3404: hiwater = 0;
3405: return(1);
3406: }
3407: xw_end()
3408: {
3409: if(nonl == 0)
3410: (*putn)('\n');
3411: hiwater = recpos = cursor = 0;
3412: return(0);
3413: }
3414: xw_rev()
3415: {
3416: if(workdone) (*putn)('\n');
3417: hiwater = recpos = cursor = 0;
3418: return(workdone=0);
3419: }
3420: ./ ADD NAME=libI77/namelist.c TIME=628989101
3421: #include "f2c.h"
3422: #include "fio.h"
3423:
3424: s_rsne(a)
3425: cilist *a;
3426: {
3427: int n;
3428: if(!init)
3429: f_init();
3430: if(n=c_le(a))
3431: return(n);
3432: reading=1;
3433: external=1;
3434: formatted=1;
3435:
3436: err(a->cierr, 118, "namelist read -- not yet implemented");
3437: }
3438:
3439: s_wsne(a)
3440: cilist *a;
3441: {
3442: int n;
3443: if(!init)
3444: f_init();
3445: if(n=c_le(a))
3446: return(n);
3447: reading=0;
3448: external=1;
3449: formatted=1;
3450:
3451: err(a->cierr, 118, "namelist write -- not yet implemented");
3452: }
3453: ./ ENDUP
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.