![[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.