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); }
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