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