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