![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to I77a.st CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10dc / cmd / f2c|
Return to I77a.st CVS log | Up to [Research Unix] / researchv10dc / cmd / f2c |
1.1 root 1: ./ ADD NAME=Version.c TIME=706280454
2: static char junk[] = "\n@(#) LIBI77 VERSION pjw,dmg-mods 19 May 1992\n";
3:
4: /*
5: 2.01 $ format added
6: 2.02 Coding bug in open.c repaired
7: 2.03 fixed bugs in lread.c (read * with negative f-format) and lio.c
8: and lio.h (e-format conforming to spec)
9: 2.04 changed open.c and err.c (fopen and freopen respectively) to
10: update to new c-library (append mode)
11: 2.05 added namelist capability
12: 2.06 allow internal list and namelist I/O
13: */
14:
15: /*
16: close.c:
17: allow upper-case STATUS= values
18: endfile.c
19: create fort.nnn if unit nnn not open;
20: else if (file length == 0) use creat() rather than copy;
21: use local copy() rather than forking /bin/cp;
22: rewind, fseek to clear buffer (for no reading past EOF)
23: err.c
24: use neither setbuf nor setvbuf; make stderr buffered
25: fio.h
26: #define _bufend
27: inquire.c
28: upper case responses;
29: omit byfile test from SEQUENTIAL=
30: answer "YES" to DIRECT= for unopened file (open to debate)
31: lio.c
32: flush stderr, stdout at end of each stmt
33: space before character strings in list output only at line start
34: lio.h
35: adjust LEW, LED consistent with old libI77
36: lread.c
37: use atof()
38: allow "nnn*," when reading complex constants
39: open.c
40: try opening for writing when open for read fails, with
41: special uwrt value (2) delaying creat() to first write;
42: set curunit so error messages don't drop core;
43: no file name ==> fort.nnn except for STATUS='SCRATCH'
44: rdfmt.c
45: use atof(); trust EOF == end-of-file (so don't read past
46: end-of-file after endfile stmt)
47: sfe.c
48: flush stderr, stdout at end of each stmt
49: wrtfmt.c:
50: use upper case
51: put wrt_E and wrt_F into wref.c, use sprintf()
52: rather than ecvt() and fcvt() [more accurate on VAX]
53: */
54:
55: /* 16 Oct. 1988: uwrt = 3 after write, rewind, so close won't zap the file. */
56:
57: /* 10 July 1989: change _bufend to buf_end in fio.h, wsfe.c, wrtfmt.c */
58:
59: /* 28 Nov. 1989: corrections for IEEE and Cray arithmetic */
60: /* 29 Nov. 1989: change various int return types to long for f2c */
61: /* 30 Nov. 1989: various types from f2c.h */
62: /* 6 Dec. 1989: types corrected various places */
63: /* 19 Dec. 1989: make iostat= work right for internal I/O */
64: /* 8 Jan. 1990: add rsne, wsne -- routines for handling NAMELIST */
65: /* 28 Jan. 1990: have NAMELIST read treat $ as &, general white
66: space as blank */
67: /* 27 Mar. 1990: change an = to == in rd_L(rdfmt.c) so formatted reads
68: of logical values reject letters other than fFtT;
69: have nowwriting reset cf */
70: /* 14 Aug. 1990: adjust lread.c to treat tabs as spaces in list input */
71: /* 17 Aug. 1990: adjust open.c to recognize blank='Z...' as well as
72: blank='z...' when reopening an open file */
73: /* 30 Aug. 1990: prevent embedded blanks in list output of complex values;
74: omit exponent field in list output of values of
75: magnitude between 10 and 1e8; prevent writing stdin
76: and reading stdout or stderr; don't close stdin, stdout,
77: or stderr when reopening units 5, 6, 0. */
78: /* 18 Sep. 1990: add component udev to unit and consider old == new file
79: iff uinode and udev values agree; use stat rather than
80: access to check existence of file (when STATUS='OLD')*/
81: /* 2 Oct. 1990: adjust rewind.c so two successive rewinds after a write
82: don't clobber the file. */
83: /* 9 Oct. 1990: add #include "fcntl.h" to endfile.c, err.c, open.c;
84: adjust g_char in util.c for segmented memories. */
85: /* 17 Oct. 1990: replace abort() and _cleanup() with calls on
86: sig_die(...,1) (defined in main.c). */
87: /* 5 Nov. 1990: changes to open.c: complain if new= is specified and the
88: file already exists; allow file= to be omitted in open stmts
89: and allow status='replace' (Fortran 90 extensions). */
90: /* 11 Dec. 1990: adjustments for POSIX. */
91: /* 15 Jan. 1991: tweak i_ungetc in rsli.c to allow reading from
92: strings in read-only memory. */
93: /* 25 Apr. 1991: adjust namelist stuff to work with f2c -i2 */
94: /* 26 Apr. 1991: fix some bugs with NAMELIST read of multi-dim. arrays */
95: /* 16 May 1991: increase LEFBL in lio.h to bypass NeXT bug */
96: /* 17 Oct. 1991: change type of length field in sequential unformatted
97: records from int to long (for systems where sizeof(int)
98: can vary, depending on the compiler or compiler options). */
99: /* 14 Nov. 1991: change uint to Uint in fmt.h, rdfmt.c, wrtfmt.c.
100: /* 25 Nov. 1991: change uint to Uint in lwrite.c; change sizeof(int) to
101: sizeof(uioint) in fseeks in sue.c (missed on 17 Oct.). */
102: /* 1 Dec. 1991: uio.c: add test for read failure (seq. unformatted reads);
103: adjust an error return from EOF to off end of record */
104: /* 12 Dec. 1991: rsli.c: fix bug with internal list input that caused
105: the last character of each record to be ignored.
106: iio.c: adjust error message in internal formatted
107: input from "end-of-file" to "off end of record" if
108: the format specifies more characters than the
109: record contains. */
110: /* 17 Jan. 1992: lread.c, rsne.c: in list and namelist input,
111: treat "r* ," and "r*," alike (where r is a
112: positive integer constant), and fix a bug in
113: handling null values following items with repeat
114: counts (e.g., 2*1,,3); for namelist reading
115: of a numeric array, allow a new name-value subsequence
116: to terminate the current one (as though the current
117: one ended with the right number of null values).
118: lio.h, lwrite.c: omit insignificant zeros in
119: list and namelist output. To get the old
120: behavior, compile with -DOld_list_output . */
121: /* 18 Jan. 1992: make list output consistent with F format by
122: printing .1 rather than 0.1 (introduced yesterday). */
123: /* 3 Feb. 1992: rsne.c: fix namelist read bug that caused the
124: character following a comma to be ignored. */
125: /* 19 May 1992: adjust iio.c, ilnw.c, rdfmt.c and rsli.c to make err=
126: work with internal list and formatted I/O. */
127: ./ ADD NAME=backspace.c TIME=708815578
128: #include "f2c.h"
129: #include "fio.h"
130: #ifdef KR_headers
131: integer f_back(a) alist *a;
132: #else
133: integer f_back(alist *a)
134: #endif
135: { unit *b;
136: int n,i;
137: long x;
138: char buf[32];
139: if(a->aunit >= MXUNIT || a->aunit < 0)
140: err(a->aerr,101,"backspace")
141: b= &units[a->aunit];
142: if(b->useek==0) err(a->aerr,106,"backspace")
143: if(b->ufd==NULL) {
144: fk_open(1, 1, a->aunit);
145: return(0);
146: }
147: if(b->uend==1)
148: { b->uend=0;
149: return(0);
150: }
151: if(b->uwrt) {
152: (void) t_runc(a);
153: if (nowreading(b))
154: err(a->aerr,errno,"backspace")
155: }
156: if(b->url>0)
157: { long y;
158: x=ftell(b->ufd);
159: y = x % b->url;
160: if(y == 0) x--;
161: x /= b->url;
162: x *= b->url;
163: (void) fseek(b->ufd,x,SEEK_SET);
164: return(0);
165: }
166:
167: if(b->ufmt==0)
168: { (void) fseek(b->ufd,-(long)sizeof(int),SEEK_CUR);
169: (void) fread((char *)&n,sizeof(int),1,b->ufd);
170: (void) fseek(b->ufd,-(long)n-2*sizeof(int),SEEK_CUR);
171: return(0);
172: }
173: for(;;)
174: { long y;
175: y = x=ftell(b->ufd);
176: if(x<sizeof(buf)) x=0;
177: else x -= sizeof(buf);
178: (void) fseek(b->ufd,x,SEEK_SET);
179: n=fread(buf,1,(int)(y-x), b->ufd);
180: for(i=n-2;i>=0;i--)
181: {
182: if(buf[i]!='\n') continue;
183: (void) fseek(b->ufd,(long)(i+1-n),SEEK_CUR);
184: return(0);
185: }
186: if(x==0)
187: {
188: (void) fseek(b->ufd, 0L, SEEK_SET);
189: return(0);
190: }
191: else if(n<=0) err(a->aerr,(EOF),"backspace")
192: (void) fseek(b->ufd, x, SEEK_SET);
193: }
194: }
195: ./ ADD NAME=close.c TIME=708917753
196: #include "f2c.h"
197: #include "fio.h"
198: #ifdef KR_headers
199: integer f_clos(a) cllist *a;
200: #else
201: #undef abs
202: #include "stdlib.h"
203: #ifdef MSDOS
204: #include "io.h"
205: #else
206: #ifdef __cplusplus
207: extern "C" int unlink(char*);
208: #else
209: extern int unlink(char*);
210: #endif
211: #endif
212:
213: integer f_clos(cllist *a)
214: #endif
215: { unit *b;
216:
217: if(a->cunit >= MXUNIT) return(0);
218: b= &units[a->cunit];
219: if(b->ufd==NULL)
220: goto done;
221: if (!a->csta)
222: if (b->uscrtch == 1)
223: goto Delete;
224: else
225: goto Keep;
226: switch(*a->csta) {
227: default:
228: Keep:
229: case 'k':
230: case 'K':
231: if(b->uwrt == 1)
232: (void) t_runc((alist *)a);
233: if(b->ufnm) {
234: (void) fclose(b->ufd);
235: free(b->ufnm);
236: }
237: break;
238: case 'd':
239: case 'D':
240: Delete:
241: if(b->ufnm) {
242: (void) fclose(b->ufd);
243: (void) unlink(b->ufnm); /*SYSDEP*/
244: free(b->ufnm);
245: }
246: }
247: b->ufd=NULL;
248: done:
249: b->uend=0;
250: b->ufnm=NULL;
251: return(0);
252: }
253: void
254: #ifdef KR_headers
255: f_exit()
256: #else
257: f_exit(void)
258: #endif
259: { int i;
260: static cllist xx;
261: if (!xx.cerr) {
262: xx.cerr=1;
263: xx.csta=NULL;
264: for(i=0;i<MXUNIT;i++)
265: {
266: xx.cunit=i;
267: (void) f_clos(&xx);
268: }
269: }
270: }
271: void
272: #ifdef KR_headers
273: flush_()
274: #else
275: flush_(void)
276: #endif
277: { int i;
278: for(i=0;i<MXUNIT;i++)
279: if(units[i].ufd != NULL) (void) fflush(units[i].ufd);
280: }
281: ./ ADD NAME=dfe.c TIME=708823203
282: #include "f2c.h"
283: #include "fio.h"
284: #include "fmt.h"
285:
286: y_rsk(Void)
287: {
288: if(curunit->uend || curunit->url <= recpos
289: || curunit->url == 1) return 0;
290: do {
291: getc(cf);
292: } while(++recpos < curunit->url);
293: return 0;
294: }
295: y_getc(Void)
296: {
297: int ch;
298: if(curunit->uend) return(-1);
299: if((ch=getc(cf))!=EOF)
300: {
301: recpos++;
302: if(curunit->url>=recpos ||
303: curunit->url==1)
304: return(ch);
305: else return(' ');
306: }
307: if(feof(cf))
308: {
309: curunit->uend=1;
310: errno=0;
311: return(-1);
312: }
313: err(elist->cierr,errno,"readingd");
314: }
315: #ifdef KR_headers
316: y_putc(c)
317: #else
318: y_putc(int c)
319: #endif
320: {
321: recpos++;
322: if(recpos <= curunit->url || curunit->url==1)
323: putc(c,cf);
324: else
325: err(elist->cierr,110,"dout");
326: return(0);
327: }
328: y_rev(Void)
329: { /*what about work done?*/
330: if(curunit->url==1 || recpos==curunit->url)
331: return(0);
332: while(recpos<curunit->url)
333: (*putn)(' ');
334: recpos=0;
335: return(0);
336: }
337: y_err(Void)
338: {
339: err(elist->cierr, 110, "dfe");
340: }
341:
342: y_newrec(Void)
343: {
344: if(curunit->url == 1 || recpos == curunit->url) {
345: hiwater = recpos = cursor = 0;
346: return(1);
347: }
348: if(hiwater > recpos)
349: recpos = hiwater;
350: y_rev();
351: hiwater = cursor = 0;
352: return(1);
353: }
354:
355: #ifdef KR_headers
356: c_dfe(a) cilist *a;
357: #else
358: c_dfe(cilist *a)
359: #endif
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),SEEK_SET);
375: curunit->uend = 0;
376: return(0);
377: }
378: #ifdef KR_headers
379: integer s_rdfe(a) cilist *a;
380: #else
381: integer s_rdfe(cilist *a)
382: #endif
383: {
384: int n;
385: if(!init) f_init();
386: if(n=c_dfe(a))return(n);
387: reading=1;
388: if(curunit->uwrt && nowreading(curunit))
389: err(a->cierr,errno,"read start");
390: getn = y_getc;
391: doed = rd_ed;
392: doned = rd_ned;
393: dorevert = donewrec = y_err;
394: doend = y_rsk;
395: if(pars_f(fmtbuf)<0)
396: err(a->cierr,100,"read start");
397: fmt_bg();
398: return(0);
399: }
400: #ifdef KR_headers
401: integer s_wdfe(a) cilist *a;
402: #else
403: integer s_wdfe(cilist *a)
404: #endif
405: {
406: int n;
407: if(!init) f_init();
408: if(n=c_dfe(a)) return(n);
409: reading=0;
410: if(curunit->uwrt != 1 && nowwriting(curunit))
411: err(a->cierr,errno,"startwrt");
412: putn = y_putc;
413: doed = w_ed;
414: doned= w_ned;
415: dorevert = y_err;
416: donewrec = y_newrec;
417: doend = y_rev;
418: if(pars_f(fmtbuf)<0)
419: err(a->cierr,100,"startwrt");
420: fmt_bg();
421: return(0);
422: }
423: integer e_rdfe(Void)
424: {
425: (void) en_fio();
426: return(0);
427: }
428: integer e_wdfe(Void)
429: {
430: (void) en_fio();
431: return(0);
432: }
433: ./ ADD NAME=dolio.c TIME=708905794
434: #include "f2c.h"
435:
436: #ifdef __cplusplus
437: extern "C" {
438: #endif
439: #ifdef KR_headers
440: extern int (*lioproc)();
441:
442: integer do_lio(type,number,ptr,len) ftnint *number,*type; char *ptr; ftnlen len;
443: #else
444: extern int (*lioproc)(ftnint*, char*, ftnlen, ftnint);
445:
446: integer do_lio(ftnint *type, ftnint *number, char *ptr, ftnlen len)
447: #endif
448: {
449: return((*lioproc)(number,ptr,len,*type));
450: }
451: #ifdef __cplusplus
452: }
453: #endif
454: ./ ADD NAME=due.c TIME=708866794
455: #include "f2c.h"
456: #include "fio.h"
457:
458: #ifdef KR_headers
459: c_due(a) cilist *a;
460: #else
461: c_due(cilist *a)
462: #endif
463: {
464: if(!init) f_init();
465: if(a->ciunit>=MXUNIT || a->ciunit<0)
466: err(a->cierr,101,"startio");
467: recpos=sequential=formatted=0;
468: external=1;
469: curunit = &units[a->ciunit];
470: elist=a;
471: if(curunit->ufd==NULL && fk_open(DIR,UNF,a->ciunit) ) err(a->cierr,104,"due");
472: cf=curunit->ufd;
473: if(curunit->ufmt) err(a->cierr,102,"cdue")
474: if(!curunit->useek) err(a->cierr,104,"cdue")
475: if(curunit->ufd==NULL) err(a->cierr,114,"cdue")
476: (void) fseek(cf,(long)(a->cirec-1)*curunit->url,SEEK_SET);
477: curunit->uend = 0;
478: return(0);
479: }
480: #ifdef KR_headers
481: integer s_rdue(a) cilist *a;
482: #else
483: integer s_rdue(cilist *a)
484: #endif
485: {
486: int n;
487: if(n=c_due(a)) return(n);
488: reading=1;
489: if(curunit->uwrt && nowreading(curunit))
490: err(a->cierr,errno,"read start");
491: return(0);
492: }
493: #ifdef KR_headers
494: integer s_wdue(a) cilist *a;
495: #else
496: integer s_wdue(cilist *a)
497: #endif
498: {
499: int n;
500: if(n=c_due(a)) return(n);
501: reading=0;
502: if(curunit->uwrt != 1 && nowwriting(curunit))
503: err(a->cierr,errno,"write start");
504: return(0);
505: }
506: integer e_rdue(Void)
507: {
508: if(curunit->url==1 || recpos==curunit->url)
509: return(0);
510: (void) fseek(cf,(long)(curunit->url-recpos),SEEK_CUR);
511: if(ftell(cf)%curunit->url)
512: err(elist->cierr,200,"syserr");
513: return(0);
514: }
515: integer e_wdue(Void)
516: {
517: return(e_rdue());
518: }
519: ./ ADD NAME=endfile.c TIME=708893804
520: #include "f2c.h"
521: #include "fio.h"
522: #include "fcntl.h"
523: #include "rawio.h"
524: #ifndef O_RDONLY
525: #define O_RDONLY 0
526: #endif
527:
528: #ifdef KR_headers
529: extern char *strcpy();
530: #else
531: #undef abs
532: #include "stdlib.h"
533: #include "string.h"
534: #endif
535:
536:
537: #ifdef KR_headers
538: integer f_end(a) alist *a;
539: #else
540: integer f_end(alist *a)
541: #endif
542: {
543: unit *b;
544: if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
545: b = &units[a->aunit];
546: if(b->ufd==NULL) {
547: char nbuf[10];
548: (void) sprintf(nbuf,"fort.%ld",a->aunit);
549: close(creat(nbuf, 0666));
550: return(0);
551: }
552: b->uend=1;
553: return(b->useek ? t_runc(a) : 0);
554: }
555:
556: static int
557: #ifdef KR_headers
558: copy(from, len, to) char *from, *to; register long len;
559: #else
560: copy(char *from, register long len, char *to)
561: #endif
562: {
563: register int n;
564: int k, rc = 0, tmp;
565: char buf[BUFSIZ];
566:
567: if ((k = open(from, O_RDONLY)) < 0)
568: return 1;
569: if ((tmp = creat(to,0666)) < 0)
570: return 1;
571: while((n = read(k, buf, len > BUFSIZ ? BUFSIZ : (int)len)) > 0) {
572: if (write(tmp, buf, n) != n)
573: { rc = 1; break; }
574: if ((len -= n) <= 0)
575: break;
576: }
577: close(k);
578: close(tmp);
579: return n < 0 ? 1 : rc;
580: }
581:
582: int
583: #ifdef KR_headers
584: t_runc(a) alist *a;
585: #else
586: t_runc(alist *a)
587: #endif
588: {
589: char nm[16];
590: long loc, len;
591: unit *b;
592: int rc = 0;
593:
594: b = &units[a->aunit];
595: if(b->url) return(0); /*don't truncate direct files*/
596: loc=ftell(b->ufd);
597: (void) fseek(b->ufd,0L,SEEK_END);
598: len=ftell(b->ufd);
599: if (loc >= len || b->useek == 0 || b->ufnm == NULL)
600: return(0);
601: rewind(b->ufd); /* empty buffer */
602: if (!loc) {
603: if (close(creat(b->ufnm,0666)))
604: { rc = 1; goto done; }
605: if (b->uwrt)
606: b->uwrt = 1;
607: return 0;
608: }
609: (void) strcpy(nm,"tmp.FXXXXXX");
610: (void) mktemp(nm);
611: if (copy(b->ufnm, loc, nm)
612: || copy(nm, loc, b->ufnm))
613: rc = 1;
614: unlink(nm);
615: done:
616: fseek(b->ufd, loc, SEEK_SET);
617: if (rc)
618: err(a->aerr,111,"endfile");
619: return 0;
620: }
621: ./ ADD NAME=err.c TIME=708894334
622: #include "sys/types.h"
623: #ifndef MSDOS
624: #include "sys/stat.h"
625: #endif
626: #include "f2c.h"
627: #include "fio.h"
628: #include "fcntl.h"
629: #include "rawio.h"
630: #ifdef NON_UNIX_STDIO
631: #ifdef KR_headers
632: extern char *malloc();
633: #else
634: #undef abs
635: #include "stdlib.h"
636: #endif
637: #endif
638: #ifndef O_WRONLY
639: #define O_WRONLY 1
640: #endif
641:
642: /*global definitions*/
643: unit units[MXUNIT]; /*unit table*/
644: flag init; /*0 on entry, 1 after initializations*/
645: cilist *elist; /*active external io list*/
646: flag reading; /*1 if reading, 0 if writing*/
647: flag cplus,cblank;
648: char *fmtbuf;
649: flag external; /*1 if external io, 0 if internal */
650: #ifdef KR_headers
651: int (*doed)(),(*doned)();
652: int (*doend)(),(*donewrec)(),(*dorevert)();
653: int (*getn)(),(*putn)(); /*for formatted io*/
654: #else
655: int (*getn)(void),(*putn)(int); /*for formatted io*/
656: int (*doed)(struct syl*, char*, ftnlen),(*doned)(struct syl*);
657: int (*dorevert)(void),(*donewrec)(void),(*doend)(void);
658: #endif
659: flag sequential; /*1 if sequential io, 0 if direct*/
660: flag formatted; /*1 if formatted io, 0 if unformatted*/
661: FILE *cf; /*current file*/
662: unit *curunit; /*current unit*/
663: int recpos; /*place in current record*/
664: int cursor,scale;
665:
666: /*error messages*/
667: char *F_err[] =
668: {
669: "error in format", /* 100 */
670: "illegal unit number", /* 101 */
671: "formatted io not allowed", /* 102 */
672: "unformatted io not allowed", /* 103 */
673: "direct io not allowed", /* 104 */
674: "sequential io not allowed", /* 105 */
675: "can't backspace file", /* 106 */
676: "null file name", /* 107 */
677: "can't stat file", /* 108 */
678: "unit not connected", /* 109 */
679: "off end of record", /* 110 */
680: "truncation failed in endfile", /* 111 */
681: "incomprehensible list input", /* 112 */
682: "out of free space", /* 113 */
683: "unit not connected", /* 114 */
684: "read unexpected character", /* 115 */
685: "bad logical input field", /* 116 */
686: "bad variable type", /* 117 */
687: "bad namelist name", /* 118 */
688: "variable not in namelist", /* 119 */
689: "no end record", /* 120 */
690: "variable count incorrect", /* 121 */
691: "subscript for scalar variable", /* 122 */
692: "invalid array section", /* 123 */
693: "substring out of bounds", /* 124 */
694: "subscript out of bounds", /* 125 */
695: "can't read file", /* 126 */
696: "can't write file", /* 127 */
697: "'new' file exists" /* 128 */
698: };
699: #define MAXERR (sizeof(F_err)/sizeof(char *)+100)
700:
701: #ifdef KR_headers
702: canseek(f) FILE *f; /*SYSDEP*/
703: #else
704: canseek(FILE *f) /*SYSDEP*/
705: #endif
706: {
707: #ifdef MSDOS
708: return !isatty(fileno(f));
709: #else
710: struct stat x;
711:
712: if (fstat(fileno(f),&x) < 0)
713: return(0);
714: #ifdef S_IFMT
715: switch(x.st_mode & S_IFMT) {
716: case S_IFDIR:
717: case S_IFREG:
718: if(x.st_nlink > 0) /* !pipe */
719: return(1);
720: else
721: return(0);
722: case S_IFCHR:
723: if(isatty(fileno(f)))
724: return(0);
725: return(1);
726: #ifdef S_IFBLK
727: case S_IFBLK:
728: return(1);
729: #endif
730: }
731: #else
732: #ifdef S_ISDIR
733: /* POSIX version */
734: if (S_ISREG(x.st_mode) || S_ISDIR(x.st_mode)) {
735: if(x.st_nlink > 0) /* !pipe */
736: return(1);
737: else
738: return(0);
739: }
740: if (S_ISCHR(x.st_mode)) {
741: if(isatty(fileno(f)))
742: return(0);
743: return(1);
744: }
745: if (S_ISBLK(x.st_mode))
746: return(1);
747: #else
748: Help! How does fstat work on this system?
749: #endif
750: #endif
751: return(0); /* who knows what it is? */
752: #endif
753: }
754:
755: void
756: #ifdef KR_headers
757: fatal(n,s) char *s;
758: #else
759: fatal(int n, char *s)
760: #endif
761: {
762: if(n<100 && n>=0) perror(s); /*SYSDEP*/
763: else if(n >= (int)MAXERR || n < -1)
764: { fprintf(stderr,"%s: illegal error number %d\n",s,n);
765: }
766: else if(n == -1) fprintf(stderr,"%s: end of file\n",s);
767: else
768: fprintf(stderr,"%s: %s\n",s,F_err[n-100]);
769: if (curunit) {
770: fprintf(stderr,"apparent state: unit %d ",curunit-units);
771: fprintf(stderr, curunit->ufnm ? "named %s\n" : "(unnamed)\n",
772: curunit->ufnm);
773: }
774: else
775: fprintf(stderr,"apparent state: internal I/O\n");
776: if (fmtbuf)
777: fprintf(stderr,"last format: %s\n",fmtbuf);
778: fprintf(stderr,"lately %s %s %s %s",reading?"reading":"writing",
779: sequential?"sequential":"direct",formatted?"formatted":"unformatted",
780: external?"external":"internal");
781: sig_die(" IO", 1);
782: }
783: /*initialization routine*/
784: VOID
785: f_init(Void)
786: { unit *p;
787:
788: init=1;
789: p= &units[0];
790: p->ufd=stderr;
791: p->useek=canseek(stderr);
792: #ifdef COMMENTED_OUT
793: if(isatty(fileno(stderr))) {
794: extern char *malloc();
795: setbuf(stderr, malloc(BUFSIZ));
796: /* setvbuf(stderr, _IOLBF, 0, 0); */
797: } /* wastes space, but win for debugging in windows */
798: #endif
799: #ifdef NON_UNIX_STDIO
800: setbuf(stderr, malloc(BUFSIZ));
801: #else
802: stderr->_flag &= ~_IONBF;
803: #endif
804: p->ufmt=1;
805: p->uwrt=1;
806: p = &units[5];
807: p->ufd=stdin;
808: p->useek=canseek(stdin);
809: p->ufmt=1;
810: p->uwrt=0;
811: p= &units[6];
812: p->ufd=stdout;
813: p->useek=canseek(stdout);
814: /* IOLBUF and setvbuf only in system 5+ */
815: #ifdef COMMENTED_OUT
816: if(isatty(fileno(stdout))) {
817: extern char _sobuf[];
818: setbuf(stdout, _sobuf);
819: /* setvbuf(stdout, _IOLBF, 0, 0); /* the buf arg in setvbuf? */
820: p->useek = 1; /* only within a record no bigger than BUFSIZ */
821: }
822: #endif
823: p->ufmt=1;
824: p->uwrt=1;
825: }
826: #ifdef KR_headers
827: nowreading(x) unit *x;
828: #else
829: nowreading(unit *x)
830: #endif
831: {
832: long loc;
833: extern char *r_mode[];
834: if (!x->ufnm)
835: goto cantread;
836: loc=ftell(x->ufd);
837: if(freopen(x->ufnm,r_mode[x->ufmt],x->ufd) == NULL) {
838: cantread:
839: errno = 126;
840: return(1);
841: }
842: x->uwrt=0;
843: (void) fseek(x->ufd,loc,SEEK_SET);
844: return(0);
845: }
846: #ifdef KR_headers
847: nowwriting(x) unit *x;
848: #else
849: nowwriting(unit *x)
850: #endif
851: {
852: long loc;
853: int k;
854: extern char *w_mode[];
855:
856: if (!x->ufnm)
857: goto cantwrite;
858: if (x->uwrt == 3) { /* just did write, rewind */
859: if (close(creat(x->ufnm,0666)))
860: goto cantwrite;
861: }
862: else {
863: loc=ftell(x->ufd);
864: if (fclose(x->ufd) < 0
865: || (k = x->uwrt == 2 ? creat(x->ufnm,0666)
866: : open(x->ufnm,O_WRONLY)) < 0
867: || (cf = x->ufd = fdopen(k,w_mode[x->ufmt])) == NULL) {
868: x->ufd = NULL;
869: cantwrite:
870: errno = 127;
871: return(1);
872: }
873: (void) fseek(x->ufd,loc,SEEK_SET);
874: }
875: x->uwrt = 1;
876: return(0);
877: }
878: ./ ADD NAME=f2c.h TIME=708964532
879: /* f2c.h -- Standard Fortran to C header file */
880:
881: /** barf [ba:rf] 2. "He suggested using FORTRAN, and everybody barfed."
882:
883: - From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
884:
885: #ifndef F2C_INCLUDE
886: #define F2C_INCLUDE
887:
888: typedef long int integer;
889: typedef char *address;
890: typedef short int shortint;
891: typedef float real;
892: typedef double doublereal;
893: typedef struct { real r, i; } complex;
894: typedef struct { doublereal r, i; } doublecomplex;
895: typedef long int logical;
896: typedef short int shortlogical;
897:
898: #define TRUE_ (1)
899: #define FALSE_ (0)
900:
901: /* Extern is for use with -E */
902: #ifndef Extern
903: #define Extern extern
904: #endif
905:
906: /* I/O stuff */
907:
908: #ifdef f2c_i2
909: /* for -i2 */
910: typedef short flag;
911: typedef short ftnlen;
912: typedef short ftnint;
913: #else
914: typedef long flag;
915: typedef long ftnlen;
916: typedef long ftnint;
917: #endif
918:
919: /*external read, write*/
920: typedef struct
921: { flag cierr;
922: ftnint ciunit;
923: flag ciend;
924: char *cifmt;
925: ftnint cirec;
926: } cilist;
927:
928: /*internal read, write*/
929: typedef struct
930: { flag icierr;
931: char *iciunit;
932: flag iciend;
933: char *icifmt;
934: ftnint icirlen;
935: ftnint icirnum;
936: } icilist;
937:
938: /*open*/
939: typedef struct
940: { flag oerr;
941: ftnint ounit;
942: char *ofnm;
943: ftnlen ofnmlen;
944: char *osta;
945: char *oacc;
946: char *ofm;
947: ftnint orl;
948: char *oblnk;
949: } olist;
950:
951: /*close*/
952: typedef struct
953: { flag cerr;
954: ftnint cunit;
955: char *csta;
956: } cllist;
957:
958: /*rewind, backspace, endfile*/
959: typedef struct
960: { flag aerr;
961: ftnint aunit;
962: } alist;
963:
964: /* inquire */
965: typedef struct
966: { flag inerr;
967: ftnint inunit;
968: char *infile;
969: ftnlen infilen;
970: ftnint *inex; /*parameters in standard's order*/
971: ftnint *inopen;
972: ftnint *innum;
973: ftnint *innamed;
974: char *inname;
975: ftnlen innamlen;
976: char *inacc;
977: ftnlen inacclen;
978: char *inseq;
979: ftnlen inseqlen;
980: char *indir;
981: ftnlen indirlen;
982: char *infmt;
983: ftnlen infmtlen;
984: char *inform;
985: ftnint informlen;
986: char *inunf;
987: ftnlen inunflen;
988: ftnint *inrecl;
989: ftnint *innrec;
990: char *inblank;
991: ftnlen inblanklen;
992: } inlist;
993:
994: #define VOID void
995:
996: union Multitype { /* for multiple entry points */
997: shortint h;
998: integer i;
999: real r;
1000: doublereal d;
1001: complex c;
1002: doublecomplex z;
1003: };
1004:
1005: typedef union Multitype Multitype;
1006:
1007: typedef long Long; /* No longer used; formerly in Namelist */
1008:
1009: struct Vardesc { /* for Namelist */
1010: char *name;
1011: char *addr;
1012: ftnlen *dims;
1013: int type;
1014: };
1015: typedef struct Vardesc Vardesc;
1016:
1017: struct Namelist {
1018: char *name;
1019: Vardesc **vars;
1020: int nvars;
1021: };
1022: typedef struct Namelist Namelist;
1023:
1024: #define abs(x) ((x) >= 0 ? (x) : -(x))
1025: #define dabs(x) (doublereal)abs(x)
1026: #define min(a,b) ((a) <= (b) ? (a) : (b))
1027: #define max(a,b) ((a) >= (b) ? (a) : (b))
1028: #define dmin(a,b) (doublereal)min(a,b)
1029: #define dmax(a,b) (doublereal)max(a,b)
1030:
1031: /* procedure parameter types for -A and -C++ */
1032:
1033: #define F2C_proc_par_types 1
1034: #ifdef __cplusplus
1035: typedef int /* Unknown procedure type */ (*U_fp)(...);
1036: typedef shortint (*J_fp)(...);
1037: typedef integer (*I_fp)(...);
1038: typedef real (*R_fp)(...);
1039: typedef doublereal (*D_fp)(...), (*E_fp)(...);
1040: typedef /* Complex */ VOID (*C_fp)(...);
1041: typedef /* Double Complex */ VOID (*Z_fp)(...);
1042: typedef logical (*L_fp)(...);
1043: typedef shortlogical (*K_fp)(...);
1044: typedef /* Character */ VOID (*H_fp)(...);
1045: typedef /* Subroutine */ int (*S_fp)(...);
1046: #else
1047: #ifndef __LCC__
1048: typedef int /* Unknown procedure type */ (*U_fp)();
1049: typedef shortint (*J_fp)();
1050: typedef integer (*I_fp)();
1051: typedef real (*R_fp)();
1052: typedef doublereal (*D_fp)(), (*E_fp)();
1053: typedef /* Complex */ VOID (*C_fp)();
1054: typedef /* Double Complex */ VOID (*Z_fp)();
1055: typedef logical (*L_fp)();
1056: typedef shortlogical (*K_fp)();
1057: typedef /* Character */ VOID (*H_fp)();
1058: typedef /* Subroutine */ int (*S_fp)();
1059: #endif
1060: #endif
1061: /* E_fp is for real functions when -R is not specified */
1062: typedef VOID C_f; /* complex function */
1063: typedef VOID H_f; /* character function */
1064: typedef VOID Z_f; /* double complex function */
1065: typedef doublereal E_f; /* real function with -R not specified */
1066:
1067: /* undef any lower-case symbols that your C compiler predefines, e.g.: */
1068:
1069: #ifndef Skip_f2c_Undefs
1070: #undef mips
1071: #undef sgi
1072: #undef unix
1073: #endif
1074: #endif
1075:
1076: #ifdef __cplusplus
1077: extern "C" {
1078: extern void abort_(void);
1079: extern double c_abs(complex *);
1080: extern void c_cos(complex *, complex *);
1081: extern void c_div(complex *, complex *, complex *);
1082: extern void c_exp(complex *, complex *);
1083: extern void c_log(complex *, complex *);
1084: extern void c_sin(complex *, complex *);
1085: extern void c_sqrt(complex *, complex *);
1086: extern double d_abs(double *);
1087: extern double d_acos(double *);
1088: extern double d_asin(double *);
1089: extern double d_atan(double *);
1090: extern double d_atn2(double *, double *);
1091: extern void d_cnjg(doublecomplex *, doublecomplex *);
1092: extern double d_cos(double *);
1093: extern double d_cosh(double *);
1094: extern double d_dim(double *, double *);
1095: extern double d_exp(double *);
1096: extern double d_imag(doublecomplex *);
1097: extern double d_int(double *);
1098: extern double d_lg10(double *);
1099: extern double d_log(double *);
1100: extern double d_mod(double *, double *);
1101: extern double d_nint(double *);
1102: extern double d_prod(float *, float *);
1103: extern double d_sign(double *, double *);
1104: extern double d_sin(double *);
1105: extern double d_sinh(double *);
1106: extern double d_sqrt(double *);
1107: extern double d_tan(double *);
1108: extern double d_tanh(double *);
1109: extern double derf_(double *);
1110: extern double derfc_(double *);
1111: extern void ef1asc_(long int *, long int *, long int *, long int *);
1112: extern long int ef1cmc_(long int *, long int *, long int *, long int *);
1113: extern double erf(double);
1114: extern double erf_(float *);
1115: extern double erfc(double);
1116: extern double erfc_(float *);
1117: extern void getarg_(long int *, char *, long int);
1118: extern void getenv_(char *, char *, long int, long int);
1119: extern int getpid(void);
1120: extern short h_abs(short *);
1121: extern short h_dim(short *, short *);
1122: extern short h_dnnt(double *);
1123: extern short h_indx(char *, char *, long int, long int);
1124: extern short h_len(char *, long int);
1125: extern short h_mod(short *, short *);
1126: extern short h_nint(float *);
1127: extern short h_sign(short *, short *);
1128: extern short hl_ge(char *, char *, long int, long int);
1129: extern short hl_gt(char *, char *, long int, long int);
1130: extern short hl_le(char *, char *, long int, long int);
1131: extern short hl_lt(char *, char *, long int, long int);
1132: extern long int i_abs(long int *);
1133: extern long int i_dim(long int *, long int *);
1134: extern long int i_dnnt(double *);
1135: extern long int i_indx(char *, char *, long int, long int);
1136: extern long int i_len(char *, long int);
1137: extern long int i_mod(long int *, long int *);
1138: extern long int i_nint(float *);
1139: extern long int i_sign(long int *, long int *);
1140: extern long int iargc_(void);
1141: extern long int l_ge(char *, char *, long int, long int);
1142: extern long int l_gt(char *, char *, long int, long int);
1143: extern long int l_le(char *, char *, long int, long int);
1144: extern long int l_lt(char *, char *, long int, long int);
1145: extern int main(int, char **);
1146: extern int pause(void);
1147: extern void pow_ci(complex *, complex *, long int *);
1148: extern double pow_dd(double *, double *);
1149: extern double pow_di(double *, long int *);
1150: extern short pow_hh(short *, short *);
1151: extern long int pow_ii(long int *, long int *);
1152: extern double pow_ri(float *, long int *);
1153: extern void pow_zi(doublecomplex *, doublecomplex *, long int *);
1154: extern void pow_zz(doublecomplex *, doublecomplex *, doublecomplex *);
1155: extern double r_abs(float *);
1156: extern double r_acos(float *);
1157: extern double r_asin(float *);
1158: extern double r_atan(float *);
1159: extern double r_atn2(float *, float *);
1160: extern void r_cnjg(complex *, complex *);
1161: extern double r_cos(float *);
1162: extern double r_cosh(float *);
1163: extern double r_dim(float *, float *);
1164: extern double r_exp(float *);
1165: extern double r_imag(complex *);
1166: extern double r_int(float *);
1167: extern double r_lg10(float *);
1168: extern double r_log(float *);
1169: extern double r_mod(float *, float *);
1170: extern double r_nint(float *);
1171: extern double r_sign(float *, float *);
1172: extern double r_sin(float *);
1173: extern double r_sinh(float *);
1174: extern double r_sqrt(float *);
1175: extern double r_tan(float *);
1176: extern double r_tanh(float *);
1177: extern void s_cat(char *, char **, long int *, long int *, long int);
1178: extern long int s_cmp(char *, char *, long int, long int);
1179: extern void s_copy(char *, char *, long int, long int);
1180: extern void s_paus(char *, long int);
1181: extern void s_rnge(char *, long int, char *, long int);
1182: extern void s_stop(char *, long int);
1183: extern void sig_die(char *, int);
1184: extern long int signal_(long int *, void *);
1185: extern int system_(char *, long int);
1186: extern double z_abs(doublecomplex *);
1187: extern void z_cos(doublecomplex *, doublecomplex *);
1188: extern void z_div(doublecomplex *, doublecomplex *, doublecomplex *);
1189: extern void z_exp(doublecomplex *, doublecomplex *);
1190: extern void z_log(doublecomplex *, doublecomplex *);
1191: extern void z_sin(doublecomplex *, doublecomplex *);
1192: extern void z_sqrt(doublecomplex *, doublecomplex *);
1193: }
1194: #endif
1195: ./ ADD NAME=fio.h TIME=708907413
1196: #include "stdio.h"
1197: #ifndef NULL
1198: /* ANSI C */
1199: #include "stddef.h"
1200: #endif
1201:
1202: #ifndef SEEK_SET
1203: #define SEEK_SET 0
1204: #define SEEK_CUR 1
1205: #define SEEK_END 2
1206: #endif
1207:
1208: #ifdef MSDOS
1209: #ifndef NON_UNIX_STDIO
1210: #define NON_UNIX_STDIO
1211: #endif
1212: #endif
1213:
1214: #ifdef UIOLEN_int
1215: typedef int uiolen;
1216: #else
1217: typedef long uiolen;
1218: #endif
1219:
1220: /*units*/
1221: typedef struct
1222: { FILE *ufd; /*0=unconnected*/
1223: char *ufnm;
1224: #ifndef MSDOS
1225: long uinode;
1226: int udev;
1227: #endif
1228: int url; /*0=sequential*/
1229: flag useek; /*true=can backspace, use dir, ...*/
1230: flag ufmt;
1231: flag uprnt;
1232: flag ublnk;
1233: flag uend;
1234: flag uwrt; /*last io was write*/
1235: flag uscrtch;
1236: } unit;
1237:
1238: extern int errno;
1239: extern flag init;
1240: extern cilist *elist; /*active external io list*/
1241: extern flag reading,external,sequential,formatted;
1242: #ifdef KR_headers
1243: #define Void /*void*/
1244: extern int (*getn)(),(*putn)(); /*for formatted io*/
1245: extern long inode();
1246: extern VOID sig_die();
1247: extern int (*donewrec)(), t_putc(), x_wSL();
1248: extern int c_sfe();
1249: #else
1250: #define Void void
1251: #ifdef __cplusplus
1252: extern "C" {
1253: #endif
1254: extern int (*getn)(void),(*putn)(int); /*for formatted io*/
1255: extern long inode(char*,int*);
1256: extern void sig_die(char*,int);
1257: extern void fatal(int,char*);
1258: extern int t_runc(alist*);
1259: extern int nowreading(unit*), nowwriting(unit*);
1260: extern int fk_open(int,int,ftnint);
1261: extern int en_fio(void);
1262: extern void f_init(void);
1263: extern int (*donewrec)(void), t_putc(int), x_wSL(void);
1264: extern void b_char(char*,char*,ftnlen), g_char(char*,ftnlen,char*);
1265: extern int c_sfe(cilist*), z_rnew(void);
1266: extern int isatty(int);
1267: #ifdef __cplusplus
1268: }
1269: #endif
1270: #endif
1271: extern FILE *cf; /*current file*/
1272: extern unit *curunit; /*current unit*/
1273: extern unit units[];
1274: #define err(f,m,s) {if(f) errno= m; else fatal(m,s); return(m);}
1275:
1276: /*Table sizes*/
1277: #define MXUNIT 100
1278:
1279: extern int recpos; /*position in current record*/
1280: extern int cursor; /* offset to move to */
1281: extern int hiwater; /* so TL doesn't confuse us */
1282:
1283: #define WRITE 1
1284: #define READ 2
1285: #define SEQ 3
1286: #define DIR 4
1287: #define FMT 5
1288: #define UNF 6
1289: #define EXT 7
1290: #define INT 8
1291:
1292: #define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)
1293: #ifdef __cplusplus
1294: extern "C" {
1295: extern long int f_back(alist *);
1296: extern long int f_clos(cllist *);
1297: extern void f_exit(void);
1298: extern void flush_(void);
1299: extern int y_rsk(void);
1300: extern int y_getc(void);
1301: extern int y_putc(int);
1302: extern int y_rev(void);
1303: extern int y_err(void);
1304: extern int y_newrec(void);
1305: extern int c_dfe(cilist *);
1306: extern long int s_rdfe(cilist *);
1307: extern long int s_wdfe(cilist *);
1308: extern long int e_rdfe(void);
1309: extern long int e_wdfe(void);
1310: extern long int do_lio(long int *, long int *, char *, long int);
1311: extern int c_due(cilist *);
1312: extern long int s_rdue(cilist *);
1313: extern long int s_wdue(cilist *);
1314: extern long int e_rdue(void);
1315: extern long int e_wdue(void);
1316: extern long int f_end(alist *);
1317: extern int canseek(struct _iobuf *);
1318: extern char *ap_end(char *);
1319: extern int op_gen(int, int, int, int);
1320: extern char *gt_num(char *, int *);
1321: extern char *f_s(char *, int);
1322: extern int ne_d(char *, char **);
1323: extern int e_d(char *, char **);
1324: extern char *i_tem(char *);
1325: extern char *f_list(char *);
1326: extern int pars_f(char *);
1327: extern int type_f(int);
1328: extern long int do_fio(long int *, char *, long int);
1329: extern void fmt_bg(void);
1330: extern char *icvt(long int, int *, int *, int);
1331: extern int z_getc(void);
1332: extern int z_putc(int);
1333: extern int c_si(icilist *);
1334: extern int y_ierr(void);
1335: extern long int s_rsfi(icilist *);
1336: extern int z_wnew(void);
1337: extern long int s_wsfi(icilist *);
1338: extern long int e_rsfi(void);
1339: extern long int e_wsfi(void);
1340: extern void c_liw(icilist *);
1341: extern int s_wsni(icilist *);
1342: extern long int s_wsli(icilist *);
1343: extern long int e_wsli(void);
1344: extern long int f_inqu(inlist *);
1345: extern int t_getc(void);
1346: extern long int e_rsle(void);
1347: extern int l_R(int);
1348: extern int l_C(void);
1349: extern int l_L(void);
1350: extern int l_CHAR(void);
1351: extern int c_le(cilist *);
1352: extern int l_read(long int *, char *, long int, long int);
1353: extern long int s_rsle(cilist *);
1354: extern int l_write(long int *, char *, long int, long int);
1355: extern char *mktemp(char *);
1356: extern int isdev(char *);
1357: extern long int f_open(olist *);
1358: extern long int f_rew(alist *);
1359: extern int xrd_SL(void);
1360: extern int x_getc(void);
1361: extern int x_endp(void);
1362: extern int x_rev(void);
1363: extern long int s_rsfe(cilist *);
1364: extern int i_getc(void);
1365: extern int i_ungetc(int, struct _iobuf *);
1366: extern long int s_rsli(icilist *);
1367: extern long int e_rsli(void);
1368: extern int s_rsni(icilist *);
1369: extern int x_rsne(cilist *);
1370: extern long int s_rsne(cilist *);
1371: extern long int e_rsfe(void);
1372: extern long int e_wsfe(void);
1373: extern int c_sue(cilist *);
1374: extern long int s_rsue(cilist *);
1375: extern long int s_wsue(cilist *);
1376: extern long int e_wsue(void);
1377: extern long int e_rsue(void);
1378: extern int do_us(long int *, char *, long int);
1379: extern long int do_ud(long int *, char *, long int);
1380: extern long int do_uio(long int *, char *, long int);
1381: extern long int inode(char *, int *);
1382: extern void mvgbt(int, int, char *, char *);
1383: extern int mv_cur(void);
1384: extern int x_putc(int);
1385: extern int xw_end(void);
1386: extern int xw_rev(void);
1387: extern long int s_wsfe(cilist *);
1388: extern long int s_wsle(cilist *);
1389: extern long int e_wsle(void);
1390: extern long int s_wsne(cilist *);
1391: extern void x_wsne(cilist *);
1392: }
1393: #endif
1394: ./ ADD NAME=fmt.c TIME=708822446
1395: #include "f2c.h"
1396: #include "fio.h"
1397: #include "fmt.h"
1398: #define skip(s) while(*s==' ') s++
1399: #ifdef interdata
1400: #define SYLMX 300
1401: #endif
1402: #ifdef pdp11
1403: #define SYLMX 300
1404: #endif
1405: #ifdef vax
1406: #define SYLMX 300
1407: #endif
1408: #ifndef SYLMX
1409: #define SYLMX 300
1410: #endif
1411: #define GLITCH '\2'
1412: /* special quote character for stu */
1413: extern int cursor,scale;
1414: extern flag cblank,cplus; /*blanks in I and compulsory plus*/
1415: struct syl syl[SYLMX];
1416: int parenlvl,pc,revloc;
1417:
1418: #ifdef KR_headers
1419: char *ap_end(s) char *s;
1420: #else
1421: char *ap_end(char *s)
1422: #endif
1423: { char quote;
1424: quote= *s++;
1425: for(;*s;s++)
1426: { if(*s!=quote) continue;
1427: if(*++s!=quote) return(s);
1428: }
1429: if(elist->cierr) {
1430: errno = 100;
1431: return(NULL);
1432: }
1433: fatal(100, "bad string");
1434: /*NOTREACHED*/ return 0;
1435: }
1436: #ifdef KR_headers
1437: op_gen(a,b,c,d)
1438: #else
1439: op_gen(int a, int b, int c, int d)
1440: #endif
1441: { struct syl *p= &syl[pc];
1442: if(pc>=SYLMX)
1443: { fprintf(stderr,"format too complicated:\n");
1444: sig_die(fmtbuf, 1);
1445: }
1446: p->op=a;
1447: p->p1=b;
1448: p->p2=c;
1449: p->p3=d;
1450: return(pc++);
1451: }
1452: #ifdef KR_headers
1453: char *f_list();
1454: char *gt_num(s,n) char *s; int *n;
1455: #else
1456: char *f_list(char*);
1457: char *gt_num(char *s, int *n)
1458: #endif
1459: { int m=0,cnt=0;
1460: char c;
1461: for(c= *s;;c = *s)
1462: { if(c==' ')
1463: { s++;
1464: continue;
1465: }
1466: if(c>'9' || c<'0') break;
1467: m=10*m+c-'0';
1468: cnt++;
1469: s++;
1470: }
1471: if(cnt==0) *n=1;
1472: else *n=m;
1473: return(s);
1474: }
1475: #ifdef KR_headers
1476: char *f_s(s,curloc) char *s;
1477: #else
1478: char *f_s(char *s, int curloc)
1479: #endif
1480: {
1481: skip(s);
1482: if(*s++!='(')
1483: {
1484: return(NULL);
1485: }
1486: if(parenlvl++ ==1) revloc=curloc;
1487: if(op_gen(RET,curloc,0,0)<0 ||
1488: (s=f_list(s))==NULL)
1489: {
1490: return(NULL);
1491: }
1492: skip(s);
1493: return(s);
1494: }
1495: #ifdef KR_headers
1496: ne_d(s,p) char *s,**p;
1497: #else
1498: ne_d(char *s, char **p)
1499: #endif
1500: { int n,x,sign=0;
1501: struct syl *sp;
1502: switch(*s)
1503: {
1504: default:
1505: return(0);
1506: case ':': (void) op_gen(COLON,0,0,0); break;
1507: case '$':
1508: (void) op_gen(NONL, 0, 0, 0); break;
1509: case 'B':
1510: case 'b':
1511: if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
1512: else (void) op_gen(BN,0,0,0);
1513: break;
1514: case 'S':
1515: case 's':
1516: if(*(s+1)=='s' || *(s+1) == 'S')
1517: { x=SS;
1518: s++;
1519: }
1520: else if(*(s+1)=='p' || *(s+1) == 'P')
1521: { x=SP;
1522: s++;
1523: }
1524: else x=S;
1525: (void) op_gen(x,0,0,0);
1526: break;
1527: case '/': (void) op_gen(SLASH,0,0,0); break;
1528: case '-': sign=1;
1529: case '+': s++; /*OUTRAGEOUS CODING TRICK*/
1530: case '0': case '1': case '2': case '3': case '4':
1531: case '5': case '6': case '7': case '8': case '9':
1532: s=gt_num(s,&n);
1533: switch(*s)
1534: {
1535: default:
1536: return(0);
1537: case 'P':
1538: case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
1539: case 'X':
1540: case 'x': (void) op_gen(X,n,0,0); break;
1541: case 'H':
1542: case 'h':
1543: sp = &syl[op_gen(H,n,0,0)];
1544: *(char **)&sp->p2 = s + 1;
1545: s+=n;
1546: break;
1547: }
1548: break;
1549: case GLITCH:
1550: case '"':
1551: case '\'':
1552: sp = &syl[op_gen(APOS,0,0,0)];
1553: *(char **)&sp->p2 = s;
1554: if((*p = ap_end(s)) == NULL)
1555: return(0);
1556: return(1);
1557: case 'T':
1558: case 't':
1559: if(*(s+1)=='l' || *(s+1) == 'L')
1560: { x=TL;
1561: s++;
1562: }
1563: else if(*(s+1)=='r'|| *(s+1) == 'R')
1564: { x=TR;
1565: s++;
1566: }
1567: else x=T;
1568: s=gt_num(s+1,&n);
1569: s--;
1570: (void) op_gen(x,n,0,0);
1571: break;
1572: case 'X':
1573: case 'x': (void) op_gen(X,1,0,0); break;
1574: case 'P':
1575: case 'p': (void) op_gen(P,1,0,0); break;
1576: }
1577: s++;
1578: *p=s;
1579: return(1);
1580: }
1581: #ifdef KR_headers
1582: e_d(s,p) char *s,**p;
1583: #else
1584: e_d(char *s, char **p)
1585: #endif
1586: { int n,w,d,e,found=0,x=0;
1587: char *sv=s;
1588: s=gt_num(s,&n);
1589: (void) op_gen(STACK,n,0,0);
1590: switch(*s++)
1591: {
1592: default: break;
1593: case 'E':
1594: case 'e': x=1;
1595: case 'G':
1596: case 'g':
1597: found=1;
1598: s=gt_num(s,&w);
1599: if(w==0) break;
1600: if(*s=='.')
1601: { s++;
1602: s=gt_num(s,&d);
1603: }
1604: else d=0;
1605: if(*s!='E' && *s != 'e')
1606: (void) op_gen(x==1?E:G,w,d,0); /* default is Ew.dE2 */
1607: else
1608: { s++;
1609: s=gt_num(s,&e);
1610: (void) op_gen(x==1?EE:GE,w,d,e);
1611: }
1612: break;
1613: case 'O':
1614: case 'o':
1615: found = 1;
1616: s = gt_num(s, &w);
1617: if(w==0) break;
1618: (void) op_gen(O, w, 0, 0);
1619: break;
1620: case 'L':
1621: case 'l':
1622: found=1;
1623: s=gt_num(s,&w);
1624: if(w==0) break;
1625: (void) op_gen(L,w,0,0);
1626: break;
1627: case 'A':
1628: case 'a':
1629: found=1;
1630: skip(s);
1631: if(*s>='0' && *s<='9')
1632: { s=gt_num(s,&w);
1633: if(w==0) break;
1634: (void) op_gen(AW,w,0,0);
1635: break;
1636: }
1637: (void) op_gen(A,0,0,0);
1638: break;
1639: case 'F':
1640: case 'f':
1641: found=1;
1642: s=gt_num(s,&w);
1643: if(w==0) break;
1644: if(*s=='.')
1645: { s++;
1646: s=gt_num(s,&d);
1647: }
1648: else d=0;
1649: (void) op_gen(F,w,d,0);
1650: break;
1651: case 'D':
1652: case 'd':
1653: found=1;
1654: s=gt_num(s,&w);
1655: if(w==0) break;
1656: if(*s=='.')
1657: { s++;
1658: s=gt_num(s,&d);
1659: }
1660: else d=0;
1661: (void) op_gen(D,w,d,0);
1662: break;
1663: case 'I':
1664: case 'i':
1665: found=1;
1666: s=gt_num(s,&w);
1667: if(w==0) break;
1668: if(*s!='.')
1669: { (void) op_gen(I,w,0,0);
1670: break;
1671: }
1672: s++;
1673: s=gt_num(s,&d);
1674: (void) op_gen(IM,w,d,0);
1675: break;
1676: }
1677: if(found==0)
1678: { pc--; /*unSTACK*/
1679: *p=sv;
1680: return(0);
1681: }
1682: *p=s;
1683: return(1);
1684: }
1685: #ifdef KR_headers
1686: char *i_tem(s) char *s;
1687: #else
1688: char *i_tem(char *s)
1689: #endif
1690: { char *t;
1691: int n,curloc;
1692: if(*s==')') return(s);
1693: if(ne_d(s,&t)) return(t);
1694: if(e_d(s,&t)) return(t);
1695: s=gt_num(s,&n);
1696: if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
1697: return(f_s(s,curloc));
1698: }
1699: #ifdef KR_headers
1700: char *f_list(s) char *s;
1701: #else
1702: char *f_list(char *s)
1703: #endif
1704: {
1705: for(;*s!=0;)
1706: { skip(s);
1707: if((s=i_tem(s))==NULL) return(NULL);
1708: skip(s);
1709: if(*s==',') s++;
1710: else if(*s==')')
1711: { if(--parenlvl==0)
1712: {
1713: (void) op_gen(REVERT,revloc,0,0);
1714: return(++s);
1715: }
1716: (void) op_gen(GOTO,0,0,0);
1717: return(++s);
1718: }
1719: }
1720: return(NULL);
1721: }
1722:
1723: #ifdef KR_headers
1724: pars_f(s) char *s;
1725: #else
1726: pars_f(char *s)
1727: #endif
1728: {
1729: parenlvl=revloc=pc=0;
1730: if(f_s(s,0) == NULL)
1731: {
1732: return(-1);
1733: }
1734: return(0);
1735: }
1736: #define STKSZ 10
1737: int cnt[STKSZ],ret[STKSZ],cp,rp;
1738: flag workdone, nonl;
1739:
1740: #ifdef KR_headers
1741: type_f(n)
1742: #else
1743: type_f(int n)
1744: #endif
1745: {
1746: switch(n)
1747: {
1748: default:
1749: return(n);
1750: case RET:
1751: return(RET);
1752: case REVERT: return(REVERT);
1753: case GOTO: return(GOTO);
1754: case STACK: return(STACK);
1755: case X:
1756: case SLASH:
1757: case APOS: case H:
1758: case T: case TL: case TR:
1759: return(NED);
1760: case F:
1761: case I:
1762: case IM:
1763: case A: case AW:
1764: case O:
1765: case L:
1766: case E: case EE: case D:
1767: case G: case GE:
1768: return(ED);
1769: }
1770: }
1771: #ifdef KR_headers
1772: integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
1773: #else
1774: integer do_fio(ftnint *number, char *ptr, ftnlen len)
1775: #endif
1776: { struct syl *p;
1777: int n,i;
1778: for(i=0;i<*number;i++,ptr+=len)
1779: {
1780: loop: switch(type_f((p= &syl[pc])->op))
1781: {
1782: default:
1783: fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
1784: p->op,fmtbuf);
1785: err(elist->cierr,100,"do_fio");
1786: case NED:
1787: if((*doned)(p))
1788: { pc++;
1789: goto loop;
1790: }
1791: pc++;
1792: continue;
1793: case ED:
1794: if(cnt[cp]<=0)
1795: { cp--;
1796: pc++;
1797: goto loop;
1798: }
1799: if(ptr==NULL)
1800: return((*doend)());
1801: cnt[cp]--;
1802: workdone=1;
1803: if((n=(*doed)(p,ptr,len))>0) err(elist->cierr,errno,"fmt");
1804: if(n<0) err(elist->ciend,(EOF),"fmt");
1805: continue;
1806: case STACK:
1807: cnt[++cp]=p->p1;
1808: pc++;
1809: goto loop;
1810: case RET:
1811: ret[++rp]=p->p1;
1812: pc++;
1813: goto loop;
1814: case GOTO:
1815: if(--cnt[cp]<=0)
1816: { cp--;
1817: rp--;
1818: pc++;
1819: goto loop;
1820: }
1821: pc=1+ret[rp--];
1822: goto loop;
1823: case REVERT:
1824: rp=cp=0;
1825: pc = p->p1;
1826: if(ptr==NULL)
1827: return((*doend)());
1828: if(!workdone) return(0);
1829: if((n=(*dorevert)()) != 0) return(n);
1830: goto loop;
1831: case COLON:
1832: if(ptr==NULL)
1833: return((*doend)());
1834: pc++;
1835: goto loop;
1836: case NONL:
1837: nonl = 1;
1838: pc++;
1839: goto loop;
1840: case S:
1841: case SS:
1842: cplus=0;
1843: pc++;
1844: goto loop;
1845: case SP:
1846: cplus = 1;
1847: pc++;
1848: goto loop;
1849: case P: scale=p->p1;
1850: pc++;
1851: goto loop;
1852: case BN:
1853: cblank=0;
1854: pc++;
1855: goto loop;
1856: case BZ:
1857: cblank=1;
1858: pc++;
1859: goto loop;
1860: }
1861: }
1862: return(0);
1863: }
1864: en_fio(Void)
1865: { ftnint one=1;
1866: return(do_fio(&one,(char *)NULL,(ftnint)0));
1867: }
1868: VOID
1869: fmt_bg(Void)
1870: {
1871: workdone=cp=rp=pc=cursor=0;
1872: cnt[0]=ret[0]=0;
1873: }
1874: ./ ADD NAME=fmt.h TIME=708906700
1875: struct syl
1876: { int op,p1,p2,p3;
1877: };
1878: #define RET 1
1879: #define REVERT 2
1880: #define GOTO 3
1881: #define X 4
1882: #define SLASH 5
1883: #define STACK 6
1884: #define I 7
1885: #define ED 8
1886: #define NED 9
1887: #define IM 10
1888: #define APOS 11
1889: #define H 12
1890: #define TL 13
1891: #define TR 14
1892: #define T 15
1893: #define COLON 16
1894: #define S 17
1895: #define SP 18
1896: #define SS 19
1897: #define P 20
1898: #define BN 21
1899: #define BZ 22
1900: #define F 23
1901: #define E 24
1902: #define EE 25
1903: #define D 26
1904: #define G 27
1905: #define GE 28
1906: #define L 29
1907: #define A 30
1908: #define AW 31
1909: #define O 32
1910: #define NONL 33
1911: extern struct syl syl[];
1912: extern int pc,parenlvl,revloc;
1913: typedef union
1914: { real pf;
1915: doublereal pd;
1916: } ufloat;
1917: typedef union
1918: { short is;
1919: char ic;
1920: long il;
1921: } Uint;
1922: #ifdef KR_headers
1923: extern int (*doed)(),(*doned)();
1924: extern int (*dorevert)(), (*doend)();
1925: extern int rd_ed(),rd_ned();
1926: extern int w_ed(),w_ned();
1927: #else
1928: #ifdef __cplusplus
1929: extern "C" {
1930: #endif
1931: extern int (*doed)(struct syl*, char*, ftnlen),(*doned)(struct syl*);
1932: extern int (*dorevert)(void), (*doend)(void);
1933: extern void fmt_bg(void);
1934: extern int pars_f(char*);
1935: extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*);
1936: extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*);
1937: extern int wrt_E(ufloat*, int, int, int, ftnlen);
1938: extern int wrt_F(ufloat*, int, int, ftnlen);
1939: extern int wrt_L(Uint*, int, ftnlen);
1940: #ifdef __cplusplus
1941: }
1942: #endif
1943: #endif
1944: extern flag cblank,cplus,workdone, nonl;
1945: extern char *fmtbuf;
1946: extern int scale;
1947: #define GET(x) if((x=(*getn)())<0) return(x)
1948: #define VAL(x) (x!='\n'?x:' ')
1949: #define PUT(x) (*putn)(x)
1950: extern int cursor;
1951: ./ ADD NAME=fmtlib.c TIME=708905846
1952: /* @(#)fmtlib.c 1.2 */
1953: #define MAXINTLENGTH 23
1954: #ifdef __cplusplus
1955: extern "C" {
1956: #endif
1957: #ifdef KR_headers
1958: char *icvt(value,ndigit,sign, base) long value; int *ndigit,*sign;
1959: register int base;
1960: #else
1961: char *icvt(long value, int *ndigit, int *sign, int base)
1962: #endif
1963: { static char buf[MAXINTLENGTH+1];
1964: register int i;
1965: if(value>0) *sign=0;
1966: else if(value<0)
1967: { value = -value;
1968: *sign= 1;
1969: }
1970: else
1971: { *sign=0;
1972: *ndigit=1;
1973: buf[MAXINTLENGTH]='0';
1974: return(&buf[MAXINTLENGTH]);
1975: }
1976: for(i=MAXINTLENGTH-1;value>0;i--)
1977: { *(buf+i)=(int)(value%base)+'0';
1978: value /= base;
1979: }
1980: *ndigit=MAXINTLENGTH-1-i;
1981: return(&buf[i+1]);
1982: }
1983: #ifdef __cplusplus
1984: }
1985: #endif
1986: ./ ADD NAME=fp.h TIME=580998005
1987: #define FMAX 40
1988: #define EXPMAXDIGS 8
1989: #define EXPMAX 99999999
1990: /* FMAX = max number of nonzero digits passed to atof() */
1991: /* EXPMAX = 10^EXPMAXDIGS - 1 = largest allowed exponent absolute value */
1992:
1993: #include "local.h"
1994:
1995: /* MAXFRACDIGS and MAXINTDIGS are for wrt_F -- bounds (not necessarily
1996: tight) on the maximum number of digits to the right and left of
1997: * the decimal point.
1998: */
1999:
2000: #ifdef VAX
2001: #define MAXFRACDIGS 56
2002: #define MAXINTDIGS 38
2003: #else
2004: #ifdef CRAY
2005: #define MAXFRACDIGS 9880
2006: #define MAXINTDIGS 9864
2007: #else
2008: /* values that suffice for IEEE double */
2009: #define MAXFRACDIGS 344
2010: #define MAXINTDIGS 308
2011: #endif
2012: #endif
2013: ./ ADD NAME=iio.c TIME=708823315
2014: #include "f2c.h"
2015: #include "fio.h"
2016: #include "fmt.h"
2017: extern char *icptr;
2018: char *icend;
2019: extern icilist *svic;
2020: int icnum;
2021: extern int hiwater;
2022: z_getc(Void)
2023: {
2024: if(recpos++ < svic->icirlen) {
2025: if(icptr >= icend) err(svic->iciend,(EOF),"endfile");
2026: return(*icptr++);
2027: }
2028: err(svic->icierr,110,"recend");
2029: }
2030: #ifdef KR_headers
2031: z_putc(c)
2032: #else
2033: z_putc(int c)
2034: #endif
2035: {
2036: if(icptr >= icend) err(svic->icierr,110,"inwrite");
2037: if(recpos++ < svic->icirlen)
2038: *icptr++ = c;
2039: else err(svic->icierr,110,"recend");
2040: return 0;
2041: }
2042: z_rnew(Void)
2043: {
2044: icptr = svic->iciunit + (++icnum)*svic->icirlen;
2045: recpos = 0;
2046: cursor = 0;
2047: hiwater = 0;
2048: return 1;
2049: }
2050:
2051: static int
2052: z_endp(Void)
2053: {
2054: (*donewrec)();
2055: return 0;
2056: }
2057:
2058: #ifdef KR_headers
2059: c_si(a) icilist *a;
2060: #else
2061: c_si(icilist *a)
2062: #endif
2063: {
2064: elist = (cilist *)a;
2065: fmtbuf=a->icifmt;
2066: if(pars_f(fmtbuf)<0)
2067: err(a->icierr,100,"startint");
2068: fmt_bg();
2069: sequential=formatted=1;
2070: external=0;
2071: cblank=cplus=scale=0;
2072: svic=a;
2073: icnum=recpos=0;
2074: cursor = 0;
2075: hiwater = 0;
2076: icptr = a->iciunit;
2077: icend = icptr + a->icirlen*a->icirnum;
2078: curunit = 0;
2079: cf = 0;
2080: return(0);
2081: }
2082: y_ierr(Void)
2083: {
2084: err(elist->cierr, 110, "iio");
2085: }
2086: #ifdef KR_headers
2087: integer s_rsfi(a) icilist *a;
2088: #else
2089: integer s_rsfi(icilist *a)
2090: #endif
2091: { int n;
2092: if(n=c_si(a)) return(n);
2093: reading=1;
2094: doed=rd_ed;
2095: doned=rd_ned;
2096: getn=z_getc;
2097: dorevert = y_ierr;
2098: donewrec = z_rnew;
2099: doend = z_endp;
2100: return(0);
2101: }
2102:
2103: z_wnew(Void)
2104: {
2105: while(recpos++ < svic->icirlen)
2106: *icptr++ = ' ';
2107: recpos = 0;
2108: cursor = 0;
2109: hiwater = 0;
2110: icnum++;
2111: return 1;
2112: }
2113: #ifdef KR_headers
2114: integer s_wsfi(a) icilist *a;
2115: #else
2116: integer s_wsfi(icilist *a)
2117: #endif
2118: { int n;
2119: if(n=c_si(a)) return(n);
2120: reading=0;
2121: doed=w_ed;
2122: doned=w_ned;
2123: putn=z_putc;
2124: dorevert = y_ierr;
2125: donewrec = z_wnew;
2126: doend = z_endp;
2127: return(0);
2128: }
2129: integer e_rsfi(Void)
2130: { int n;
2131: n = en_fio();
2132: fmtbuf = NULL;
2133: return(n);
2134: }
2135: integer e_wsfi(Void)
2136: {
2137: int n;
2138: n = en_fio();
2139: fmtbuf = NULL;
2140: if(icnum >= svic->icirnum)
2141: return(n);
2142: while(recpos++ < svic->icirlen)
2143: *icptr++ = ' ';
2144: return(n);
2145: }
2146: ./ ADD NAME=ilnw.c TIME=708907683
2147: #include "f2c.h"
2148: #include "fio.h"
2149: #include "lio.h"
2150: extern char *icptr;
2151: extern char *icend;
2152: extern icilist *svic;
2153: extern int icnum;
2154: #ifdef KR_headers
2155: extern int z_putc();
2156: #else
2157: extern int z_putc(int);
2158: #endif
2159:
2160: static int
2161: z_wSL(Void)
2162: {
2163: while(recpos < svic->icirlen)
2164: z_putc(' ');
2165: return z_rnew();
2166: }
2167:
2168: VOID
2169: #ifdef KR_headers
2170: c_liw(a) icilist *a;
2171: #else
2172: c_liw(icilist *a)
2173: #endif
2174: {
2175: reading = 0;
2176: external = 0;
2177: formatted = 1;
2178: putn = z_putc;
2179: L_len = a->icirlen;
2180: donewrec = z_wSL;
2181: svic = a;
2182: icnum = recpos = 0;
2183: cursor = 0;
2184: cf = 0;
2185: curunit = 0;
2186: icptr = a->iciunit;
2187: icend = icptr + a->icirlen*a->icirnum;
2188: elist = (cilist *)a;
2189: }
2190:
2191: #ifdef KR_headers
2192: s_wsni(a) icilist *a;
2193: #else
2194: s_wsni(icilist *a)
2195: #endif
2196: {
2197: cilist ca;
2198:
2199: c_liw(a);
2200: ca.cifmt = a->icifmt;
2201: x_wsne(&ca);
2202: z_wSL();
2203: return 0;
2204: }
2205:
2206: #ifdef KR_headers
2207: integer s_wsli(a) icilist *a;
2208: #else
2209: integer s_wsli(icilist *a)
2210: #endif
2211: {
2212: lioproc = l_write;
2213: c_liw(a);
2214: return(0);
2215: }
2216:
2217: integer e_wsli(Void)
2218: {
2219: z_wSL();
2220: return(0);
2221: }
2222: ./ ADD NAME=inquire.c TIME=708896213
2223: #include "f2c.h"
2224: #include "fio.h"
2225: #ifdef KR_headers
2226: integer f_inqu(a) inlist *a;
2227: #else
2228: #ifdef MSDOS
2229: #undef abs
2230: #include "string.h"
2231: #include "io.h"
2232: #endif
2233: integer f_inqu(inlist *a)
2234: #endif
2235: { flag byfile;
2236: int i, n;
2237: unit *p;
2238: char buf[256];
2239: long x;
2240: if(a->infile!=NULL)
2241: { byfile=1;
2242: g_char(a->infile,a->infilen,buf);
2243: #ifdef MSDOS
2244: x = access(buf,0) ? -1 : 0;
2245: for(i=0,p=NULL;i<MXUNIT;i++)
2246: if(units[i].ufd != NULL
2247: && units[i].ufnm != NULL
2248: && !strcmp(units[i].ufnm,buf)) {
2249: p = &units[i];
2250: break;
2251: }
2252: #else
2253: x=inode(buf, &n);
2254: for(i=0,p=NULL;i<MXUNIT;i++)
2255: if(units[i].uinode==x
2256: && units[i].ufd!=NULL
2257: && units[i].udev == n) {
2258: p = &units[i];
2259: break;
2260: }
2261: #endif
2262: }
2263: else
2264: {
2265: byfile=0;
2266: if(a->inunit<MXUNIT && a->inunit>=0)
2267: {
2268: p= &units[a->inunit];
2269: }
2270: else
2271: {
2272: p=NULL;
2273: }
2274: }
2275: if(a->inex!=NULL)
2276: if(byfile && x != -1 || !byfile && p!=NULL)
2277: *a->inex=1;
2278: else *a->inex=0;
2279: if(a->inopen!=NULL)
2280: if(byfile) *a->inopen=(p!=NULL);
2281: else *a->inopen=(p!=NULL && p->ufd!=NULL);
2282: if(a->innum!=NULL) *a->innum= p-units;
2283: if(a->innamed!=NULL)
2284: if(byfile || p!=NULL && p->ufnm!=NULL)
2285: *a->innamed=1;
2286: else *a->innamed=0;
2287: if(a->inname!=NULL)
2288: if(byfile)
2289: b_char(buf,a->inname,a->innamlen);
2290: else if(p!=NULL && p->ufnm!=NULL)
2291: b_char(p->ufnm,a->inname,a->innamlen);
2292: if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL)
2293: if(p->url)
2294: b_char("DIRECT",a->inacc,a->inacclen);
2295: else b_char("SEQUENTIAL",a->inacc,a->inacclen);
2296: if(a->inseq!=NULL)
2297: if(p!=NULL && p->url)
2298: b_char("NO",a->inseq,a->inseqlen);
2299: else b_char("YES",a->inseq,a->inseqlen);
2300: if(a->indir!=NULL)
2301: if(p==NULL || p->url)
2302: b_char("YES",a->indir,a->indirlen);
2303: else b_char("NO",a->indir,a->indirlen);
2304: if(a->infmt!=NULL)
2305: if(p!=NULL && p->ufmt==0)
2306: b_char("UNFORMATTED",a->infmt,a->infmtlen);
2307: else b_char("FORMATTED",a->infmt,a->infmtlen);
2308: if(a->inform!=NULL)
2309: if(p!=NULL && p->ufmt==0)
2310: b_char("NO",a->inform,a->informlen);
2311: else b_char("YES",a->inform,a->informlen);
2312: if(a->inunf)
2313: if(p!=NULL && p->ufmt==0)
2314: b_char("YES",a->inunf,a->inunflen);
2315: else if (p!=NULL) b_char("NO",a->inunf,a->inunflen);
2316: else b_char("UNKNOWN",a->inunf,a->inunflen);
2317: if(a->inrecl!=NULL && p!=NULL)
2318: *a->inrecl=p->url;
2319: if(a->innrec!=NULL && p!=NULL && p->url>0)
2320: *a->innrec=ftell(p->ufd)/p->url+1;
2321: if(a->inblank && p!=NULL && p->ufmt)
2322: if(p->ublnk)
2323: b_char("ZERO",a->inblank,a->inblanklen);
2324: else b_char("NULL",a->inblank,a->inblanklen);
2325: return(0);
2326: }
2327: ./ ADD NAME=lio.h TIME=708907526
2328: /* copy of ftypes from the compiler */
2329: /* variable types
2330: * numeric assumptions:
2331: * int < reals < complexes
2332: * TYDREAL-TYREAL = TYDCOMPLEX-TYCOMPLEX
2333: */
2334:
2335: #define TYUNKNOWN 0
2336: #define TYADDR 1
2337: #define TYSHORT 2
2338: #define TYLONG 3
2339: #define TYREAL 4
2340: #define TYDREAL 5
2341: #define TYCOMPLEX 6
2342: #define TYDCOMPLEX 7
2343: #define TYLOGICAL 8
2344: #define TYCHAR 9
2345: #define TYSUBR 10
2346: #define TYERROR 11
2347:
2348: #define NTYPES (TYERROR+1)
2349:
2350: #define LINTW 12
2351: #define LINE 80
2352: #define LLOGW 2
2353: #ifdef Old_list_output
2354: #define LLOW 1.0
2355: #define LHIGH 1.e9
2356: #define LEFMT " %# .8E"
2357: #define LFFMT " %# .9g"
2358: #else
2359: #define LGFMT "%.9G"
2360: #endif
2361: /* LEFBL 20 should suffice; 24 overcomes a NeXT bug. */
2362: #define LEFBL 24
2363:
2364: typedef union
2365: { short flshort;
2366: ftnint flint;
2367: real flreal;
2368: doublereal fldouble;
2369: } flex;
2370: extern int scale;
2371: #ifdef KR_headers
2372: extern int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
2373: extern int l_read();
2374: #else
2375: #ifdef __cplusplus
2376: extern "C" {
2377: #endif
2378: extern int (*lioproc)(ftnint*, char*, ftnlen, ftnint);
2379: extern int l_write(ftnint*, char*, ftnlen, ftnint);
2380: extern void x_wsne(cilist*);
2381: extern int c_le(cilist*), (*l_getc)(void), (*l_ungetc)(int,FILE*);
2382: extern int l_read(ftnint*,char*,ftnlen,ftnint);
2383: extern integer e_rsle(void);
2384: extern int z_rnew(void);
2385: #ifdef __cplusplus
2386: }
2387: #endif
2388: #endif
2389: extern int L_len;
2390: ./ ADD NAME=local.h TIME=705213589
2391: ./ ADD NAME=lread.c TIME=708826270
2392: #include "f2c.h"
2393: #include "fio.h"
2394: #include "fmt.h"
2395: #include "lio.h"
2396: #include "ctype.h"
2397: #include "fp.h"
2398:
2399: extern char *fmtbuf;
2400: #ifdef KR_headers
2401: extern double atof();
2402: extern char *malloc(), *realloc();
2403: int (*lioproc)(), (*l_getc)(), (*l_ungetc)();
2404: #else
2405: #undef abs
2406: #include "stdlib.h"
2407: int (*lioproc)(ftnint*, char*, ftnlen, ftnint), (*l_getc)(void),
2408: (*l_ungetc)(int,FILE*);
2409: #endif
2410: int l_eof;
2411:
2412: #define isblnk(x) (ltab[x+1]&B)
2413: #define issep(x) (ltab[x+1]&SX)
2414: #define isapos(x) (ltab[x+1]&AX)
2415: #define isexp(x) (ltab[x+1]&EX)
2416: #define issign(x) (ltab[x+1]&SG)
2417: #define iswhit(x) (ltab[x+1]&WH)
2418: #define SX 1
2419: #define B 2
2420: #define AX 4
2421: #define EX 8
2422: #define SG 16
2423: #define WH 32
2424: char ltab[128+1] = { /* offset one for EOF */
2425: 0,
2426: 0,0,AX,0,0,0,0,0,0,WH|B,SX|WH,0,0,0,0,0,
2427: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
2428: SX|B|WH,0,AX,0,0,0,0,AX,0,0,0,SG,SX,SG,0,SX,
2429: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
2430: 0,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
2431: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,
2432: AX,0,0,0,EX,EX,0,0,0,0,0,0,0,0,0,0,
2433: 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0
2434: };
2435:
2436: #ifdef ungetc
2437: static int
2438: #ifdef KR_headers
2439: un_getc(x,cf) int x; FILE *cf;
2440: #else
2441: un_getc(int x, FILE *cf)
2442: #endif
2443: { return ungetc(x,cf); }
2444: #else
2445: #define un_getc ungetc
2446: #ifdef KR_headers
2447: extern int ungetc();
2448: #endif
2449: #endif
2450:
2451: t_getc(Void)
2452: { int ch;
2453: if(curunit->uend) return(EOF);
2454: if((ch=getc(cf))!=EOF) return(ch);
2455: if(feof(cf))
2456: l_eof = curunit->uend = 1;
2457: return(EOF);
2458: }
2459: integer e_rsle(Void)
2460: {
2461: int ch;
2462: if(curunit->uend) return(0);
2463: while((ch=t_getc())!='\n' && ch!=EOF);
2464: return(0);
2465: }
2466:
2467: flag lquit;
2468: int lcount,ltype,nml_read;
2469: char *lchar;
2470: double lx,ly;
2471: #define ERR(x) if(n=(x)) return(n)
2472: #define GETC(x) (x=(*l_getc)())
2473: #define Ungetc(x,y) (*l_ungetc)(x,y)
2474:
2475: #ifdef KR_headers
2476: l_R(poststar) int poststar;
2477: #else
2478: l_R(int poststar)
2479: #endif
2480: {
2481: char s[FMAX+EXPMAXDIGS+4];
2482: register int ch;
2483: register char *sp, *spe, *sp1;
2484: long e, exp;
2485: int havenum, havestar, se;
2486:
2487: if (!poststar) {
2488: if (lcount > 0)
2489: return(0);
2490: lcount = 1;
2491: }
2492: ltype = 0;
2493: exp = 0;
2494: havestar = 0;
2495: retry:
2496: sp1 = sp = s;
2497: spe = sp + FMAX;
2498: havenum = 0;
2499:
2500: switch(GETC(ch)) {
2501: case '-': *sp++ = ch; sp1++; spe++;
2502: case '+':
2503: GETC(ch);
2504: }
2505: while(ch == '0') {
2506: ++havenum;
2507: GETC(ch);
2508: }
2509: while(isdigit(ch)) {
2510: if (sp < spe) *sp++ = ch;
2511: else ++exp;
2512: GETC(ch);
2513: }
2514: if (ch == '*' && !poststar) {
2515: if (sp == sp1 || exp || *s == '-') {
2516: err(elist->cierr,112,"bad repetition count")
2517: }
2518: poststar = havestar = 1;
2519: *sp = 0;
2520: lcount = atoi(s);
2521: goto retry;
2522: }
2523: if (ch == '.') {
2524: GETC(ch);
2525: if (sp == sp1)
2526: while(ch == '0') {
2527: ++havenum;
2528: --exp;
2529: GETC(ch);
2530: }
2531: while(isdigit(ch)) {
2532: if (sp < spe)
2533: { *sp++ = ch; --exp; }
2534: GETC(ch);
2535: }
2536: }
2537: se = 0;
2538: if (issign(ch))
2539: goto signonly;
2540: if (isexp(ch)) {
2541: GETC(ch);
2542: if (issign(ch)) {
2543: signonly:
2544: if (ch == '-') se = 1;
2545: GETC(ch);
2546: }
2547: if (!isdigit(ch)) {
2548: bad:
2549: err(elist->cierr,112,"exponent field")
2550: }
2551:
2552: e = ch - '0';
2553: while(isdigit(GETC(ch))) {
2554: e = 10*e + ch - '0';
2555: if (e > EXPMAX)
2556: goto bad;
2557: }
2558: if (se)
2559: exp -= e;
2560: else
2561: exp += e;
2562: }
2563: (void) Ungetc(ch, cf);
2564: if (sp > sp1) {
2565: ++havenum;
2566: while(*--sp == '0')
2567: ++exp;
2568: if (exp)
2569: sprintf(sp+1, "e%ld", exp);
2570: else
2571: sp[1] = 0;
2572: lx = atof(s);
2573: }
2574: else
2575: lx = 0.;
2576: if (havenum)
2577: ltype = TYLONG;
2578: else
2579: switch(ch) {
2580: case ',':
2581: case '/':
2582: break;
2583: default:
2584: if (havestar && ( ch == ' '
2585: ||ch == '\t'
2586: ||ch == '\n'))
2587: break;
2588: if (nml_read > 1) {
2589: lquit = 2;
2590: return 0;
2591: }
2592: err(elist->cierr,112,"invalid number")
2593: }
2594: return 0;
2595: }
2596:
2597: static int
2598: #ifdef KR_headers
2599: rd_count(ch) register int ch;
2600: #else
2601: rd_count(register int ch)
2602: #endif
2603: {
2604: if (ch < '0' || ch > '9')
2605: return 1;
2606: lcount = ch - '0';
2607: while(GETC(ch) >= '0' && ch <= '9')
2608: lcount = 10*lcount + ch - '0';
2609: Ungetc(ch,cf);
2610: return lcount <= 0;
2611: }
2612:
2613: l_C(Void)
2614: { int ch, nml_save;
2615: double lz;
2616: if(lcount>0) return(0);
2617: ltype=0;
2618: GETC(ch);
2619: if(ch!='(')
2620: {
2621: if (nml_read > 1 && (ch < '0' || ch > '9')) {
2622: Ungetc(ch,cf);
2623: lquit = 2;
2624: return 0;
2625: }
2626: if (rd_count(ch))
2627: if(!cf || !feof(cf))
2628: err(elist->cierr,112,"complex format")
2629: else
2630: err(elist->cierr,(EOF),"lread");
2631: if(GETC(ch)!='*')
2632: {
2633: if(!cf || !feof(cf))
2634: err(elist->cierr,112,"no star")
2635: else
2636: err(elist->cierr,(EOF),"lread");
2637: }
2638: if(GETC(ch)!='(')
2639: { Ungetc(ch,cf);
2640: return(0);
2641: }
2642: }
2643: else
2644: lcount = 1;
2645: while(iswhit(GETC(ch)));
2646: Ungetc(ch,cf);
2647: nml_save = nml_read;
2648: nml_read = 0;
2649: if (ch = l_R(1))
2650: return ch;
2651: if (!ltype)
2652: err(elist->cierr,112,"no real part");
2653: lz = lx;
2654: while(iswhit(GETC(ch)));
2655: if(ch!=',')
2656: { (void) Ungetc(ch,cf);
2657: err(elist->cierr,112,"no comma");
2658: }
2659: while(iswhit(GETC(ch)));
2660: (void) Ungetc(ch,cf);
2661: if (ch = l_R(1))
2662: return ch;
2663: if (!ltype)
2664: err(elist->cierr,112,"no imaginary part");
2665: while(iswhit(GETC(ch)));
2666: if(ch!=')') err(elist->cierr,112,"no )");
2667: ly = lx;
2668: lx = lz;
2669: nml_read = nml_save;
2670: return(0);
2671: }
2672: l_L(Void)
2673: {
2674: int ch;
2675: if(lcount>0) return(0);
2676: ltype=0;
2677: GETC(ch);
2678: if(isdigit(ch))
2679: {
2680: rd_count(ch);
2681: if(GETC(ch)!='*')
2682: if(!cf || !feof(cf))
2683: err(elist->cierr,112,"no star")
2684: else
2685: err(elist->cierr,(EOF),"lread");
2686: GETC(ch);
2687: }
2688: if(ch == '.') GETC(ch);
2689: switch(ch)
2690: {
2691: case 't':
2692: case 'T':
2693: lx=1;
2694: break;
2695: case 'f':
2696: case 'F':
2697: lx=0;
2698: break;
2699: default:
2700: if(isblnk(ch) || issep(ch) || ch==EOF)
2701: { (void) Ungetc(ch,cf);
2702: return(0);
2703: }
2704: else err(elist->cierr,112,"logical");
2705: }
2706: ltype=TYLONG;
2707: lcount = 1;
2708: while(!issep(GETC(ch)) && ch!=EOF);
2709: (void) Ungetc(ch, cf);
2710: return(0);
2711: }
2712: #define BUFSIZE 128
2713: l_CHAR(Void)
2714: { int ch,size,i;
2715: char quote,*p;
2716: if(lcount>0) return(0);
2717: ltype=0;
2718: if(lchar!=NULL) free(lchar);
2719: size=BUFSIZE;
2720: p=lchar=malloc((unsigned int)size);
2721: if(lchar==NULL) err(elist->cierr,113,"no space");
2722:
2723: GETC(ch);
2724: if(isdigit(ch)) {
2725: /* allow Fortran 8x-style unquoted string... */
2726: /* either find a repetition count or the string */
2727: lcount = ch - '0';
2728: *p++ = ch;
2729: for(i = 1;;) {
2730: switch(GETC(ch)) {
2731: case '*':
2732: if (lcount == 0) {
2733: lcount = 1;
2734: goto noquote;
2735: }
2736: p = lchar;
2737: goto have_lcount;
2738: case ',':
2739: case ' ':
2740: case '\t':
2741: case '\n':
2742: case '/':
2743: Ungetc(ch,cf);
2744: /* no break */
2745: case EOF:
2746: lcount = 1;
2747: ltype = TYCHAR;
2748: return *p = 0;
2749: }
2750: if (!isdigit(ch)) {
2751: lcount = 1;
2752: goto noquote;
2753: }
2754: *p++ = ch;
2755: lcount = 10*lcount + ch - '0';
2756: if (++i == size) {
2757: lchar = realloc(lchar,
2758: (unsigned int)(size += BUFSIZE));
2759: p = lchar + i;
2760: }
2761: }
2762: }
2763: else (void) Ungetc(ch,cf);
2764: have_lcount:
2765: if(GETC(ch)=='\'' || ch=='"') quote=ch;
2766: else if(isblnk(ch) || (issep(ch) && ch != '\n') || ch==EOF)
2767: { (void) Ungetc(ch,cf);
2768: return(0);
2769: }
2770: else {
2771: /* Fortran 8x-style unquoted string */
2772: *p++ = ch;
2773: for(i = 1;;) {
2774: switch(GETC(ch)) {
2775: case ',':
2776: case ' ':
2777: case '\t':
2778: case '\n':
2779: case '/':
2780: Ungetc(ch,cf);
2781: /* no break */
2782: case EOF:
2783: ltype = TYCHAR;
2784: return *p = 0;
2785: }
2786: noquote:
2787: *p++ = ch;
2788: if (++i == size) {
2789: lchar = realloc(lchar,
2790: (unsigned int)(size += BUFSIZE));
2791: p = lchar + i;
2792: }
2793: }
2794: }
2795: ltype=TYCHAR;
2796: for(i=0;;)
2797: { while(GETC(ch)!=quote && ch!='\n'
2798: && ch!=EOF && ++i<size) *p++ = ch;
2799: if(i==size)
2800: {
2801: newone:
2802: lchar= realloc(lchar, (unsigned int)(size += BUFSIZE));
2803: p=lchar+i-1;
2804: *p++ = ch;
2805: }
2806: else if(ch==EOF) return(EOF);
2807: else if(ch=='\n')
2808: { if(*(p-1) != '\\') continue;
2809: i--;
2810: p--;
2811: if(++i<size) *p++ = ch;
2812: else goto newone;
2813: }
2814: else if(GETC(ch)==quote)
2815: { if(++i<size) *p++ = ch;
2816: else goto newone;
2817: }
2818: else
2819: { (void) Ungetc(ch,cf);
2820: *p = 0;
2821: return(0);
2822: }
2823: }
2824: }
2825: #ifdef KR_headers
2826: c_le(a) cilist *a;
2827: #else
2828: c_le(cilist *a)
2829: #endif
2830: {
2831: fmtbuf="list io";
2832: if(a->ciunit>=MXUNIT || a->ciunit<0)
2833: err(a->cierr,101,"stler");
2834: scale=recpos=0;
2835: elist=a;
2836: curunit = &units[a->ciunit];
2837: if(curunit->ufd==NULL && fk_open(SEQ,FMT,a->ciunit))
2838: err(a->cierr,102,"lio");
2839: cf=curunit->ufd;
2840: if(!curunit->ufmt) err(a->cierr,103,"lio")
2841: return(0);
2842: }
2843: #ifdef KR_headers
2844: l_read(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
2845: #else
2846: l_read(ftnint *number, char *ptr, ftnlen len, ftnint type)
2847: #endif
2848: {
2849: #define Ptr ((flex *)ptr)
2850: int i,n,ch;
2851: doublereal *yy;
2852: real *xx;
2853: for(i=0;i<*number;i++)
2854: {
2855: if(lquit) return(0);
2856: if(l_eof)
2857: err(elist->ciend, EOF, "list in")
2858: if(lcount == 0) {
2859: ltype = 0;
2860: for(;;) {
2861: GETC(ch);
2862: switch(ch) {
2863: case EOF:
2864: goto loopend;
2865: case ' ':
2866: case '\t':
2867: case '\n':
2868: continue;
2869: case '/':
2870: lquit = 1;
2871: goto loopend;
2872: case ',':
2873: lcount = 1;
2874: goto loopend;
2875: default:
2876: (void) Ungetc(ch, cf);
2877: goto rddata;
2878: }
2879: }
2880: }
2881: rddata:
2882: switch((int)type)
2883: {
2884: case TYSHORT:
2885: case TYLONG:
2886: case TYREAL:
2887: case TYDREAL:
2888: ERR(l_R(0));
2889: break;
2890: case TYCOMPLEX:
2891: case TYDCOMPLEX:
2892: ERR(l_C());
2893: break;
2894: case TYLOGICAL:
2895: ERR(l_L());
2896: break;
2897: case TYCHAR:
2898: ERR(l_CHAR());
2899: break;
2900: }
2901: while (GETC(ch) == ' ' || ch == '\t');
2902: if (ch != ',' || lcount > 1)
2903: Ungetc(ch,cf);
2904: loopend:
2905: if(lquit) return(0);
2906: if(cf) {
2907: if (feof(cf))
2908: err(elist->ciend,(EOF),"list in")
2909: else if(ferror(cf)) {
2910: clearerr(cf);
2911: err(elist->cierr,errno,"list in")
2912: }
2913: }
2914: if(ltype==0) goto bump;
2915: switch((int)type)
2916: {
2917: case TYSHORT:
2918: Ptr->flshort=lx;
2919: break;
2920: case TYLOGICAL:
2921: case TYLONG:
2922: Ptr->flint=lx;
2923: break;
2924: case TYREAL:
2925: Ptr->flreal=lx;
2926: break;
2927: case TYDREAL:
2928: Ptr->fldouble=lx;
2929: break;
2930: case TYCOMPLEX:
2931: xx=(real *)ptr;
2932: *xx++ = lx;
2933: *xx = ly;
2934: break;
2935: case TYDCOMPLEX:
2936: yy=(doublereal *)ptr;
2937: *yy++ = lx;
2938: *yy = ly;
2939: break;
2940: case TYCHAR:
2941: b_char(lchar,ptr,len);
2942: break;
2943: }
2944: bump:
2945: if(lcount>0) lcount--;
2946: ptr += len;
2947: if (nml_read)
2948: nml_read++;
2949: }
2950: return(0);
2951: #undef Ptr
2952: }
2953: #ifdef KR_headers
2954: integer s_rsle(a) cilist *a;
2955: #else
2956: integer s_rsle(cilist *a)
2957: #endif
2958: {
2959: int n;
2960:
2961: if(!init) f_init();
2962: if(n=c_le(a)) return(n);
2963: reading=1;
2964: external=1;
2965: formatted=1;
2966: lioproc = l_read;
2967: lquit = 0;
2968: lcount = 0;
2969: l_eof = 0;
2970: if(curunit->uwrt && nowreading(curunit))
2971: err(a->cierr,errno,"read start");
2972: l_getc = t_getc;
2973: l_ungetc = un_getc;
2974: return(0);
2975: }
2976: ./ ADD NAME=lwrite.c TIME=708868720
2977: #include "f2c.h"
2978: #include "fio.h"
2979: #include "fmt.h"
2980: #include "lio.h"
2981: int L_len;
2982:
2983: #ifdef KR_headers
2984: t_putc(c)
2985: #else
2986: t_putc(int c)
2987: #endif
2988: {
2989: recpos++;
2990: putc(c,cf);
2991: return(0);
2992: }
2993: static VOID
2994: #ifdef KR_headers
2995: lwrt_I(n) ftnint n;
2996: #else
2997: lwrt_I(ftnint n)
2998: #endif
2999: {
3000: char buf[LINTW],*p;
3001: #ifdef USE_STRLEN
3002: (void) sprintf(buf," %ld",(long)n);
3003: if(recpos+strlen(buf)>=L_len)
3004: #else
3005: if(recpos + sprintf(buf," %ld",(long)n) >= L_len)
3006: #endif
3007: (*donewrec)();
3008: for(p=buf;*p;PUT(*p++));
3009: }
3010: static VOID
3011: #ifdef KR_headers
3012: lwrt_L(n, len) ftnint n; ftnlen len;
3013: #else
3014: lwrt_L(ftnint n, ftnlen len)
3015: #endif
3016: {
3017: if(recpos+LLOGW>=L_len)
3018: (*donewrec)();
3019: wrt_L((Uint *)&n,LLOGW, len);
3020: }
3021: static VOID
3022: #ifdef KR_headers
3023: lwrt_A(p,len) char *p; ftnlen len;
3024: #else
3025: lwrt_A(char *p, ftnlen len)
3026: #endif
3027: {
3028: int i;
3029: if(recpos+len>=L_len)
3030: (*donewrec)();
3031: if (!recpos)
3032: { PUT(' '); ++recpos; }
3033: for(i=0;i<len;i++) PUT(*p++);
3034: }
3035:
3036: static int
3037: #ifdef KR_headers
3038: l_g(buf, n) char *buf; double n;
3039: #else
3040: l_g(char *buf, double n)
3041: #endif
3042: {
3043: #ifdef Old_list_output
3044: doublereal absn;
3045: char *fmt;
3046:
3047: absn = n;
3048: if (absn < 0)
3049: absn = -absn;
3050: fmt = LLOW <= absn && absn < LHIGH ? LFFMT : LEFMT;
3051: #ifdef USE_STRLEN
3052: sprintf(buf, fmt, n);
3053: return strlen(buf);
3054: #else
3055: return sprintf(buf, fmt, n);
3056: #endif
3057:
3058: #else
3059: register char *b, c, c1;
3060:
3061: b = buf;
3062: *b++ = ' ';
3063: if (n < 0) {
3064: *b++ = '-';
3065: n = -n;
3066: }
3067: else
3068: *b++ = ' ';
3069: if (n == 0) {
3070: *b++ = '0';
3071: *b++ = '.';
3072: *b = 0;
3073: goto ret;
3074: }
3075: sprintf(b, LGFMT, n);
3076: if (*b == '0') {
3077: while(b[0] = b[1])
3078: b++;
3079: }
3080: /* Fortran 77 insists on having a decimal point... */
3081: else for(;; b++)
3082: switch(*b) {
3083: case 0:
3084: *b++ = '.';
3085: *b = 0;
3086: goto ret;
3087: case '.':
3088: while(*++b);
3089: goto ret;
3090: case 'E':
3091: for(c1 = '.', c = 'E'; *b = c1;
3092: c1 = c, c = *++b);
3093: goto ret;
3094: }
3095: ret:
3096: return b - buf;
3097: #endif
3098: }
3099:
3100: static VOID
3101: #ifdef KR_headers
3102: l_put(s) register char *s;
3103: #else
3104: l_put(register char *s)
3105: #endif
3106: {
3107: #ifdef KR_headers
3108: register int c, (*pn)() = putn;
3109: #else
3110: register int c, (*pn)(int) = putn;
3111: #endif
3112: while(c = *s++)
3113: (*pn)(c);
3114: }
3115:
3116: static VOID
3117: #ifdef KR_headers
3118: lwrt_F(n) double n;
3119: #else
3120: lwrt_F(double n)
3121: #endif
3122: {
3123: char buf[LEFBL];
3124:
3125: if(recpos + l_g(buf,n) >= L_len)
3126: (*donewrec)();
3127: l_put(buf);
3128: }
3129: static VOID
3130: #ifdef KR_headers
3131: lwrt_C(a,b) double a,b;
3132: #else
3133: lwrt_C(double a, double b)
3134: #endif
3135: {
3136: char *ba, *bb, bufa[LEFBL], bufb[LEFBL];
3137: int al, bl;
3138:
3139: al = l_g(bufa, a);
3140: for(ba = bufa; *ba == ' '; ba++)
3141: --al;
3142: bl = l_g(bufb, b) + 1; /* intentionally high by 1 */
3143: for(bb = bufb; *bb == ' '; bb++)
3144: --bl;
3145: if(recpos + al + bl + 3 >= L_len && recpos)
3146: (*donewrec)();
3147: PUT(' ');
3148: PUT('(');
3149: l_put(ba);
3150: PUT(',');
3151: if (recpos + bl >= L_len) {
3152: (*donewrec)();
3153: PUT(' ');
3154: }
3155: l_put(bb);
3156: PUT(')');
3157: }
3158: #ifdef KR_headers
3159: l_write(number,ptr,len,type) ftnint *number,type; char *ptr; ftnlen len;
3160: #else
3161: l_write(ftnint *number, char *ptr, ftnlen len, ftnint type)
3162: #endif
3163: {
3164: #define Ptr ((flex *)ptr)
3165: int i;
3166: ftnint x;
3167: double y,z;
3168: real *xx;
3169: doublereal *yy;
3170: for(i=0;i< *number; i++)
3171: {
3172: switch((int)type)
3173: {
3174: default: fatal(204,"unknown type in lio");
3175: case TYSHORT:
3176: x=Ptr->flshort;
3177: goto xint;
3178: case TYLONG:
3179: x=Ptr->flint;
3180: xint: lwrt_I(x);
3181: break;
3182: case TYREAL:
3183: y=Ptr->flreal;
3184: goto xfloat;
3185: case TYDREAL:
3186: y=Ptr->fldouble;
3187: xfloat: lwrt_F(y);
3188: break;
3189: case TYCOMPLEX:
3190: xx= &Ptr->flreal;
3191: y = *xx++;
3192: z = *xx;
3193: goto xcomplex;
3194: case TYDCOMPLEX:
3195: yy = &Ptr->fldouble;
3196: y= *yy++;
3197: z = *yy;
3198: xcomplex:
3199: lwrt_C(y,z);
3200: break;
3201: case TYLOGICAL:
3202: lwrt_L(Ptr->flint, len);
3203: break;
3204: case TYCHAR:
3205: lwrt_A(ptr,len);
3206: break;
3207: }
3208: ptr += len;
3209: }
3210: return(0);
3211: }
3212: ./ ADD NAME=mktemp.c TIME=708905875
3213: /* for Zortech */
3214:
3215: #ifdef __cplusplus
3216: extern "C" {
3217: #endif
3218: char *
3219: mktemp(char *s0)
3220: {
3221: static int n;
3222: char *s = s0;
3223:
3224: while(*s != 'X')
3225: s++;
3226: *s++ = '0' + n/10;
3227: *s++ = '0' + n % 10;
3228: *s = 0;
3229: n++;
3230: return s0;
3231: }
3232: #ifdef __cplusplus
3233: }
3234: #endif
3235: ./ ADD NAME=open.c TIME=708894835
3236: #ifdef MSDOS
3237: #include "types.h"
3238: #include "stat.h"
3239: #else
3240: #include "sys/types.h"
3241: #include "sys/stat.h"
3242: #endif
3243: #include "f2c.h"
3244: #include "fio.h"
3245: #include "string.h"
3246: #include "fcntl.h"
3247: #include "rawio.h"
3248: #ifndef O_WRONLY
3249: #define O_RDONLY 0
3250: #define O_WRONLY 1
3251: #endif
3252:
3253: #ifdef KR_headers
3254: extern char *malloc(), *mktemp();
3255: extern FILE *fdopen();
3256: extern integer f_clos();
3257: #else
3258: #undef abs
3259: #include "stdlib.h"
3260: extern int canseek(FILE*);
3261: extern integer f_clos(cllist*);
3262: #endif
3263:
3264: #ifdef NON_ANSI_RW_MODES
3265: char *r_mode[2] = {"r", "r"};
3266: char *w_mode[2] = {"w", "w"};
3267: #else
3268: char *r_mode[2] = {"rb", "r"};
3269: char *w_mode[2] = {"wb", "w"};
3270: #endif
3271:
3272: #ifdef KR_headers
3273: isdev(s) char *s;
3274: #else
3275: isdev(char *s)
3276: #endif
3277: {
3278: #ifdef MSDOS
3279: int i, j;
3280:
3281: i = open(s,O_RDONLY);
3282: if (i == -1)
3283: return 0;
3284: j = isatty(i);
3285: close(i);
3286: return j;
3287: #else
3288: struct stat x;
3289:
3290: if(stat(s, &x) == -1) return(0);
3291: #ifdef S_IFMT
3292: switch(x.st_mode&S_IFMT) {
3293: case S_IFREG:
3294: case S_IFDIR:
3295: return(0);
3296: }
3297: #else
3298: #ifdef S_ISREG
3299: /* POSIX version */
3300: if(S_ISREG(x.st_mode) || S_ISDIR(x.st_mode))
3301: return(0);
3302: else
3303: #else
3304: Help! How does stat work on this system?
3305: #endif
3306: #endif
3307: return(1);
3308: #endif
3309: }
3310: #ifdef KR_headers
3311: integer f_open(a) olist *a;
3312: #else
3313: integer f_open(olist *a)
3314: #endif
3315: { unit *b;
3316: int n;
3317: char buf[256];
3318: cllist x;
3319: #ifndef MSDOS
3320: struct stat stb;
3321: #endif
3322: if(a->ounit>=MXUNIT || a->ounit<0)
3323: err(a->oerr,101,"open")
3324: curunit = b = &units[a->ounit];
3325: if(b->ufd) {
3326: if(a->ofnm==0)
3327: {
3328: same: if (a->oblnk)
3329: b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z';
3330: return(0);
3331: }
3332: #ifdef MSDOS
3333: if (b->ufnm
3334: && strlen(b->ufnm) == a->ofnmlen
3335: && !strncmp(b->ufnm, b->ufnm, (unsigned)a->ofnmlen))
3336: goto same;
3337: #else
3338: g_char(a->ofnm,a->ofnmlen,buf);
3339: if (inode(buf,&n) == b->uinode && n == b->udev)
3340: goto same;
3341: #endif
3342: x.cunit=a->ounit;
3343: x.csta=0;
3344: x.cerr=a->oerr;
3345: if((n=f_clos(&x))!=0) return(n);
3346: }
3347: b->url=a->orl;
3348: b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z');
3349: if(a->ofm==0)
3350: { if(b->url>0) b->ufmt=0;
3351: else b->ufmt=1;
3352: }
3353: else if(*a->ofm=='f' || *a->ofm == 'F') b->ufmt=1;
3354: else b->ufmt=0;
3355: #ifdef url_Adjust
3356: if (b->url && !b->ufmt)
3357: url_Adjust(b->url);
3358: #endif
3359: if (a->ofnm) {
3360: g_char(a->ofnm,a->ofnmlen,buf);
3361: if (!buf[0])
3362: err(a->oerr,107,"open")
3363: }
3364: else
3365: sprintf(buf, "fort.%ld", a->ounit);
3366: b->uscrtch = 0;
3367: switch(a->osta ? *a->osta : 'u')
3368: {
3369: case 'o':
3370: case 'O':
3371: #ifdef MSDOS
3372: if(access(buf,0))
3373: #else
3374: if(stat(buf,&stb))
3375: #endif
3376: err(a->oerr,errno,"open")
3377: break;
3378: case 's':
3379: case 'S':
3380: b->uscrtch=1;
3381: (void) strcpy(buf,"tmp.FXXXXXX");
3382: (void) mktemp(buf);
3383: (void) close(creat(buf, 0666));
3384: break;
3385: case 'n':
3386: case 'N':
3387: #ifdef MSDOS
3388: if(!access(buf,0))
3389: #else
3390: if(!stat(buf,&stb))
3391: #endif
3392: err(a->oerr,128,"open")
3393: /* no break */
3394: case 'r': /* Fortran 90 replace option */
3395: case 'R':
3396: (void) close(creat(buf, 0666));
3397: break;
3398: }
3399:
3400: b->ufnm=(char *) malloc((unsigned int)(strlen(buf)+1));
3401: if(b->ufnm==NULL) err(a->oerr,113,"no space");
3402: (void) strcpy(b->ufnm,buf);
3403: b->uend=0;
3404: b->uwrt = 0;
3405: if(isdev(buf))
3406: { b->ufd = fopen(buf,r_mode[b->ufmt]);
3407: if(b->ufd==NULL) err(a->oerr,errno,buf)
3408: }
3409: else {
3410: if((b->ufd = fopen(buf, r_mode[b->ufmt])) == NULL) {
3411: if ((n = open(buf,O_WRONLY)) >= 0) {
3412: b->uwrt = 2;
3413: }
3414: else {
3415: n = creat(buf, 0666);
3416: b->uwrt = 1;
3417: }
3418: if (n < 0
3419: || (b->ufd = fdopen(n, w_mode[b->ufmt])) == NULL)
3420: err(a->oerr, errno, "open");
3421: }
3422: }
3423: b->useek=canseek(b->ufd);
3424: #ifndef MSDOS
3425: if((b->uinode=inode(buf,&b->udev))==-1)
3426: err(a->oerr,108,"open")
3427: #endif
3428: if(a->orl && b->useek) rewind(b->ufd);
3429: return(0);
3430: }
3431: #ifdef KR_headers
3432: fk_open(seq,fmt,n) ftnint n;
3433: #else
3434: fk_open(int seq, int fmt, ftnint n)
3435: #endif
3436: { char nbuf[10];
3437: olist a;
3438: (void) sprintf(nbuf,"fort.%ld",n);
3439: a.oerr=1;
3440: a.ounit=n;
3441: a.ofnm=nbuf;
3442: a.ofnmlen=strlen(nbuf);
3443: a.osta=NULL;
3444: a.oacc= seq==SEQ?"s":"d";
3445: a.ofm = fmt==FMT?"f":"u";
3446: a.orl = seq==DIR?1:0;
3447: a.oblnk=NULL;
3448: return(f_open(&a));
3449: }
3450: ./ ADD NAME=rawio.h TIME=708896068
3451: #ifndef KR_headers
3452: #ifdef MSDOS
3453: #include "io.h"
3454: #define close _close
3455: #define creat _creat
3456: #define open _open
3457: #define read _read
3458: #define write _write
3459: #endif
3460: #ifdef __cplusplus
3461: extern "C" {
3462: #endif
3463: #ifndef MSDOS
3464: #ifndef NO_OPEN_DECL
3465: extern int creat(const char*,int), open(const char*,int);
3466: #endif
3467: extern int close(int);
3468: extern int read(int,void*,size_t), write(int,void*,size_t);
3469: extern int unlink(const char*);
3470: extern FILE *fdopen(int, const char*);
3471: #endif
3472:
3473: extern char *mktemp(char*);
3474:
3475: #ifdef __cplusplus
3476: }
3477: #endif
3478: #endif
3479: ./ ADD NAME=rdfmt.c TIME=708870801
3480: #include "f2c.h"
3481: #include "fio.h"
3482: #include "fmt.h"
3483: #include "fp.h"
3484:
3485: extern int cursor;
3486: #ifdef KR_headers
3487: extern double atof();
3488: #else
3489: #undef abs
3490: #include "stdlib.h"
3491: #endif
3492:
3493: static int
3494: #ifdef KR_headers
3495: rd_I(n,w,len, base) ftnlen len; Uint *n; register int base;
3496: #else
3497: rd_I(Uint *n, int w, ftnlen len, register int base)
3498: #endif
3499: { long x;
3500: int sign,ch;
3501: char s[84], *ps;
3502: ps=s; x=0;
3503: while (w)
3504: {
3505: GET(ch);
3506: if (ch==',' || ch=='\n') break;
3507: *ps=ch; ps++; w--;
3508: }
3509: *ps='\0';
3510: ps=s;
3511: while (*ps==' ') ps++;
3512: if (*ps=='-') { sign=1; ps++; }
3513: else { sign=0; if (*ps=='+') ps++; }
3514: loop: while (*ps>='0' && *ps<='9') { x=x*base+(*ps-'0'); ps++; }
3515: if (*ps==' ') {if (cblank) x *= base; ps++; goto loop;}
3516: if(sign) x = -x;
3517: if(len==sizeof(integer)) n->il=x;
3518: else if(len == sizeof(char)) n->ic = x;
3519: else n->is=x;
3520: if (*ps) return(errno=115); else return(0);
3521: }
3522: static int
3523: #ifdef KR_headers
3524: rd_L(n,w) ftnint *n;
3525: #else
3526: rd_L(ftnint *n, int w)
3527: #endif
3528: { int ch;
3529: char s[84], *ps;
3530: ps=s;
3531: while (w) {
3532: GET(ch);
3533: if (ch==','||ch=='\n') break;
3534: *ps=ch;
3535: ps++; w--;
3536: }
3537: *ps='\0';
3538: ps=s; while (*ps==' ') ps++;
3539: if (*ps=='.') ps++;
3540: if (*ps=='t' || *ps == 'T') { *n=1; return(0); }
3541: else if (*ps == 'f' || *ps == 'F') { *n=0; return(0); }
3542: else return(errno=116);
3543: }
3544:
3545: #include "ctype.h"
3546:
3547: static int
3548: #ifdef KR_headers
3549: rd_F(p, w, d, len) ufloat *p; ftnlen len;
3550: #else
3551: rd_F(ufloat *p, int w, int d, ftnlen len)
3552: #endif
3553: {
3554: char s[FMAX+EXPMAXDIGS+4];
3555: register int ch;
3556: register char *sp, *spe, *sp1;
3557: double x;
3558: int scale1, se;
3559: long e, exp;
3560:
3561: sp1 = sp = s;
3562: spe = sp + FMAX;
3563: exp = -d;
3564: x = 0.;
3565:
3566: do {
3567: GET(ch);
3568: w--;
3569: } while (ch == ' ' && w);
3570: switch(ch) {
3571: case '-': *sp++ = ch; sp1++; spe++;
3572: case '+':
3573: if (!w) goto zero;
3574: --w;
3575: GET(ch);
3576: }
3577: while(ch == ' ') {
3578: blankdrop:
3579: if (!w--) goto zero; GET(ch); }
3580: while(ch == '0')
3581: { if (!w--) goto zero; GET(ch); }
3582: if (ch == ' ' && cblank)
3583: goto blankdrop;
3584: scale1 = scale;
3585: while(isdigit(ch)) {
3586: digloop1:
3587: if (sp < spe) *sp++ = ch;
3588: else ++exp;
3589: digloop1e:
3590: if (!w--) goto done;
3591: GET(ch);
3592: }
3593: if (ch == ' ') {
3594: if (cblank)
3595: { ch = '0'; goto digloop1; }
3596: goto digloop1e;
3597: }
3598: if (ch == '.') {
3599: exp += d;
3600: if (!w--) goto done;
3601: GET(ch);
3602: if (sp == sp1) { /* no digits yet */
3603: while(ch == '0') {
3604: skip01:
3605: --exp;
3606: skip0:
3607: if (!w--) goto done;
3608: GET(ch);
3609: }
3610: if (ch == ' ') {
3611: if (cblank) goto skip01;
3612: goto skip0;
3613: }
3614: }
3615: while(isdigit(ch)) {
3616: digloop2:
3617: if (sp < spe)
3618: { *sp++ = ch; --exp; }
3619: digloop2e:
3620: if (!w--) goto done;
3621: GET(ch);
3622: }
3623: if (ch == ' ') {
3624: if (cblank)
3625: { ch = '0'; goto digloop2; }
3626: goto digloop2e;
3627: }
3628: }
3629: switch(ch) {
3630: default:
3631: break;
3632: case '-': se = 1; goto signonly;
3633: case '+': se = 0; goto signonly;
3634: case 'e':
3635: case 'E':
3636: case 'd':
3637: case 'D':
3638: if (!w--)
3639: goto bad;
3640: GET(ch);
3641: while(ch == ' ') {
3642: if (!w--)
3643: goto bad;
3644: GET(ch);
3645: }
3646: se = 0;
3647: switch(ch) {
3648: case '-': se = 1;
3649: case '+':
3650: signonly:
3651: if (!w--)
3652: goto bad;
3653: GET(ch);
3654: }
3655: while(ch == ' ') {
3656: if (!w--)
3657: goto bad;
3658: GET(ch);
3659: }
3660: if (!isdigit(ch))
3661: goto bad;
3662:
3663: e = ch - '0';
3664: for(;;) {
3665: if (!w--)
3666: { ch = '\n'; break; }
3667: GET(ch);
3668: if (!isdigit(ch)) {
3669: if (ch == ' ') {
3670: if (cblank)
3671: ch = '0';
3672: else continue;
3673: }
3674: else
3675: break;
3676: }
3677: e = 10*e + ch - '0';
3678: if (e > EXPMAX && sp > sp1)
3679: goto bad;
3680: }
3681: if (se)
3682: exp -= e;
3683: else
3684: exp += e;
3685: scale1 = 0;
3686: }
3687: switch(ch) {
3688: case '\n':
3689: case ',':
3690: break;
3691: default:
3692: bad:
3693: return (errno = 115);
3694: }
3695: done:
3696: if (sp > sp1) {
3697: while(*--sp == '0')
3698: ++exp;
3699: if (exp -= scale1)
3700: sprintf(sp+1, "e%ld", exp);
3701: else
3702: sp[1] = 0;
3703: x = atof(s);
3704: }
3705: zero:
3706: if (len == sizeof(real))
3707: p->pf = x;
3708: else
3709: p->pd = x;
3710: return(0);
3711: }
3712:
3713:
3714: static int
3715: #ifdef KR_headers
3716: rd_A(p,len) char *p; ftnlen len;
3717: #else
3718: rd_A(char *p, ftnlen len)
3719: #endif
3720: { int i,ch;
3721: for(i=0;i<len;i++)
3722: { GET(ch);
3723: *p++=VAL(ch);
3724: }
3725: return(0);
3726: }
3727: static int
3728: #ifdef KR_headers
3729: rd_AW(p,w,len) char *p; ftnlen len;
3730: #else
3731: rd_AW(char *p, int w, ftnlen len)
3732: #endif
3733: { int i,ch;
3734: if(w>=len)
3735: { for(i=0;i<w-len;i++)
3736: GET(ch);
3737: for(i=0;i<len;i++)
3738: { GET(ch);
3739: *p++=VAL(ch);
3740: }
3741: return(0);
3742: }
3743: for(i=0;i<w;i++)
3744: { GET(ch);
3745: *p++=VAL(ch);
3746: }
3747: for(i=0;i<len-w;i++) *p++=' ';
3748: return(0);
3749: }
3750: static int
3751: #ifdef KR_headers
3752: rd_H(n,s) char *s;
3753: #else
3754: rd_H(int n, char *s)
3755: #endif
3756: { int i,ch;
3757: for(i=0;i<n;i++)
3758: if((ch=(*getn)())<0) return(ch);
3759: else *s++ = ch=='\n'?' ':ch;
3760: return(1);
3761: }
3762: static int
3763: #ifdef KR_headers
3764: rd_POS(s) char *s;
3765: #else
3766: rd_POS(char *s)
3767: #endif
3768: { char quote;
3769: int ch;
3770: quote= *s++;
3771: for(;*s;s++)
3772: if(*s==quote && *(s+1)!=quote) break;
3773: else if((ch=(*getn)())<0) return(ch);
3774: else *s = ch=='\n'?' ':ch;
3775: return(1);
3776: }
3777: #ifdef KR_headers
3778: rd_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
3779: #else
3780: rd_ed(struct syl *p, char *ptr, ftnlen len)
3781: #endif
3782: { int ch;
3783: for(;cursor>0;cursor--) if((ch=(*getn)())<0) return(ch);
3784: if(cursor<0)
3785: { if(recpos+cursor < 0) /*err(elist->cierr,110,"fmt")*/
3786: cursor = -recpos; /* is this in the standard? */
3787: if(external == 0) {
3788: extern char *icptr;
3789: icptr += cursor;
3790: }
3791: else if(curunit && curunit->useek)
3792: (void) fseek(cf,(long) cursor,SEEK_CUR);
3793: else
3794: err(elist->cierr,106,"fmt");
3795: recpos += cursor;
3796: cursor=0;
3797: }
3798: switch(p->op)
3799: {
3800: default: fprintf(stderr,"rd_ed, unexpected code: %d\n", p->op);
3801: sig_die(fmtbuf, 1);
3802: case I: ch = (rd_I((Uint *)ptr,p->p1,len, 10));
3803: break;
3804: case IM: ch = (rd_I((Uint *)ptr,p->p1,len, 10));
3805: break;
3806: case O: ch = (rd_I((Uint *)ptr, p->p1, len, 8));
3807: break;
3808: case L: ch = (rd_L((ftnint *)ptr,p->p1));
3809: break;
3810: case A: ch = (rd_A(ptr,len));
3811: break;
3812: case AW:
3813: ch = (rd_AW(ptr,p->p1,len));
3814: break;
3815: case E: case EE:
3816: case D:
3817: case G:
3818: case GE:
3819: case F: ch = (rd_F((ufloat *)ptr,p->p1,p->p2,len));
3820: break;
3821: }
3822: if(ch == 0) return(ch);
3823: else if(ch == EOF) return(EOF);
3824: if (cf)
3825: clearerr(cf);
3826: return(errno);
3827: }
3828: #ifdef KR_headers
3829: rd_ned(p) struct syl *p;
3830: #else
3831: rd_ned(struct syl *p)
3832: #endif
3833: {
3834: switch(p->op)
3835: {
3836: default: fprintf(stderr,"rd_ned, unexpected code: %d\n", p->op);
3837: sig_die(fmtbuf, 1);
3838: case APOS:
3839: return(rd_POS(*(char **)&p->p2));
3840: case H: return(rd_H(p->p1,*(char **)&p->p2));
3841: case SLASH: return((*donewrec)());
3842: case TR:
3843: case X: cursor += p->p1;
3844: return(1);
3845: case T: cursor=p->p1-recpos - 1;
3846: return(1);
3847: case TL: cursor -= p->p1;
3848: if(cursor < -recpos) /* TL1000, 1X */
3849: cursor = -recpos;
3850: return(1);
3851: }
3852: }
3853: ./ ADD NAME=rewind.c TIME=708863391
3854: #include "f2c.h"
3855: #include "fio.h"
3856: #ifdef KR_headers
3857: integer f_rew(a) alist *a;
3858: #else
3859: integer f_rew(alist *a)
3860: #endif
3861: {
3862: unit *b;
3863: if(a->aunit>=MXUNIT || a->aunit<0)
3864: err(a->aerr,101,"rewind");
3865: b = &units[a->aunit];
3866: if(b->ufd == NULL || b->uwrt == 3)
3867: return(0);
3868: if(!b->useek)
3869: err(a->aerr,106,"rewind")
3870: if(b->uwrt) {
3871: (void) t_runc(a);
3872: b->uwrt = 3;
3873: }
3874: rewind(b->ufd);
3875: b->uend=0;
3876: return(0);
3877: }
3878: ./ ADD NAME=rsfe.c TIME=708863550
3879: /* read sequential formatted external */
3880: #include "f2c.h"
3881: #include "fio.h"
3882: #include "fmt.h"
3883:
3884: xrd_SL(Void)
3885: { int ch;
3886: if(!curunit->uend)
3887: while((ch=getc(cf))!='\n' && ch!=EOF);
3888: cursor=recpos=0;
3889: return(1);
3890: }
3891: x_getc(Void)
3892: { int ch;
3893: if(curunit->uend) return(EOF);
3894: ch = getc(cf);
3895: if(ch!=EOF && ch!='\n')
3896: { recpos++;
3897: return(ch);
3898: }
3899: if(ch=='\n')
3900: { (void) ungetc(ch,cf);
3901: return(ch);
3902: }
3903: if(curunit->uend || feof(cf))
3904: { errno=0;
3905: curunit->uend=1;
3906: return(-1);
3907: }
3908: return(-1);
3909: }
3910: x_endp(Void)
3911: {
3912: (void) xrd_SL();
3913: return(0);
3914: }
3915: x_rev(Void)
3916: {
3917: (void) xrd_SL();
3918: return(0);
3919: }
3920: #ifdef KR_headers
3921: integer s_rsfe(a) cilist *a; /* start */
3922: #else
3923: integer s_rsfe(cilist *a) /* start */
3924: #endif
3925: { int n;
3926: if(!init) f_init();
3927: if(n=c_sfe(a)) return(n);
3928: reading=1;
3929: sequential=1;
3930: formatted=1;
3931: external=1;
3932: elist=a;
3933: cursor=recpos=0;
3934: scale=0;
3935: fmtbuf=a->cifmt;
3936: curunit= &units[a->ciunit];
3937: cf=curunit->ufd;
3938: if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
3939: getn= x_getc;
3940: doed= rd_ed;
3941: doned= rd_ned;
3942: fmt_bg();
3943: doend=x_endp;
3944: donewrec=xrd_SL;
3945: dorevert=x_rev;
3946: cblank=curunit->ublnk;
3947: cplus=0;
3948: if(curunit->uwrt && nowreading(curunit))
3949: err(a->cierr,errno,"read start");
3950: return(0);
3951: }
3952: ./ ADD NAME=rsli.c TIME=708864284
3953: #include "f2c.h"
3954: #include "fio.h"
3955: #include "lio.h"
3956:
3957: extern flag lquit;
3958: extern int lcount;
3959: extern char *icptr;
3960: extern char *icend;
3961: extern icilist *svic;
3962: extern int icnum, recpos;
3963:
3964: int i_getc(Void)
3965: {
3966: if(recpos >= svic->icirlen) {
3967: if (recpos++ == svic->icirlen)
3968: return '\n';
3969: z_rnew();
3970: }
3971: recpos++;
3972: if(icptr >= icend) err(svic->iciend,(EOF),"endfile");
3973: return(*icptr++);
3974: }
3975:
3976: #ifdef KR_headers
3977: int i_ungetc(ch, f) int ch; FILE *f;
3978: #else
3979: int i_ungetc(int ch, FILE *f)
3980: #endif
3981: {
3982: if (--recpos == svic->icirlen)
3983: return '\n';
3984: if (recpos < -1)
3985: err(svic->icierr,110,"recend");
3986: /* *--icptr == ch, and icptr may point to read-only memory */
3987: return *--icptr /* = ch */;
3988: }
3989:
3990: static void
3991: #ifdef KR_headers
3992: c_lir(a) icilist *a;
3993: #else
3994: c_lir(icilist *a)
3995: #endif
3996: {
3997: extern int l_eof;
3998: reading = 1;
3999: external = 0;
4000: formatted = 1;
4001: svic = a;
4002: L_len = a->icirlen;
4003: recpos = -1;
4004: icnum = recpos = 0;
4005: cursor = 0;
4006: l_getc = i_getc;
4007: l_ungetc = i_ungetc;
4008: l_eof = 0;
4009: icptr = a->iciunit;
4010: icend = icptr + a->icirlen*a->icirnum;
4011: cf = 0;
4012: curunit = 0;
4013: elist = (cilist *)a;
4014: }
4015:
4016:
4017: #ifdef KR_headers
4018: integer s_rsli(a) icilist *a;
4019: #else
4020: integer s_rsli(icilist *a)
4021: #endif
4022: {
4023: lioproc = l_read;
4024: lquit = 0;
4025: lcount = 0;
4026: c_lir(a);
4027: return(0);
4028: }
4029:
4030: integer e_rsli(Void)
4031: { return 0; }
4032:
4033: #ifdef KR_headers
4034: s_rsni(a) icilist *a;
4035: #else
4036: extern int x_rsne(cilist*);
4037:
4038: s_rsni(icilist *a)
4039: #endif
4040: {
4041: cilist ca;
4042: ca.ciend = a->iciend;
4043: ca.cierr = a->icierr;
4044: ca.cifmt = a->icifmt;
4045: c_lir(a);
4046: return x_rsne(&ca);
4047: }
4048: ./ ADD NAME=rsne.c TIME=708907688
4049: #include "f2c.h"
4050: #include "fio.h"
4051: #include "lio.h"
4052:
4053: #define MAX_NL_CACHE 3 /* maximum number of namelist hash tables to cache */
4054: #define MAXDIM 20 /* maximum number of subscripts */
4055:
4056: struct dimen {
4057: ftnlen extent;
4058: ftnlen curval;
4059: ftnlen delta;
4060: ftnlen stride;
4061: };
4062: typedef struct dimen dimen;
4063:
4064: struct hashentry {
4065: struct hashentry *next;
4066: char *name;
4067: Vardesc *vd;
4068: };
4069: typedef struct hashentry hashentry;
4070:
4071: struct hashtab {
4072: struct hashtab *next;
4073: Namelist *nl;
4074: int htsize;
4075: hashentry *tab[1];
4076: };
4077: typedef struct hashtab hashtab;
4078:
4079: static hashtab *nl_cache;
4080: static n_nlcache;
4081: static hashentry **zot;
4082: extern ftnlen typesize[];
4083:
4084: extern flag lquit;
4085: extern int lcount, nml_read;
4086: extern t_getc(Void);
4087:
4088: #ifdef KR_headers
4089: extern char *malloc(), *memset();
4090:
4091: #ifdef ungetc
4092: static int
4093: un_getc(x,cf) int x; FILE *cf;
4094: { return ungetc(x,cf); }
4095: #else
4096: #define un_getc ungetc
4097: extern int ungetc();
4098: #endif
4099:
4100: #else
4101: #undef abs
4102: #include "stdlib.h"
4103: #include "string.h"
4104:
4105: #ifdef ungetc
4106: static int
4107: un_getc(int x, FILE *cf)
4108: { return ungetc(x,cf); }
4109: #else
4110: #define un_getc ungetc
4111: #endif
4112: #endif
4113:
4114: static Vardesc *
4115: #ifdef KR_headers
4116: hash(ht, s) hashtab *ht; register char *s;
4117: #else
4118: hash(hashtab *ht, register char *s)
4119: #endif
4120: {
4121: register int c, x;
4122: register hashentry *h;
4123: char *s0 = s;
4124:
4125: for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
4126: x += c;
4127: for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
4128: if (!strcmp(s0, h->name))
4129: return h->vd;
4130: return 0;
4131: }
4132:
4133: hashtab *
4134: #ifdef KR_headers
4135: mk_hashtab(nl) Namelist *nl;
4136: #else
4137: mk_hashtab(Namelist *nl)
4138: #endif
4139: {
4140: int nht, nv;
4141: hashtab *ht;
4142: Vardesc *v, **vd, **vde;
4143: hashentry *he;
4144:
4145: hashtab **x, **x0, *y;
4146: for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
4147: if (nl == y->nl)
4148: return y;
4149: if (n_nlcache >= MAX_NL_CACHE) {
4150: /* discard least recently used namelist hash table */
4151: y = *x0;
4152: free((char *)y->next);
4153: y->next = 0;
4154: }
4155: else
4156: n_nlcache++;
4157: nv = nl->nvars;
4158: if (nv >= 0x4000)
4159: nht = 0x7fff;
4160: else {
4161: for(nht = 1; nht < nv; nht <<= 1);
4162: nht += nht - 1;
4163: }
4164: ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
4165: + nv*sizeof(hashentry));
4166: if (!ht)
4167: return 0;
4168: he = (hashentry *)&ht->tab[nht];
4169: ht->nl = nl;
4170: ht->htsize = nht;
4171: ht->next = nl_cache;
4172: nl_cache = ht;
4173: memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
4174: vd = nl->vars;
4175: vde = vd + nv;
4176: while(vd < vde) {
4177: v = *vd++;
4178: if (!hash(ht, v->name)) {
4179: he->next = *zot;
4180: *zot = he;
4181: he->name = v->name;
4182: he->vd = v;
4183: he++;
4184: }
4185: }
4186: return ht;
4187: }
4188:
4189: static char Alpha[256], Alphanum[256];
4190:
4191: static VOID
4192: nl_init(Void) {
4193: register char *s;
4194: register int c;
4195:
4196: if(!init)
4197: f_init();
4198: for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
4199: Alpha[c]
4200: = Alphanum[c]
4201: = Alpha[c + 'a' - 'A']
4202: = Alphanum[c + 'a' - 'A']
4203: = c;
4204: for(s = "0123456789_"; c = *s++; )
4205: Alphanum[c] = c;
4206: }
4207:
4208: #define GETC(x) (x=(*l_getc)())
4209: #define Ungetc(x,y) (*l_ungetc)(x,y)
4210:
4211: static int
4212: #ifdef KR_headers
4213: getname(s, slen) register char *s; int slen;
4214: #else
4215: getname(register char *s, int slen)
4216: #endif
4217: {
4218: register char *se = s + slen - 1;
4219: register int ch;
4220:
4221: GETC(ch);
4222: if (!(*s++ = Alpha[ch & 0xff])) {
4223: if (ch != EOF)
4224: ch = 115;
4225: err(elist->cierr, ch, "namelist read");
4226: }
4227: while(*s = Alphanum[GETC(ch) & 0xff])
4228: if (s < se)
4229: s++;
4230: if (ch == EOF)
4231: err(elist->cierr, EOF, "namelist read");
4232: if (ch > ' ')
4233: Ungetc(ch,cf);
4234: return *s = 0;
4235: }
4236:
4237: static int
4238: getnum(int *chp, ftnlen *val)
4239: {
4240: register int ch, sign;
4241: register ftnlen x;
4242:
4243: while(GETC(ch) <= ' ' && ch >= 0);
4244: if (ch == '-') {
4245: sign = 1;
4246: GETC(ch);
4247: }
4248: else {
4249: sign = 0;
4250: if (ch == '+')
4251: GETC(ch);
4252: }
4253: x = ch - '0';
4254: if (x < 0 || x > 9)
4255: return 115;
4256: while(GETC(ch) >= '0' && ch <= '9')
4257: x = 10*x + ch - '0';
4258: while(ch <= ' ' && ch >= 0)
4259: GETC(ch);
4260: if (ch == EOF)
4261: return EOF;
4262: *val = sign ? -x : x;
4263: *chp = ch;
4264: return 0;
4265: }
4266:
4267: static int
4268: #ifdef KR_headers
4269: getdimen(chp, d, delta, extent, x1)
4270: int *chp; dimen *d; ftnlen delta, extent, *x1;
4271: #else
4272: getdimen(int *chp, dimen *d, ftnlen delta, ftnlen extent, ftnlen *x1)
4273: #endif
4274: {
4275: register int k;
4276: ftnlen x2, x3;
4277:
4278: if (k = getnum(chp, x1))
4279: return k;
4280: x3 = 1;
4281: if (*chp == ':') {
4282: if (k = getnum(chp, &x2))
4283: return k;
4284: x2 -= *x1;
4285: if (*chp == ':') {
4286: if (k = getnum(chp, &x3))
4287: return k;
4288: if (!x3)
4289: return 123;
4290: x2 /= x3;
4291: }
4292: if (x2 < 0 || x2 >= extent)
4293: return 123;
4294: d->extent = x2 + 1;
4295: }
4296: else
4297: d->extent = 1;
4298: d->curval = 0;
4299: d->delta = delta;
4300: d->stride = x3;
4301: return 0;
4302: }
4303:
4304: static char where0[] = "namelist read start ";
4305:
4306: #ifdef KR_headers
4307: x_rsne(a) cilist *a;
4308: #else
4309: x_rsne(cilist *a)
4310: #endif
4311: {
4312: int ch, got1, k, n, nd;
4313: Namelist *nl;
4314: static char where[] = "namelist read";
4315: char buf[64];
4316: hashtab *ht;
4317: Vardesc *v;
4318: dimen *dn, *dn0, *dn1;
4319: ftnlen *dims, *dims1;
4320: ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
4321: ftnint type;
4322: char *vaddr;
4323: long iva, ivae;
4324: dimen dimens[MAXDIM], substr;
4325:
4326: if (!Alpha['a'])
4327: nl_init();
4328: reading=1;
4329: formatted=1;
4330: got1 = 0;
4331: for(;;) switch(GETC(ch)) {
4332: case EOF:
4333: err(a->ciend,(EOF),where0);
4334: case '&':
4335: case '$':
4336: goto have_amp;
4337: default:
4338: if (ch <= ' ' && ch >= 0)
4339: continue;
4340: err(a->cierr, 115, where0);
4341: }
4342: have_amp:
4343: if (ch = getname(buf,sizeof(buf)))
4344: return ch;
4345: nl = (Namelist *)a->cifmt;
4346: if (strcmp(buf, nl->name))
4347: err(a->cierr, 118, where0);
4348: ht = mk_hashtab(nl);
4349: if (!ht)
4350: err(elist->cierr, 113, where0);
4351: for(;;) {
4352: for(;;) switch(GETC(ch)) {
4353: case EOF:
4354: if (got1)
4355: return 0;
4356: err(a->ciend,(EOF),where0);
4357: case '/':
4358: case '$':
4359: return 0;
4360: default:
4361: if (ch <= ' ' && ch >= 0 || ch == ',')
4362: continue;
4363: Ungetc(ch,cf);
4364: if (ch = getname(buf,sizeof(buf)))
4365: return ch;
4366: goto havename;
4367: }
4368: havename:
4369: v = hash(ht,buf);
4370: if (!v)
4371: err(a->cierr, 119, where);
4372: while(GETC(ch) <= ' ' && ch >= 0);
4373: vaddr = v->addr;
4374: type = v->type;
4375: if (type < 0) {
4376: size = -type;
4377: type = TYCHAR;
4378: }
4379: else
4380: size = typesize[type];
4381: ivae = size;
4382: iva = 0;
4383: if (ch == '(' /*)*/ ) {
4384: dn = dimens;
4385: if (!(dims = v->dims)) {
4386: if (type != TYCHAR)
4387: err(a->cierr, 122, where);
4388: if (k = getdimen(&ch, dn, (ftnlen)size,
4389: (ftnlen)size, &b))
4390: err(a->cierr, k, where);
4391: if (ch != ')')
4392: err(a->cierr, 115, where);
4393: b1 = dn->extent;
4394: if (--b < 0 || b + b1 > size)
4395: return 124;
4396: iva += b;
4397: size = b1;
4398: while(GETC(ch) <= ' ' && ch >= 0);
4399: goto scalar;
4400: }
4401: nd = dims[0];
4402: nomax = span = dims[1];
4403: ivae = iva + size*nomax;
4404: if (k = getdimen(&ch, dn, size, nomax, &b))
4405: err(a->cierr, k, where);
4406: no = dn->extent;
4407: b0 = dims[2];
4408: dims1 = dims += 3;
4409: ex = 1;
4410: for(n = 1; n++ < nd; dims++) {
4411: if (ch != ',')
4412: err(a->cierr, 115, where);
4413: dn1 = dn + 1;
4414: span /= *dims;
4415: if (k = getdimen(&ch, dn1, dn->delta**dims,
4416: span, &b1))
4417: err(a->cierr, k, where);
4418: ex *= *dims;
4419: b += b1*ex;
4420: no *= dn1->extent;
4421: dn = dn1;
4422: }
4423: if (ch != ')')
4424: err(a->cierr, 115, where);
4425: b -= b0;
4426: if (b < 0 || b >= nomax)
4427: err(a->cierr, 125, where);
4428: iva += size * b;
4429: dims = dims1;
4430: while(GETC(ch) <= ' ' && ch >= 0);
4431: no1 = 1;
4432: dn0 = dimens;
4433: if (type == TYCHAR && ch == '(' /*)*/) {
4434: if (k = getdimen(&ch, &substr, size, size, &b))
4435: err(a->cierr, k, where);
4436: if (ch != ')')
4437: err(a->cierr, 115, where);
4438: b1 = substr.extent;
4439: if (--b < 0 || b + b1 > size)
4440: return 124;
4441: iva += b;
4442: b0 = size;
4443: size = b1;
4444: while(GETC(ch) <= ' ' && ch >= 0);
4445: if (b1 < b0)
4446: goto delta_adj;
4447: }
4448: for(; dn0 < dn; dn0++) {
4449: if (dn0->extent != *dims++ || dn0->stride != 1)
4450: break;
4451: no1 *= dn0->extent;
4452: }
4453: if (dn0 == dimens && dimens[0].stride == 1) {
4454: no1 = dimens[0].extent;
4455: dn0++;
4456: }
4457: delta_adj:
4458: ex = 0;
4459: for(dn1 = dn0; dn1 <= dn; dn1++)
4460: ex += (dn1->extent-1)
4461: * (dn1->delta *= dn1->stride);
4462: for(dn1 = dn; dn1 > dn0; dn1--) {
4463: ex -= (dn1->extent - 1) * dn1->delta;
4464: dn1->delta -= ex;
4465: }
4466: }
4467: else if (dims = v->dims) {
4468: no = no1 = dims[1];
4469: ivae = iva + no*size;
4470: }
4471: else
4472: scalar:
4473: no = no1 = 1;
4474: if (ch != '=')
4475: err(a->cierr, 115, where);
4476: got1 = nml_read = 1;
4477: lcount = 0;
4478: readloop:
4479: for(;;) {
4480: if (iva >= ivae || iva < 0) {
4481: lquit = 1;
4482: goto mustend;
4483: }
4484: else if (iva + no1*size > ivae)
4485: no1 = (ivae - iva)/size;
4486: lquit = 0;
4487: l_read(&no1, vaddr + iva, size, type);
4488: if (lquit == 1)
4489: return 0;
4490: mustend:
4491: if (GETC(ch) == '/' || ch == '$') {
4492: lquit = 1;
4493: return 0;
4494: }
4495: else if (lquit) {
4496: while(ch <= ' ' && ch >= 0)
4497: GETC(ch);
4498: Ungetc(ch,cf);
4499: if (!Alpha[ch & 0xff] && ch >= 0)
4500: err(a->cierr, 125, where);
4501: break;
4502: }
4503: Ungetc(ch,cf);
4504: if ((no -= no1) <= 0)
4505: break;
4506: for(dn1 = dn0; dn1 <= dn; dn1++) {
4507: if (++dn1->curval < dn1->extent) {
4508: iva += dn1->delta;
4509: goto readloop;
4510: }
4511: dn1->curval = 0;
4512: }
4513: break;
4514: }
4515: }
4516: }
4517:
4518: integer
4519: #ifdef KR_headers
4520: s_rsne(a) cilist *a;
4521: #else
4522: s_rsne(cilist *a)
4523: #endif
4524: {
4525: int n;
4526: external=1;
4527: if(n = c_le(a))
4528: return n;
4529: if(curunit->uwrt && nowreading(curunit))
4530: err(a->cierr,errno,where0);
4531: l_getc = t_getc;
4532: l_ungetc = un_getc;
4533: if (n = x_rsne(a))
4534: return n;
4535: return e_rsle();
4536: }
4537: ./ ADD NAME=sfe.c TIME=708865458
4538: /* sequential formatted external common routines*/
4539: #include "f2c.h"
4540: #include "fio.h"
4541:
4542: extern char *fmtbuf;
4543:
4544: integer e_rsfe(Void)
4545: { int n;
4546: n=en_fio();
4547: if (cf == stdout)
4548: fflush(stdout);
4549: else if (cf == stderr)
4550: fflush(stderr);
4551: fmtbuf=NULL;
4552: return(n);
4553: }
4554: #ifdef KR_headers
4555: c_sfe(a) cilist *a; /* check */
4556: #else
4557: c_sfe(cilist *a) /* check */
4558: #endif
4559: { unit *p;
4560: if(a->ciunit >= MXUNIT || a->ciunit<0)
4561: err(a->cierr,101,"startio");
4562: p = &units[a->ciunit];
4563: if(p->ufd==NULL && fk_open(SEQ,FMT,a->ciunit)) err(a->cierr,114,"sfe")
4564: if(!p->ufmt) err(a->cierr,102,"sfe")
4565: return(0);
4566: }
4567: integer e_wsfe(Void)
4568: { return(e_rsfe());
4569: }
4570: ./ ADD NAME=sig_die.c TIME=708905928
4571: #include "stdio.h"
4572: #include "signal.h"
4573:
4574: #ifndef SIGIOT
4575: #define SIGIOT SIGABRT
4576: #endif
4577:
4578: #ifdef __cplusplus
4579: extern "C" {
4580: #endif
4581: #ifdef KR_headers
4582: void sig_die(s, kill) register char *s; int kill;
4583: #else
4584: #include "stdlib.h"
4585: extern void f_exit(void);
4586:
4587: void sig_die(register char *s, int kill)
4588: #endif
4589: {
4590: /* print error message, then clear buffers */
4591: fprintf(stderr, "%s\n", s);
4592: fflush(stderr);
4593: f_exit();
4594: fflush(stderr);
4595:
4596: if(kill)
4597: {
4598: /* now get a core */
4599: signal(SIGIOT, SIG_DFL);
4600: abort();
4601: }
4602: else
4603: exit(1);
4604: }
4605: #ifdef __cplusplus
4606: }
4607: #endif
4608: ./ ADD NAME=sue.c TIME=708865914
4609: #include "f2c.h"
4610: #include "fio.h"
4611: extern uiolen reclen;
4612: long recloc;
4613:
4614: #ifdef KR_headers
4615: c_sue(a) cilist *a;
4616: #else
4617: c_sue(cilist *a)
4618: #endif
4619: {
4620: if(a->ciunit >= MXUNIT || a->ciunit < 0)
4621: err(a->cierr,101,"startio");
4622: external=sequential=1;
4623: formatted=0;
4624: curunit = &units[a->ciunit];
4625: elist=a;
4626: if(curunit->ufd==NULL && fk_open(SEQ,UNF,a->ciunit))
4627: err(a->cierr,114,"sue");
4628: cf=curunit->ufd;
4629: if(curunit->ufmt) err(a->cierr,103,"sue")
4630: if(!curunit->useek) err(a->cierr,103,"sue")
4631: return(0);
4632: }
4633: #ifdef KR_headers
4634: integer s_rsue(a) cilist *a;
4635: #else
4636: integer s_rsue(cilist *a)
4637: #endif
4638: {
4639: int n;
4640: if(!init) f_init();
4641: reading=1;
4642: if(n=c_sue(a)) return(n);
4643: recpos=0;
4644: if(curunit->uwrt && nowreading(curunit))
4645: err(a->cierr, errno, "read start");
4646: if(fread((char *)&reclen,sizeof(uiolen),1,cf)
4647: != 1)
4648: { if(feof(cf))
4649: { curunit->uend = 1;
4650: err(a->ciend, EOF, "start");
4651: }
4652: clearerr(cf);
4653: err(a->cierr, errno, "start");
4654: }
4655: return(0);
4656: }
4657: #ifdef KR_headers
4658: integer s_wsue(a) cilist *a;
4659: #else
4660: integer s_wsue(cilist *a)
4661: #endif
4662: {
4663: int n;
4664: if(!init) f_init();
4665: if(n=c_sue(a)) return(n);
4666: reading=0;
4667: reclen=0;
4668: if(curunit->uwrt != 1 && nowwriting(curunit))
4669: err(a->cierr, errno, "write start");
4670: recloc=ftell(cf);
4671: (void) fseek(cf,(long)sizeof(uiolen),SEEK_CUR);
4672: return(0);
4673: }
4674: integer e_wsue(Void)
4675: { long loc;
4676: (void) fwrite((char *)&reclen,sizeof(uiolen),1,cf);
4677: loc=ftell(cf);
4678: (void) fseek(cf,recloc,SEEK_SET);
4679: (void) fwrite((char *)&reclen,sizeof(uiolen),1,cf);
4680: (void) fseek(cf,loc,SEEK_SET);
4681: return(0);
4682: }
4683: integer e_rsue(Void)
4684: {
4685: (void) fseek(cf,(long)(reclen-recpos+sizeof(uiolen)),SEEK_CUR);
4686: return(0);
4687: }
4688: ./ ADD NAME=typesize.c TIME=640009768
4689: #include "f2c.h"
4690:
4691: ftnlen typesize[] = { 0, 0, sizeof(shortint), sizeof(integer),
4692: sizeof(real), sizeof(doublereal),
4693: sizeof(complex), sizeof(doublecomplex),
4694: sizeof(logical), sizeof(char) };
4695: ./ ADD NAME=uio.c TIME=708866134
4696: #include "f2c.h"
4697: #include "fio.h"
4698: uiolen reclen;
4699:
4700: #ifdef KR_headers
4701: do_us(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
4702: #else
4703: do_us(ftnint *number, char *ptr, ftnlen len)
4704: #endif
4705: {
4706: if(reading)
4707: {
4708: recpos += *number * len;
4709: if(recpos>reclen)
4710: err(elist->ciend, 110, "do_us");
4711: if (fread(ptr,(int)len,(int)(*number),cf) != *number)
4712: err(elist->ciend, EOF, "do_us");
4713: return(0);
4714: }
4715: else
4716: {
4717: reclen += *number * len;
4718: (void) fwrite(ptr,(int)len,(int)(*number),cf);
4719: return(0);
4720: }
4721: }
4722: #ifdef KR_headers
4723: integer do_ud(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
4724: #else
4725: integer do_ud(ftnint *number, char *ptr, ftnlen len)
4726: #endif
4727: {
4728: recpos += *number * len;
4729: if(recpos > curunit->url && curunit->url!=1)
4730: err(elist->cierr,110,"do_ud");
4731: if(reading)
4732: {
4733: if(fread(ptr,(int)len,(int)(*number),cf) != *number)
4734: err(elist->cierr,EOF,"do_ud")
4735: else return(0);
4736: }
4737: (void) fwrite(ptr,(int)len,(int)(*number),cf);
4738: return(0);
4739: }
4740: #ifdef KR_headers
4741: integer do_uio(number,ptr,len) ftnint *number; char *ptr; ftnlen len;
4742: #else
4743: integer do_uio(ftnint *number, char *ptr, ftnlen len)
4744: #endif
4745: {
4746: if(sequential)
4747: return(do_us(number,ptr,len));
4748: else return(do_ud(number,ptr,len));
4749: }
4750: ./ ADD NAME=util.c TIME=708907661
4751: #ifndef MSDOS
4752: #include "sys/types.h"
4753: #include "sys/stat.h"
4754: #endif
4755: #include "f2c.h"
4756: #include "fio.h"
4757:
4758: VOID
4759: #ifdef KR_headers
4760: g_char(a,alen,b) char *a,*b; ftnlen alen;
4761: #else
4762: g_char(char *a, ftnlen alen, char *b)
4763: #endif
4764: {
4765: char *x = a + alen, *y = b + alen;
4766:
4767: for(;; y--) {
4768: if (x <= a) {
4769: *b = 0;
4770: return;
4771: }
4772: if (*--x != ' ')
4773: break;
4774: }
4775: *y-- = 0;
4776: do *y-- = *x;
4777: while(x-- > a);
4778: }
4779:
4780: VOID
4781: #ifdef KR_headers
4782: b_char(a,b,blen) char *a,*b; ftnlen blen;
4783: #else
4784: b_char(char *a, char *b, ftnlen blen)
4785: #endif
4786: { int i;
4787: for(i=0;i<blen && *a!=0;i++) *b++= *a++;
4788: for(;i<blen;i++) *b++=' ';
4789: }
4790: #ifndef MSDOS
4791: #ifdef KR_headers
4792: long inode(a, dev) char *a; int *dev;
4793: #else
4794: long inode(char *a, int *dev)
4795: #endif
4796: { struct stat x;
4797: if(stat(a,&x)<0) return(-1);
4798: *dev = x.st_dev;
4799: return(x.st_ino);
4800: }
4801: #endif
4802:
4803: #define INTBOUND sizeof(int)-1
4804: VOID
4805: #ifdef KR_headers
4806: mvgbt(n,len,a,b) char *a,*b;
4807: #else
4808: mvgbt(int n, int len, char *a, char *b)
4809: #endif
4810: { register int num=n*len;
4811: if( ((int)a&INTBOUND)==0 && ((int)b&INTBOUND)==0 && (num&INTBOUND)==0 )
4812: { register int *x=(int *)a,*y=(int *)b;
4813: num /= sizeof(int);
4814: if(x>y) for(;num>0;num--) *y++= *x++;
4815: else for(num--;num>=0;num--) *(y+num)= *(x+num);
4816: }
4817: else
4818: { register char *x=a,*y=b;
4819: if(x>y) for(;num>0;num--) *y++= *x++;
4820: else for(num--;num>=0;num--) *(y+num)= *(x+num);
4821: }
4822: }
4823: ./ ADD NAME=wref.c TIME=708866396
4824: #include "f2c.h"
4825: #include "fio.h"
4826: #include "fmt.h"
4827: #include "fp.h"
4828: #ifndef VAX
4829: #include "ctype.h"
4830: #endif
4831:
4832: #ifndef KR_headers
4833: #undef abs
4834: #include "stdlib.h"
4835: #include "string.h"
4836: #endif
4837:
4838: #ifdef KR_headers
4839: wrt_E(p,w,d,e,len) ufloat *p; ftnlen len;
4840: #else
4841: wrt_E(ufloat *p, int w, int d, int e, ftnlen len)
4842: #endif
4843: {
4844: char buf[FMAX+EXPMAXDIGS+4], *s, *se;
4845: int d1, delta, e1, i, sign, signspace;
4846: double dd;
4847: #ifndef VAX
4848: int e0 = e;
4849: #endif
4850:
4851: if(e <= 0)
4852: e = 2;
4853: if(scale) {
4854: if(scale >= d + 2 || scale <= -d)
4855: goto nogood;
4856: }
4857: if(scale <= 0)
4858: --d;
4859: if (len == sizeof(real))
4860: dd = p->pf;
4861: else
4862: dd = p->pd;
4863: if (dd >= 0.) {
4864: sign = 0;
4865: signspace = cplus;
4866: #ifndef VAX
4867: if (!dd)
4868: dd = 0.; /* avoid -0 */
4869: #endif
4870: }
4871: else {
4872: signspace = sign = 1;
4873: dd = -dd;
4874: }
4875: delta = w - (2 /* for the . and the d adjustment above */
4876: + 2 /* for the E+ */ + signspace + d + e);
4877: if (delta < 0) {
4878: nogood:
4879: while(--w >= 0)
4880: PUT('*');
4881: return(0);
4882: }
4883: if (scale < 0)
4884: d += scale;
4885: if (d > FMAX) {
4886: d1 = d - FMAX;
4887: d = FMAX;
4888: }
4889: else
4890: d1 = 0;
4891: sprintf(buf,"%#.*E", d, dd);
4892: #ifndef VAX
4893: /* check for NaN, Infinity */
4894: if (!isdigit(buf[0])) {
4895: delta = w - strlen(buf) - signspace;
4896: if (delta < 0)
4897: goto nogood;
4898: while(--delta >= 0)
4899: PUT(' ');
4900: if (signspace)
4901: PUT(sign ? '-' : '+');
4902: for(s = buf; *s; s++)
4903: PUT(*s);
4904: return 0;
4905: }
4906: #endif
4907: se = buf + d + 3;
4908: if (scale != 1 && dd)
4909: sprintf(se, "%+.2d", atoi(se) + 1 - scale);
4910: s = ++se;
4911: if (e < 2) {
4912: if (*s != '0')
4913: goto nogood;
4914: }
4915: #ifndef VAX
4916: /* accommodate 3 significant digits in exponent */
4917: if (s[2]) {
4918: #ifdef Pedantic
4919: if (!e0 && !s[3])
4920: for(s -= 2, e1 = 2; s[0] = s[1]; s++);
4921:
4922: /* Pedantic gives the behavior that Fortran 77 specifies, */
4923: /* i.e., requires that E be specified for exponent fields */
4924: /* of more than 3 digits. With Pedantic undefined, we get */
4925: /* the behavior that Cray displays -- you get a bigger */
4926: /* exponent field if it fits. */
4927: #else
4928: if (!e0) {
4929: for(s -= 2, e1 = 2; s[0] = s[1]; s++)
4930: #ifdef CRAY
4931: delta--;
4932: if ((delta += 4) < 0)
4933: goto nogood
4934: #endif
4935: ;
4936: }
4937: #endif
4938: else if (e0 >= 0)
4939: goto shift;
4940: else
4941: e1 = e;
4942: }
4943: else
4944: shift:
4945: #endif
4946: for(s += 2, e1 = 2; *s; ++e1, ++s)
4947: if (e1 >= e)
4948: goto nogood;
4949: while(--delta >= 0)
4950: PUT(' ');
4951: if (signspace)
4952: PUT(sign ? '-' : '+');
4953: s = buf;
4954: i = scale;
4955: if (scale <= 0) {
4956: PUT('.');
4957: for(; i < 0; ++i)
4958: PUT('0');
4959: PUT(*s);
4960: s += 2;
4961: }
4962: else if (scale > 1) {
4963: PUT(*s);
4964: s += 2;
4965: while(--i > 0)
4966: PUT(*s++);
4967: PUT('.');
4968: }
4969: if (d1) {
4970: se -= 2;
4971: while(s < se) PUT(*s++);
4972: se += 2;
4973: do PUT('0'); while(--d1 > 0);
4974: }
4975: while(s < se)
4976: PUT(*s++);
4977: if (e < 2)
4978: PUT(s[1]);
4979: else {
4980: while(++e1 <= e)
4981: PUT('0');
4982: while(*s)
4983: PUT(*s++);
4984: }
4985: return 0;
4986: }
4987:
4988: #ifdef KR_headers
4989: wrt_F(p,w,d,len) ufloat *p; ftnlen len;
4990: #else
4991: wrt_F(ufloat *p, int w, int d, ftnlen len)
4992: #endif
4993: {
4994: int d1, sign, n;
4995: double x;
4996: char *b, buf[MAXINTDIGS+MAXFRACDIGS+4], *s;
4997:
4998: x= (len==sizeof(real)?p->pf:p->pd);
4999: if (d < MAXFRACDIGS)
5000: d1 = 0;
5001: else {
5002: d1 = d - MAXFRACDIGS;
5003: d = MAXFRACDIGS;
5004: }
5005: if (x < 0.)
5006: { x = -x; sign = 1; }
5007: else {
5008: sign = 0;
5009: #ifndef VAX
5010: if (!x)
5011: x = 0.;
5012: #endif
5013: }
5014:
5015: if (n = scale)
5016: if (n > 0)
5017: do x *= 10.; while(--n > 0);
5018: else
5019: do x *= 0.1; while(++n < 0);
5020:
5021: #ifdef USE_STRLEN
5022: sprintf(b = buf, "%#.*f", d, x);
5023: n = strlen(b) + d1;
5024: #else
5025: n = sprintf(b = buf, "%#.*f", d, x) + d1;
5026: #endif
5027:
5028: if (buf[0] == '0' && d)
5029: { ++b; --n; }
5030: if (sign) {
5031: /* check for all zeros */
5032: for(s = b;;) {
5033: while(*s == '0') s++;
5034: switch(*s) {
5035: case '.':
5036: s++; continue;
5037: case 0:
5038: sign = 0;
5039: }
5040: break;
5041: }
5042: }
5043: if (sign || cplus)
5044: ++n;
5045: if (n > w) {
5046: while(--w >= 0)
5047: PUT('*');
5048: return 0;
5049: }
5050: for(w -= n; --w >= 0; )
5051: PUT(' ');
5052: if (sign)
5053: PUT('-');
5054: else if (cplus)
5055: PUT('+');
5056: while(n = *b++)
5057: PUT(n);
5058: while(--d1 >= 0)
5059: PUT('0');
5060: return 0;
5061: }
5062: ./ ADD NAME=wrtfmt.c TIME=708868978
5063: #include "f2c.h"
5064: #include "fio.h"
5065: #include "fmt.h"
5066: extern int cursor;
5067: #ifdef KR_headers
5068: extern char *icvt();
5069: #else
5070: extern char *icvt(long, int*, int*, int);
5071: #endif
5072: int hiwater;
5073: icilist *svic;
5074: char *icptr;
5075: mv_cur(Void) /* shouldn't use fseek because it insists on calling fflush */
5076: /* instead we know too much about stdio */
5077: {
5078: if(external == 0) {
5079: if(cursor < 0) {
5080: if(hiwater < recpos)
5081: hiwater = recpos;
5082: recpos += cursor;
5083: icptr += cursor;
5084: cursor = 0;
5085: if(recpos < 0)
5086: err(elist->cierr, 110, "left off");
5087: }
5088: else if(cursor > 0) {
5089: if(recpos + cursor >= svic->icirlen)
5090: err(elist->cierr, 110, "recend");
5091: if(hiwater <= recpos)
5092: for(; cursor > 0; cursor--)
5093: (*putn)(' ');
5094: else if(hiwater <= recpos + cursor) {
5095: cursor -= hiwater - recpos;
5096: icptr += hiwater - recpos;
5097: recpos = hiwater;
5098: for(; cursor > 0; cursor--)
5099: (*putn)(' ');
5100: }
5101: else {
5102: icptr += cursor;
5103: recpos += cursor;
5104: }
5105: cursor = 0;
5106: }
5107: return(0);
5108: }
5109: if(cursor > 0) {
5110: if(hiwater <= recpos)
5111: for(;cursor>0;cursor--) (*putn)(' ');
5112: else if(hiwater <= recpos + cursor) {
5113: #ifndef NON_UNIX_STDIO
5114: if(cf->_ptr + hiwater - recpos < buf_end(cf))
5115: cf->_ptr += hiwater - recpos;
5116: else
5117: #endif
5118: (void) fseek(cf, (long) (hiwater - recpos), SEEK_CUR);
5119: cursor -= hiwater - recpos;
5120: recpos = hiwater;
5121: for(; cursor > 0; cursor--)
5122: (*putn)(' ');
5123: }
5124: else {
5125: #ifndef NON_UNIX_STDIO
5126: if(cf->_ptr + cursor < buf_end(cf))
5127: cf->_ptr += cursor;
5128: else
5129: #endif
5130: (void) fseek(cf, (long)cursor, SEEK_CUR);
5131: recpos += cursor;
5132: }
5133: }
5134: if(cursor<0)
5135: {
5136: if(cursor+recpos<0) err(elist->cierr,110,"left off");
5137: #ifndef NON_UNIX_STDIO
5138: if(cf->_ptr + cursor >= cf->_base)
5139: cf->_ptr += cursor;
5140: else
5141: #endif
5142: if(curunit && curunit->useek)
5143: (void) fseek(cf,(long)cursor,SEEK_CUR);
5144: else
5145: err(elist->cierr,106,"fmt");
5146: if(hiwater < recpos)
5147: hiwater = recpos;
5148: recpos += cursor;
5149: cursor=0;
5150: }
5151: return(0);
5152: }
5153: static int
5154: #ifdef KR_headers
5155: wrt_I(n,w,len, base) Uint *n; ftnlen len; register int base;
5156: #else
5157: wrt_I(Uint *n, int w, ftnlen len, register int base)
5158: #endif
5159: { int ndigit,sign,spare,i;
5160: long x;
5161: char *ans;
5162: if(len==sizeof(integer)) x=n->il;
5163: else if(len == sizeof(char)) x = n->ic;
5164: else x=n->is;
5165: ans=icvt(x,&ndigit,&sign, base);
5166: spare=w-ndigit;
5167: if(sign || cplus) spare--;
5168: if(spare<0)
5169: for(i=0;i<w;i++) (*putn)('*');
5170: else
5171: { for(i=0;i<spare;i++) (*putn)(' ');
5172: if(sign) (*putn)('-');
5173: else if(cplus) (*putn)('+');
5174: for(i=0;i<ndigit;i++) (*putn)(*ans++);
5175: }
5176: return(0);
5177: }
5178: static int
5179: #ifdef KR_headers
5180: wrt_IM(n,w,m,len) Uint *n; ftnlen len;
5181: #else
5182: wrt_IM(Uint *n, int w, int m, ftnlen len)
5183: #endif
5184: { int ndigit,sign,spare,i,xsign;
5185: long x;
5186: char *ans;
5187: if(sizeof(integer)==len) x=n->il;
5188: else if(len == sizeof(char)) x = n->ic;
5189: else x=n->is;
5190: ans=icvt(x,&ndigit,&sign, 10);
5191: if(sign || cplus) xsign=1;
5192: else xsign=0;
5193: if(ndigit+xsign>w || m+xsign>w)
5194: { for(i=0;i<w;i++) (*putn)('*');
5195: return(0);
5196: }
5197: if(x==0 && m==0)
5198: { for(i=0;i<w;i++) (*putn)(' ');
5199: return(0);
5200: }
5201: if(ndigit>=m)
5202: spare=w-ndigit-xsign;
5203: else
5204: spare=w-m-xsign;
5205: for(i=0;i<spare;i++) (*putn)(' ');
5206: if(sign) (*putn)('-');
5207: else if(cplus) (*putn)('+');
5208: for(i=0;i<m-ndigit;i++) (*putn)('0');
5209: for(i=0;i<ndigit;i++) (*putn)(*ans++);
5210: return(0);
5211: }
5212: static int
5213: #ifdef KR_headers
5214: wrt_AP(s) char *s;
5215: #else
5216: wrt_AP(char *s)
5217: #endif
5218: { char quote;
5219: if(cursor && mv_cur()) return(mv_cur());
5220: quote = *s++;
5221: for(;*s;s++)
5222: { if(*s!=quote) (*putn)(*s);
5223: else if(*++s==quote) (*putn)(*s);
5224: else return(1);
5225: }
5226: return(1);
5227: }
5228: static int
5229: #ifdef KR_headers
5230: wrt_H(a,s) char *s;
5231: #else
5232: wrt_H(int a, char *s)
5233: #endif
5234: {
5235: if(cursor && mv_cur()) return(mv_cur());
5236: while(a--) (*putn)(*s++);
5237: return(1);
5238: }
5239: #ifdef KR_headers
5240: wrt_L(n,len, sz) Uint *n; ftnlen sz;
5241: #else
5242: wrt_L(Uint *n, int len, ftnlen sz)
5243: #endif
5244: { int i;
5245: long x;
5246: if(sizeof(integer)==sz) x=n->il;
5247: else if(sz == sizeof(char)) x = n->ic;
5248: else x=n->is;
5249: for(i=0;i<len-1;i++)
5250: (*putn)(' ');
5251: if(x) (*putn)('T');
5252: else (*putn)('F');
5253: return(0);
5254: }
5255: static int
5256: #ifdef KR_headers
5257: wrt_A(p,len) char *p; ftnlen len;
5258: #else
5259: wrt_A(char *p, ftnlen len)
5260: #endif
5261: {
5262: while(len-- > 0) (*putn)(*p++);
5263: return(0);
5264: }
5265: static int
5266: #ifdef KR_headers
5267: wrt_AW(p,w,len) char * p; ftnlen len;
5268: #else
5269: wrt_AW(char * p, int w, ftnlen len)
5270: #endif
5271: {
5272: while(w>len)
5273: { w--;
5274: (*putn)(' ');
5275: }
5276: while(w-- > 0)
5277: (*putn)(*p++);
5278: return(0);
5279: }
5280:
5281: static int
5282: #ifdef KR_headers
5283: wrt_G(p,w,d,e,len) ufloat *p; ftnlen len;
5284: #else
5285: wrt_G(ufloat *p, int w, int d, int e, ftnlen len)
5286: #endif
5287: { double up = 1,x;
5288: int i,oldscale=scale,n,j;
5289: x= len==sizeof(real)?p->pf:p->pd;
5290: if(x < 0 ) x = -x;
5291: if(x<.1) return(wrt_E(p,w,d,e,len));
5292: for(i=0;i<=d;i++,up*=10)
5293: { if(x>=up) continue;
5294: scale=0;
5295: if(e==0) n=4;
5296: else n=e+2;
5297: i=wrt_F(p,w-n,d-i,len);
5298: for(j=0;j<n;j++) (*putn)(' ');
5299: scale=oldscale;
5300: return(i);
5301: }
5302: return(wrt_E(p,w,d,e,len));
5303: }
5304: #ifdef KR_headers
5305: w_ed(p,ptr,len) struct syl *p; char *ptr; ftnlen len;
5306: #else
5307: w_ed(struct syl *p, char *ptr, ftnlen len)
5308: #endif
5309: {
5310: if(cursor && mv_cur()) return(mv_cur());
5311: switch(p->op)
5312: {
5313: default:
5314: fprintf(stderr,"w_ed, unexpected code: %d\n", p->op);
5315: sig_die(fmtbuf, 1);
5316: case I: return(wrt_I((Uint *)ptr,p->p1,len, 10));
5317: case IM:
5318: return(wrt_IM((Uint *)ptr,p->p1,p->p2,len));
5319: case O: return(wrt_I((Uint *)ptr, p->p1, len, 8));
5320: case L: return(wrt_L((Uint *)ptr,p->p1, len));
5321: case A: return(wrt_A(ptr,len));
5322: case AW:
5323: return(wrt_AW(ptr,p->p1,len));
5324: case D:
5325: case E:
5326: case EE:
5327: return(wrt_E((ufloat *)ptr,p->p1,p->p2,p->p3,len));
5328: case G:
5329: case GE:
5330: return(wrt_G((ufloat *)ptr,p->p1,p->p2,p->p3,len));
5331: case F: return(wrt_F((ufloat *)ptr,p->p1,p->p2,len));
5332: }
5333: }
5334: #ifdef KR_headers
5335: w_ned(p) struct syl *p;
5336: #else
5337: w_ned(struct syl *p)
5338: #endif
5339: {
5340: switch(p->op)
5341: {
5342: default: fprintf(stderr,"w_ned, unexpected code: %d\n", p->op);
5343: sig_die(fmtbuf, 1);
5344: case SLASH:
5345: return((*donewrec)());
5346: case T: cursor = p->p1-recpos - 1;
5347: return(1);
5348: case TL: cursor -= p->p1;
5349: if(cursor < -recpos) /* TL1000, 1X */
5350: cursor = -recpos;
5351: return(1);
5352: case TR:
5353: case X:
5354: cursor += p->p1;
5355: return(1);
5356: case APOS:
5357: return(wrt_AP(*(char **)&p->p2));
5358: case H:
5359: return(wrt_H(p->p1,*(char **)&p->p2));
5360: }
5361: }
5362: ./ ADD NAME=wsfe.c TIME=708863158
5363: /*write sequential formatted external*/
5364: #include "f2c.h"
5365: #include "fio.h"
5366: #include "fmt.h"
5367: extern int hiwater;
5368:
5369: #ifdef KR_headers
5370: x_putc(c)
5371: #else
5372: x_putc(int c)
5373: #endif
5374: {
5375: /* this uses \n as an indicator of record-end */
5376: if(c == '\n' && recpos < hiwater) { /* fseek calls fflush, a loss */
5377: #ifndef NON_UNIX_STDIO
5378: if(cf->_ptr + hiwater - recpos < buf_end(cf))
5379: cf->_ptr += hiwater - recpos;
5380: else
5381: #endif
5382: (void) fseek(cf, (long)(hiwater - recpos), SEEK_CUR);
5383: }
5384: recpos++;
5385: return putc(c,cf);
5386: }
5387: x_wSL(Void)
5388: {
5389: (*putn)('\n');
5390: recpos=0;
5391: cursor = 0;
5392: hiwater = 0;
5393: return(1);
5394: }
5395: xw_end(Void)
5396: {
5397: if(nonl == 0)
5398: (*putn)('\n');
5399: hiwater = recpos = cursor = 0;
5400: return(0);
5401: }
5402: xw_rev(Void)
5403: {
5404: if(workdone) (*putn)('\n');
5405: hiwater = recpos = cursor = 0;
5406: return(workdone=0);
5407: }
5408:
5409: #ifdef KR_headers
5410: integer s_wsfe(a) cilist *a; /*start*/
5411: #else
5412: integer s_wsfe(cilist *a) /*start*/
5413: #endif
5414: { int n;
5415: if(!init) f_init();
5416: if(n=c_sfe(a)) return(n);
5417: reading=0;
5418: sequential=1;
5419: formatted=1;
5420: external=1;
5421: elist=a;
5422: hiwater = cursor=recpos=0;
5423: nonl = 0;
5424: scale=0;
5425: fmtbuf=a->cifmt;
5426: curunit = &units[a->ciunit];
5427: cf=curunit->ufd;
5428: if(pars_f(fmtbuf)<0) err(a->cierr,100,"startio");
5429: putn= x_putc;
5430: doed= w_ed;
5431: doned= w_ned;
5432: doend=xw_end;
5433: dorevert=xw_rev;
5434: donewrec=x_wSL;
5435: fmt_bg();
5436: cplus=0;
5437: cblank=curunit->ublnk;
5438: if(curunit->uwrt != 1 && nowwriting(curunit))
5439: err(a->cierr,errno,"write start");
5440: return(0);
5441: }
5442: ./ ADD NAME=wsle.c TIME=708862784
5443: #include "f2c.h"
5444: #include "fio.h"
5445: #include "fmt.h"
5446: #include "lio.h"
5447:
5448: #ifdef KR_headers
5449: integer s_wsle(a) cilist *a;
5450: #else
5451: integer s_wsle(cilist *a)
5452: #endif
5453: {
5454: int n;
5455: if(!init) f_init();
5456: if(n=c_le(a)) return(n);
5457: reading=0;
5458: external=1;
5459: formatted=1;
5460: putn = t_putc;
5461: lioproc = l_write;
5462: L_len = LINE;
5463: donewrec = x_wSL;
5464: if(curunit->uwrt != 1 && nowwriting(curunit))
5465: err(a->cierr, errno, "list output start");
5466: return(0);
5467: }
5468:
5469: integer e_wsle(Void)
5470: {
5471: t_putc('\n');
5472: recpos=0;
5473: if (cf == stdout)
5474: fflush(stdout);
5475: else if (cf == stderr)
5476: fflush(stderr);
5477: return(0);
5478: }
5479: ./ ADD NAME=wsne.c TIME=708862700
5480: #include "f2c.h"
5481: #include "fio.h"
5482: #include "lio.h"
5483:
5484: integer
5485: #ifdef KR_headers
5486: s_wsne(a) cilist *a;
5487: #else
5488: s_wsne(cilist *a)
5489: #endif
5490: {
5491: int n;
5492: extern integer e_wsle(Void);
5493:
5494: if(!init)
5495: f_init();
5496: if(n=c_le(a))
5497: return(n);
5498: reading=0;
5499: external=1;
5500: formatted=1;
5501: putn = t_putc;
5502: L_len = LINE;
5503: donewrec = x_wSL;
5504: if(curunit->uwrt != 1 && nowwriting(curunit))
5505: err(a->cierr, errno, "namelist output start");
5506: x_wsne(a);
5507: return e_wsle();
5508: }
5509: ./ ADD NAME=xwsne.c TIME=708824981
5510: #include "f2c.h"
5511: #include "fio.h"
5512: #include "lio.h"
5513: #include "fmt.h"
5514:
5515: #ifdef KR_headers
5516: x_wsne(a) cilist *a;
5517: #else
5518: #include "string.h"
5519:
5520: VOID
5521: x_wsne(cilist *a)
5522: #endif
5523: {
5524: Namelist *nl;
5525: char *s;
5526: Vardesc *v, **vd, **vde;
5527: ftnint *number, type;
5528: ftnlen *dims;
5529: ftnlen size;
5530: static ftnint one = 1;
5531: extern ftnlen typesize[];
5532:
5533: nl = (Namelist *)a->cifmt;
5534: PUT('&');
5535: for(s = nl->name; *s; s++)
5536: PUT(*s);
5537: PUT(' ');
5538: vd = nl->vars;
5539: vde = vd + nl->nvars;
5540: while(vd < vde) {
5541: v = *vd++;
5542: s = v->name;
5543: if (recpos+strlen(s)+2 >= L_len)
5544: (*donewrec)();
5545: while(*s)
5546: PUT(*s++);
5547: PUT(' ');
5548: PUT('=');
5549: number = (dims = v->dims) ? dims + 1 : &one;
5550: type = v->type;
5551: if (type < 0) {
5552: size = -type;
5553: type = TYCHAR;
5554: }
5555: else
5556: size = typesize[type];
5557: l_write(number, v->addr, size, type);
5558: if (vd < vde) {
5559: if (recpos+2 >= L_len)
5560: (*donewrec)();
5561: PUT(',');
5562: PUT(' ');
5563: }
5564: else if (recpos+1 >= L_len)
5565: (*donewrec)();
5566: }
5567: PUT('/');
5568: }
5569: ./ ENDUP
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.