integer G77_link_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) { #if defined (HAVE_LINK) char *buff1, *buff2; int i; buff1 = malloc (Lpath1 + 1); if (buff1 == NULL) return -1; g_char (path1, Lpath1, buff1); buff2 = malloc (Lpath2 + 1); if (buff2 == NULL) return -1; g_char (path2, Lpath2, buff2); i = link (buff1, buff2); free (buff1); free (buff2); return i ? errno : 0; #else /* ! HAVE_LINK */ errno = ENOSYS; return -1; #endif }
integer G77_rename_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) { char *buff1, *buff2; int i; buff1 = malloc (Lpath1 + 1); if (buff1 == NULL) return -1; g_char (path1, Lpath1, buff1); buff2 = malloc (Lpath2 + 1); if (buff2 == NULL) return -1; g_char (path2, Lpath2, buff2); i = rename (buff1, buff2); free (buff1); free (buff2); return i ? errno : 0; }
int32 unlink_(char *fname, int32 namlen) { if (!bufarg && !(bufarg=malloc(bufarglen=namlen+1))) return((errno=F_ERSPACE)); else if (bufarglen <= namlen && !(bufarg=realloc(bufarg, bufarglen=namlen+1))) return((int32)(errno=F_ERSPACE)); g_char(fname, namlen, bufarg); return( (int32) unlink(bufarg) ); }
static void opn_err (int m, char *s, olist * a) { if (a->ofnm) { /* supply file name to error message */ if (a->ofnmlen >= f__buflen) f__bufadj ((int) a->ofnmlen, 0); g_char (a->ofnm, a->ofnmlen, f__curunit->ufnm = f__buf); } f__fatal (m, s); }
integer G77_unlink_0 (const char *str, const ftnlen Lstr) #endif { char *buff; char *bp, *blast; int i; buff = malloc (Lstr+1); if (buff == NULL) return -1; g_char (str, Lstr, buff); i = unlink (buff); free (buff); return i ? errno : 0; /* SGI version returns -1 on failure. */ }
pathf90_i4 pathf90_chmod(char *name, char *mode, pathf90_i4 *status, int namlen, int modlen) { pathf90_i4 junk; char *modbuf; __int32_t retcode; status = (0 == status) ? (&junk) : status; if (!bufarg && !(bufarg=malloc(bufarglen=namlen+modlen+2))) return(*status = errno=F_ERSPACE); else if (bufarglen <= namlen+modlen+1 && !(bufarg=realloc(bufarg, bufarglen=namlen+modlen+2))) return(*status = errno=F_ERSPACE); modbuf = &bufarg[namlen+1]; g_char(name, namlen, bufarg); g_char(mode, modlen, modbuf); if (bufarg[0] == '\0') return(*status = errno=ENOENT); if (modbuf[0] == '\0') return(*status = errno=F_ERARG); if (fork()) { if (wait(&retcode) == -1) return(*status = errno); return(*status = retcode); } else /* child */ #ifdef KEY /* Bug 1683 */ /* make error messages vanish if possible, since * we'll use return status to tell caller about errors */ dup2(open("/dev/null", O_WRONLY, 0666), 2); #endif /* KEY Bug 1683 */ execl("/bin/chmod", "chmod", modbuf, bufarg, (char *)0); /* NOTREACHED */ }
pathf90_i4 pathf90_chdir(char *dname, pathf90_i4 *status, int dnamlen) { pathf90_i4 junk; status = (0 == status) ? &junk : status; if (!bufarg && !(bufarg=malloc(bufarglen=dnamlen+1))) return((*status = errno=F_ERSPACE)); else if (bufarglen <= dnamlen && !(bufarg=realloc(bufarg, bufarglen=dnamlen+1))) return(*status = (errno=F_ERSPACE)); g_char(dname, dnamlen, bufarg); if (chdir(bufarg) != 0) { return(*status = errno); } return(*status = 0); }
pathf90_i4 pathf90_unlink(char *fname, pathf90_i4 *status, int namlen) { pathf90_i4 junk; status = (0 == status) ? (&junk) : status; if (!bufarg && !(bufarg=malloc(bufarglen=namlen+1))) return(*status = (errno=F_ERSPACE)); else if (bufarglen <= namlen && !(bufarg=realloc(bufarg, bufarglen=namlen+1))) return(*status = (errno=F_ERSPACE)); g_char(fname, namlen, bufarg); if (0 != unlink(bufarg)) { return *status = errno; } return *status = 0; }
integer G77_lstat_0 (const char *name, integer statb[13], const ftnlen Lname) { #if HAVE_LSTAT char *buff; int err; struct stat buf; buff = malloc (Lname + 1); if (buff == NULL) return -1; g_char (name, Lname, buff); err = lstat (buff, &buf); free (buff); statb[0] = buf.st_dev; statb[1] = buf.st_ino; statb[2] = buf.st_mode; statb[3] = buf.st_nlink; statb[4] = buf.st_uid; statb[5] = buf.st_gid; #if HAVE_ST_RDEV statb[6] = buf.st_rdev; #else statb[6] = 0; #endif statb[7] = buf.st_size; statb[8] = buf.st_atime; statb[9] = buf.st_mtime; statb[10] = buf.st_ctime; #if HAVE_ST_BLKSIZE statb[11] = buf.st_blksize; #else statb[11] = -1; #endif #if HAVE_ST_BLOCKS statb[12] = buf.st_blocks; #else statb[12] = -1; #endif return err; #else /* !HAVE_LSTAT */ return errno = ENOSYS; #endif /* !HAVE_LSTAT */ }
integer G77_stat_0 (const char *name, integer statb[13], const ftnlen Lname) #endif { char *buff; char *bp, *blast; int err; struct stat buf; buff = malloc (Lname+1); if (buff == NULL) return -1; g_char (name, Lname, buff); err = stat (buff, &buf); free (buff); statb[0] = buf.st_dev; statb[1] = buf.st_ino; statb[2] = buf.st_mode; statb[3] = buf.st_nlink; statb[4] = buf.st_uid; statb[5] = buf.st_gid; #if HAVE_ST_RDEV statb[6] = buf.st_rdev; /* not posix */ #else statb[6] = 0; #endif statb[7] = buf.st_size; statb[8] = buf.st_atime; statb[9] = buf.st_mtime; statb[10] = buf.st_ctime; #if HAVE_ST_BLKSIZE statb[11] = buf.st_blksize; /* not posix */ #else statb[11] = -1; #endif #if HAVE_ST_BLOCKS statb[12] = buf.st_blocks; /* not posix */ #else statb[12] = -1; #endif return err; }
f_inqu0_com (inlist *a, int *mask, int lock) #endif { flag byfile; flag sysfile = 0; /* set this flag if the file name is * "SYS$*" */ int i; char buf[PATH_MAX], *abuf; int x = 0; ino_t inod; unit *ftnunit; if (a->infile != NULL) { char *flname; flname = a->infile; byfile = 1; if (flname[3] == '$' && _I90_uppercase(flname, buf) && (!strcmp (buf, "SYS$INPUT") || !strcmp (buf, "SYS$OUTPUT") || !strcmp (buf, "SYS$ERROR"))) sysfile = 1; if (a->indefaultfile) { g_char (a->indefaultfile, a->indefaultfilelen, buf); abuf = buf + strlen (buf); } else abuf = buf; g_char (a->infile, a->infilen, abuf); /* bug fix 12983 */ x = f77inode (buf, &inod); if (x < 0) { mkidxname (buf, buf); x = f77inode (buf, &inod); } if (strlen (buf) > PATH_MAX) { /* can't use err() with inquire since f77curunit is never defined by a call to map_luno err (a->inerr, 145, "inquire"); */ if (a->inerr) { return(errno=F_ERFNAME); } else { fprintf(stderr, "Error in INQUIRE: file name too long: %s\n", buf); _cleanup (); exit(F_ERFNAME); } } ftnunit = NULL; if (x < 0) goto setvar; for (i = 0; i < mxunit; i++) /* sjc #1963 11Dec 87 */ if (f77units[i].uinode == inod && f77units[i].uconn > 0) { ftnunit = &f77units[i]; /* while (lock && test_and_set( &ftnunit->lock_unit, 1L )) ; */ break; } } else { byfile = 0; ftnunit = map_luno (a->inunit); /* while (lock && test_and_set( &ftnunit->lock_unit, 1L )) ; */ } setvar: if (a->inex) /* Fix BN 11327 . * If the file name is SYS$* then the file always exists. The sysfile * flag gets set above and hence when a user does and inquire with EXIST, then * the exist variable will be set . * * ---ravi---1/16/92 */ set_var (a->inex, *mask, INEX, (byfile && x > 0 || !byfile && ftnunit != NULL || sysfile) ? 1 : 0); if (a->inopen) set_var (a->inopen, *mask, INOPEN, byfile ? (ftnunit != NULL) : (ftnunit && ftnunit->uconn > 0)); if (a->innum) set_var (a->innum, *mask, INNUM, ftnunit ? ftnunit->luno : 0); if (a->innamed) set_var (a->innamed, *mask, INNAMED, (byfile || ftnunit != NULL && ftnunit->ufnm != NULL) ? 1 : 0); if (a->inname != NULL) if (byfile) b_char (buf, a->inname, a->innamlen); else if (ftnunit != NULL && ftnunit->ufnm != NULL) b_char (ftnunit->ufnm, a->inname, a->innamlen); else b_char ("", a->inname, a->innamlen); if (a->inacc) if (ftnunit && ftnunit->uconn > 0) switch (ftnunit->uacc) { case SEQUENTIAL: b_char ("SEQUENTIAL", a->inacc, a->inacclen); break; case DIRECT: b_char ("DIRECT", a->inacc, a->inacclen); break; case KEYED: b_char ("KEYED", a->inacc, a->inacclen); break; default: b_char ("UNKNOWN", a->inacc, a->inacclen); } else b_char ("UNKNOWN", a->inacc, a->inacclen); if (a->inseq != NULL) if (ftnunit) b_char ((ftnunit->uacc == SEQUENTIAL) ? "YES" : "NO", a->inseq, a->inseqlen); else b_char ("UNKNOWN", a->inseq, a->inseqlen); if (a->indir != NULL) if (ftnunit) b_char ((ftnunit->uacc == DIRECT) ? "YES" : "NO", a->indir, a->indirlen); else b_char ("UNKNOWN", a->indir, a->indirlen); if (a->infmt != NULL) if (ftnunit) if (!ftnunit->ufmt) b_char ("UNFORMATTED", a->infmt, a->infmtlen); else if (ftnunit->ufmt == 1) b_char ("FORMATTED", a->infmt, a->infmtlen); else b_char ("BINARY", a->infmt, a->infmtlen); else b_char ("UNKNOWN", a->infmt, a->infmtlen); if (a->inform != NULL) if (ftnunit) b_char (ftnunit->ufmt > 0 ? "YES" : "NO", a->inform, a->informlen); else b_char ("UNKNOWN", a->inform, a->informlen); if (a->inunf) if (ftnunit) b_char (ftnunit->ufmt > 0 ? "NO" : "YES", a->inunf, a->inunflen); else b_char ("UNKNOWN", a->inunf, a->inunflen); if (a->inrecl) set_var (a->inrecl, *mask, INRECL, (int) (ftnunit ? (ftnunit->ufmt || f77vms_flag_[OLD_RL] ? ftnunit->url : ftnunit->url / sizeof (int)) : 0)); if (a->innrec) { /* CALVIN: need to determine if a->innrec points to a *4 or a *8 */ if (ftnunit && (ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) { set_var (a->innrec, *mask, INNREC, (ftnunit && ftnunit->uacc == DIRECT && ftnunit->url) ? ftnunit->uirec + 1 : 0); } else { set_var (a->innrec, *mask, INNREC, (ftnunit && ftnunit->uacc == DIRECT && ftnunit->url) ? ftell (ftnunit->ufd) / ftnunit->url + 1 : 0); } } if (a->inblank) if (ftnunit && ftnunit->ufmt > 0) b_char (ftnunit->ublnk ? "ZERO" : "NULL", a->inblank, a->inblanklen); else b_char ("UNKNOWN", a->inblank, a->inblanklen); if (a->incc) if (ftnunit && ftnunit->ufmt > 0) switch (ftnunit->ucc) { case CC_FORTRAN: b_char ("FORTRAN", a->incc, a->incclen); break; case CC_LIST: b_char ("LIST", a->incc, a->incclen); break; case CC_NONE: b_char ("NONE", a->incc, a->incclen); break; default: b_char ("UNKNOWN", a->incc, a->incclen); } else b_char ("UNKNOWN", a->incc, a->incclen); if (a->inkeyed) if (ftnunit) b_char (ftnunit->uacc == KEYED ? "YES" : "NO", a->inkeyed, a->inkeyedlen); else b_char ("UNKNOWN", a->inkeyed, a->inkeyedlen); if (a->inorg) if (ftnunit) switch (ftnunit->uacc) { case SEQUENTIAL: b_char ("SEQUNTIAL", a->inorg, a->inorglen); break; case DIRECT: b_char ("RELATIVE", a->inorg, a->inorglen); break; case KEYED: b_char ("INDEXED", a->inorg, a->inorglen); break; default: b_char ("UNKNOWN", a->inorg, a->inorglen); } else b_char ("UNKNOWN", a->inorg, a->inorglen); if (a->inrecordtype) if (ftnunit) switch (ftnunit->uacc) { case SEQUENTIAL: b_char (ftnunit->ufmt == 1 ? "STREAM_LF" : "VARIABLE", a->inrecordtype, a->inrecordtypelen); break; case DIRECT: case KEYED: b_char ("FIXED", a->inrecordtype, a->inrecordtypelen); break; default: b_char ("UNKNOWN", a->inrecordtype, a->inrecordtypelen); } else b_char ("UNKNOWN", a->inrecordtype, a->inrecordtypelen); /* if (ftnunit) { ftnunit->lock_unit = 0; } */ return (0); }
integer f_inqu(inlist *a) #endif { flag byfile; int i, n; unit *p; char buf[256]; long x; if(a->infile!=NULL) { byfile=1; g_char(a->infile,a->infilen,buf); #ifdef NON_UNIX_STDIO x = access(buf,0) ? -1 : 0; for(i=0,p=NULL;i<MXUNIT;i++) if(f__units[i].ufd != NULL && f__units[i].ufnm != NULL && !strcmp(f__units[i].ufnm,buf)) { p = &f__units[i]; break; } #else x=f__inode(buf, &n); for(i=0,p=NULL;i<MXUNIT;i++) if(f__units[i].uinode==x && f__units[i].ufd!=NULL && f__units[i].udev == n) { p = &f__units[i]; break; } #endif } else { byfile=0; if(a->inunit<MXUNIT && a->inunit>=0) { p= &f__units[a->inunit]; } else { p=NULL; } } if(a->inex!=NULL) if(byfile && x != -1 || !byfile && p!=NULL) *a->inex=1; else *a->inex=0; if(a->inopen!=NULL) if(byfile) *a->inopen=(p!=NULL); else *a->inopen=(p!=NULL && p->ufd!=NULL); if(a->innum!=NULL) *a->innum= p-f__units; if(a->innamed!=NULL) if(byfile || p!=NULL && p->ufnm!=NULL) *a->innamed=1; else *a->innamed=0; if(a->inname!=NULL) if(byfile) b_char(buf,a->inname,a->innamlen); else if(p!=NULL && p->ufnm!=NULL) b_char(p->ufnm,a->inname,a->innamlen); if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) if(p->url) b_char("DIRECT",a->inacc,a->inacclen); else b_char("SEQUENTIAL",a->inacc,a->inacclen); if(a->inseq!=NULL) if(p!=NULL && p->url) b_char("NO",a->inseq,a->inseqlen); else b_char("YES",a->inseq,a->inseqlen); if(a->indir!=NULL) if(p==NULL || p->url) b_char("YES",a->indir,a->indirlen); else b_char("NO",a->indir,a->indirlen); if(a->infmt!=NULL) if(p!=NULL && p->ufmt==0) b_char("UNFORMATTED",a->infmt,a->infmtlen); else b_char("FORMATTED",a->infmt,a->infmtlen); if(a->inform!=NULL) if(p!=NULL && p->ufmt==0) b_char("NO",a->inform,a->informlen); else b_char("YES",a->inform,a->informlen); if(a->inunf) if(p!=NULL && p->ufmt==0) b_char("YES",a->inunf,a->inunflen); else if (p!=NULL) b_char("NO",a->inunf,a->inunflen); else b_char("UNKNOWN",a->inunf,a->inunflen); if(a->inrecl!=NULL && p!=NULL) *a->inrecl=p->url; if(a->innrec!=NULL && p!=NULL && p->url>0) *a->innrec=ftell(p->ufd)/p->url+1; if(a->inblank && p!=NULL && p->ufmt) if(p->ublnk) b_char("ZERO",a->inblank,a->inblanklen); else b_char("NULL",a->inblank,a->inblanklen); return(0); }
int f_inqu(inlist *a) { flag byfile,legal; int i; unit *p; char buf[256]; long x; x = 0; /* XXX - check correctness */ if(a->infile!=NULL) { byfile=1; g_char(a->infile,a->infilen,buf); x=inode(buf); for(i=0,p=NULL;i<MXUNIT;i++) if(units[i].uinode==x && units[i].ufd!=NULL) p = &units[i]; } else { byfile=0; if(a->inunit<MXUNIT && a->inunit>=0) { legal=1; p= &units[a->inunit]; } else { legal=0; p=NULL; } } if(a->inex!=NULL) { if((byfile && x>0) || (!byfile && p!=NULL)) *a->inex=1; else *a->inex=0; } if(a->inopen!=NULL) { if(byfile) *a->inopen=(p!=NULL); else *a->inopen=(p!=NULL && p->ufd!=NULL); } if(a->innum!=NULL) *a->innum= p-units; if(a->innamed!=NULL) { if(byfile || (p!=NULL && p->ufnm!=NULL)) *a->innamed=1; else *a->innamed=0; } if(a->inname!=NULL) { if(byfile) b_char(buf,a->inname,a->innamlen); else if(p!=NULL && p->ufnm!=NULL) b_char(p->ufnm,a->inname,a->innamlen); } if(a->inacc!=NULL && p!=NULL && p->ufd!=NULL) { if(p->url) b_char("direct",a->inacc,a->inacclen); else b_char("sequential",a->inacc,a->inacclen); } if(a->inseq!=NULL) { if(byfile || (p!=NULL && p->useek)) b_char("yes",a->inseq,a->inseqlen); else b_char("no",a->inseq,a->inseqlen); } if(a->indir!=NULL) { if(byfile || (p!=NULL && p->useek)) b_char("yes",a->indir,a->indirlen); else b_char("no",a->indir,a->indirlen); } if(a->infmt!=NULL) { if(p!=NULL && p->ufmt) b_char("formatted",a->infmt,a->infmtlen); else if(p!=NULL) b_char("unformatted",a->infmt,a->infmtlen); } if(a->inform!=NULL) b_char("yes",a->inform,a->informlen); if(a->inunf) { if(byfile || (p!=NULL && p->useek)) b_char("yes",a->inunf,a->inunflen); else b_char("unknown",a->inunf,a->inunflen); } if(a->inrecl!=NULL && p!=NULL) *a->inrecl=p->url; if(a->innrec!=NULL && p!=NULL && p->url>0) *a->innrec=ftell(p->ufd)/p->url+1; if(a->inblank && p!=NULL && p->ufmt) { if(p->ublnk) b_char("zero",a->inblank,a->inblanklen); else b_char("blank",a->inblank,a->inblanklen); } return(0); }
integer f_open (olist * a) { unit *b; integer rv; char buf[256], *s, *env; cllist x; int ufmt; FILE *tf; int fd, len; #ifndef NON_UNIX_STDIO int n; #endif if (f__init != 1) f_init (); f__external = 1; if (a->ounit >= MXUNIT || a->ounit < 0) err (a->oerr, 101, "open"); f__curunit = b = &f__units[a->ounit]; if (b->ufd) { if (a->ofnm == 0) { same:if (a->oblnk) b->ublnk = *a->oblnk == 'z' || *a->oblnk == 'Z'; return (0); } #ifdef NON_UNIX_STDIO if (b->ufnm && strlen (b->ufnm) == a->ofnmlen && !strncmp (b->ufnm, a->ofnm, (unsigned) a->ofnmlen)) goto same; #else g_char (a->ofnm, a->ofnmlen, buf); if (f__inode (buf, &n) == b->uinode && n == b->udev) goto same; #endif x.cunit = a->ounit; x.csta = 0; x.cerr = a->oerr; if ((rv = f_clos (&x)) != 0) return rv; } b->url = (int) a->orl; b->ublnk = a->oblnk && (*a->oblnk == 'z' || *a->oblnk == 'Z'); if (a->ofm == 0) if ((a->oacc) && (*a->oacc == 'D' || *a->oacc == 'd')) b->ufmt = 0; else b->ufmt = 1; else if (*a->ofm == 'f' || *a->ofm == 'F') b->ufmt = 1; else b->ufmt = 0; ufmt = b->ufmt; #ifdef url_Adjust if (b->url && !ufmt) url_Adjust (b->url); #endif if (a->ofnm) { g_char (a->ofnm, a->ofnmlen, buf); if (!buf[0]) opnerr (a->oerr, 107, "open"); } else sprintf (buf, "fort.%ld", (long) a->ounit); b->uscrtch = 0; b->uend = 0; b->uwrt = 0; b->ufd = 0; b->urw = 3; switch (a->osta ? *a->osta : 'u') { case 'o': case 'O': #ifdef NON_POSIX_STDIO if (!(tf = fopen (buf, "r"))) opnerr (a->oerr, errno, "open"); fclose (tf); #else if (access (buf, 0)) opnerr (a->oerr, errno, "open"); #endif break; case 's': case 'S': b->uscrtch = 1; #ifdef HAVE_MKSTEMP /* Allow use of TMPDIR preferentially. */ env = getenv ("TMPDIR"); if (!env) env = getenv ("TEMP"); if (!env) env = "/tmp"; len = strlen (env); if (len > 256 - (int) sizeof ("/tmp.FXXXXXX")) err (a->oerr, 132, "open"); strcpy (buf, env); strcat (buf, "/tmp.FXXXXXX"); fd = mkstemp (buf); if (fd == -1 || close (fd)) err (a->oerr, 132, "open"); #else /* ! defined (HAVE_MKSTEMP) */ #ifdef HAVE_TEMPNAM /* Allow use of TMPDIR preferentially. */ s = tempnam (0, buf); if (strlen (s) >= sizeof (buf)) err (a->oerr, 132, "open"); (void) strcpy (buf, s); free (s); #else /* ! defined (HAVE_TEMPNAM) */ #ifdef HAVE_TMPNAM tmpnam (buf); #else (void) strcpy (buf, "tmp.FXXXXXX"); (void) mktemp (buf); #endif #endif /* ! defined (HAVE_TEMPNAM) */ #endif /* ! defined (HAVE_MKSTEMP) */ goto replace; case 'n': case 'N': #ifdef NON_POSIX_STDIO if ((tf = fopen (buf, "r")) || (tf = fopen (buf, "a"))) { fclose (tf); opnerr (a->oerr, 128, "open"); } #else if (!access (buf, 0)) opnerr (a->oerr, 128, "open"); #endif /* no break */ case 'r': /* Fortran 90 replace option */ case 'R': replace: if ((tf = fopen (buf, f__w_mode[0]))) fclose (tf); } b->ufnm = (char *) malloc ((unsigned int) (strlen (buf) + 1)); if (b->ufnm == NULL) opnerr (a->oerr, 113, "no space"); (void) strcpy (b->ufnm, buf); if ((s = a->oacc) && b->url) ufmt = 0; if (!(tf = fopen (buf, f__w_mode[ufmt | 2]))) { if ((tf = fopen (buf, f__r_mode[ufmt]))) b->urw = 1; else if ((tf = fopen (buf, f__w_mode[ufmt]))) { b->uwrt = 1; b->urw = 2; } else err (a->oerr, errno, "open"); } b->useek = f__canseek (b->ufd = tf); #ifndef NON_UNIX_STDIO if ((b->uinode = f__inode (buf, &b->udev)) == -1) opnerr (a->oerr, 108, "open"); #endif if (b->useek) { if (a->orl) FSEEK (b->ufd, 0, SEEK_SET); else if ((s = a->oacc) && (*s == 'a' || *s == 'A') && FSEEK (b->ufd, 0, SEEK_END)) opnerr (a->oerr, 129, "open"); } return (0); }
f_open_com (olist *a, ftnint *mask, char **mode_, char **buf_, unit **fu) #endif { unit *b; ino_t inod; int n, org; char *mode = "r"; char *abuf, c, *cbuf, errstr[80]; char buf[PATH_MAX]; /* temp buffer */ char ubuf[PATH_MAX]; /* temp buffer */ unsigned int need; #if 00 cllist64 x; #else cllist x; #endif struct stat sbuf; static char seed[] = "aa"; char *q = seed; char ch; unit *dupunit; int dupopen; int istty = 0; /* Flag to indicate whether file * being opened is /dev/tty */ /* extern FILE *debugfile; */ struct stat stat_struct; unit *ftnunit; /* bug fix 12787 : need to initialize to zero */ /* sjc #1827: The cretin who coded this originally assumed that an * 80-byte temporary string would always be enough. We dynamically * allocate it to be 80 bytes plus whatever we can easily find out * about the length of the filename being passed to us. That may * not be enough (the string gets passed all over creation, so * it's hard to know) but it's better than before. Note that this * relies on f_open continuing not to be recursive. */ if (a->ofnm) istty = !strncmp ("/dev/tty", a->ofnm, 8); need = a->odfnm ? a->odfnmlen : 0; need += a->ofnm ? a->ofnmlen : 0; need += 40; if ((*fu = ftnunit = b = map_luno (a->ounit)) == NULL) err(a->oerr, 101, "open"); while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L )) { sginap(0); } /* obtain exclusive lock for special I/O operation, this should always be done after the lock onthe unit has been done to avoid deadlock */ while (test_and_set( &io_lock, 1L )) sginap(0); * buf_ = buf; /* Fix BN 9310 . If the the terminal is being opened do not test to see if this * file is already connected to a fortran unit since the terminal should be * able to be connected to various fortran units simultaneously * ---ravi---1/7/91 */ /* From the ANSI standard: to make this clear once and for all: ** If a unit is connnected to a file that exists, execution of an OPEN ** statement for that unit is permitted. If the FILE= specifier is not ** included in the OPEN statement, the file to be connected to the unit is ** the same as the file to which the unit is connected. ** If the file to be connected to the unit does not exist, but is the ** same as the file to which the unit is preconnected, the properties ** specifies by the OPEN statement become a part of the connection. ** If the file to be connected to the unit is not the same as the ** file to which the unit is conencted, the effect is as if a CLOSE ** statement without a STATUS= specifier had been executed for the unit ** immediately to the execution of the OPEN statement. ** If the file to be connected to the unit is the same as the file ** to which the unit is connected, only the BLANK= specifier may have a ** value different from the one currently in effect. The position of ** the file is unaffected. ** If a file is connected to a unit, execution of an OPEN statement ** on that file and a different unit is not permitted */ if (!istty) { if (dupopen = f_duped (a, ftnunit, &dupunit)) if (!a->oshared) return(dupopen); } else dupopen = 0; if (a->odfnm) { g_char (a->odfnm, a->odfnmlen, buf); abuf = &buf[strlen(buf)]; } else abuf = buf; if (b->uconn > 0 && (!a->osta || up_low (*a->osta) != 's')) { if (a->ofnm == 0) { same:if (a->oblnk != 0) b->ublnk = up_low (*a->oblnk) == 'z' ? 1 : 0; /* Ignore this open statement if it is not a preconnected unit ** otherwise redefine the unit characteristics */ if ((b->ufd == stdin || b->ufd == stdout || b->ufd == stderr) && b->ufnm == NULL) dupopen = 1; else return (0); } if (a->ofnm) { g_char (a->ofnm, a->ofnmlen, abuf); if (b->uacc == KEYED) mkidxname (buf, buf); f77inode (buf, &inod); if ((inod == b->uinode) && inod) goto same; buf[a->ofnmlen] = '\0'; } x.cunit = a->ounit; x.csta = 0; x.cerr = a->oerr; /* fix bug 6084 */ /* BN-8077 */ /* Leave the stdin, stdout, stderr alone without closing them, * since if that is done a normal file will be opened which will * have the ufd value of stdin, stdout, or stderr and mess up all * the conditional testing for stdin, stdout, and stderr */ if (b->ufd == stdin || b->ufd == stdout || b->ufd == stderr) { if (!dupopen) { b->uconn = 0; b->ufd = NULL; } #if 00 #define NAMEf_clos f_clos64 #else #define NAMEf_clos f_clos #endif } else if ((n = NAMEf_clos (&x)) != 0) return (n); b->luno = a->ounit; #undef NAMEf_clos } org = a->oorg ? up_low (*a->oorg) : 0; b->umask = *mask; if (a->oacc == 0) switch (org) { case 'r': b->uacc = DIRECT; break; case 'i': if (dupopen) err(a->oerr, 186, "open") b->uacc = KEYED; break; default: b->uacc = SEQUENTIAL; } else switch (up_low (*a->oacc)) { case 'd': b->uacc = DIRECT; if (org == 'i') err(a->oerr, 149, "open") break; case 'k': b->uacc = KEYED; if (org == 's') err(a->oerr, 150, "open") if (org == 'r') err(a->oerr, 151, "open") break; case 'a': b->uacc = APPEND; if (org == 'i') err(a->oerr, 152, "open") break; /* Fix BN 11769 * Currently if the access parameter is not a keywords, it * sets it to the default ,sequential. Generate error instead. * ---ravi---2/21/92 * case 's': default: b->uacc = org == 'i' ? KEYED : SEQUENTIAL; */ case 's': b->uacc = org == 'i' ? KEYED : SEQUENTIAL; break; default: err(a->oerr, 130, "open"); } if (a->oassocv && b->uacc == DIRECT) set_var ((ftnintu *)(b->uassocv = a->oassocv), b->umask, ASSOCV, 1); else b->uassocv = NULL; if (a->omaxrec && b->uacc == DIRECT) b->umaxrec = a->omaxrec; else b->umaxrec = 0; if (cbuf = a->odisp) switch (up_low (*cbuf++)) { case 'd': b->udisp = DELETE; break; case 'p': b->udisp = PRINT; goto checkdelete; case 's': if (up_low (*cbuf) == 'a') goto keep; b->udisp = SUBMIT; checkdelete: while (c = (*cbuf++)) if ((c == '/') && (c = (*cbuf)) && (up_low (c) == 'd')) b->udisp |= DELETE; break; keep: default: b->udisp = KEEP; } else b->udisp = KEEP; b->ushared = a->oshared; b->ureadonly = a->oreadonly; if (a->oblnk && up_low (*a->oblnk) == 'z') b->ublnk = 1; else b->ublnk = 0; #ifdef I90 b->uaction = b->ureadonly ? READONLY : READWRITE; b->unpad = 0; b->udelim = DELIM_NONE; #endif b->url = a->orl; if (a->ofm == 0) { if (b->uacc == DIRECT || b->uacc == KEYED) { b->ufmt = 0; if (!f77vms_flag_[OLD_RL]) b->url *= sizeof (int); } else b->ufmt = 1; } else if (up_low (*a->ofm) == 'f') b->ufmt = 1; else if (up_low (*a->ofm) == 'b') b->ufmt = 2; else if (up_low (*a->ofm) == 's') { /* system file = direct unformatted file with record length = 1 */ b->ufmt = 0; b->url = 1; b->uacc = DIRECT; } else { b->ufmt = 0; if (!f77vms_flag_[OLD_RL]) b->url *= sizeof (int); /* all sequential unformatted must need a minimum of 1K buffer to avoid fseek() operations when reading which causes data to be read from the disk each time and cause a 12X performance loss. */ check_buflen( b, 1024 ); } if (a->orectype) switch (up_low (*a->orectype)) { case 'f': if (b->uacc != DIRECT && b->uacc != KEYED) err(a->oerr, 156, "open") break; case 'v': if (b->uacc == DIRECT || b->uacc == KEYED || b->ufmt == 1) err(a->oerr, 157, "open") break; case 's': if (b->uacc == DIRECT || b->uacc == KEYED || b->ufmt != 1) err(a->oerr, 158, "open") default: break; } if (a->occ == 0) b->ucc = (char) (b->ufmt ? ((b->luno == 6 && f77vms_flag_[VMS_CC]) ? CC_FORTRAN : CC_LIST) : CC_NONE); else switch (up_low (*a->occ)) { case 'l': b->ucc = CC_LIST; break; case 'f': b->ucc = CC_FORTRAN; b->ucchar = '\0'; break; case 'n': b->ucc = CC_NONE; break; default: b->ucc = (char) (b->ufmt ? ((b->luno == 6 && f77vms_flag_[VMS_CC]) ? CC_FORTRAN : CC_LIST) : CC_NONE); } if (!b->ufmt && b->ucc != CC_NONE) err(a->oerr, 162, "open"); if (a->ofnm == 0) #ifdef SIZEOF_LUNO_IS_64 (void) sprintf (abuf, "fort.%lld", a->ounit); #else (void) sprintf (abuf, "fort.%d", a->ounit); #endif else