/* * ASNQFILE - returns the assign attributes for a file name. * * Call from Fortran: * * CALL ASNQFILE(FNAME, ATTR, ISTAT) * * Parameters * * FNAME (I) file name * ATTR (O) receives the assign options for this unit number * ISTAT (O) 0 if any options were found, -1 if not found, * >0 error code on error. */ void #ifdef _UNICOS ASNQFILE( _fcd fname, _fcd attrs, _f_int *istat) { #else /* _SOLARIS, __mips, etc. */ asnqfile_( char *fnamptr, char *attrptr, _f_int *istat, int fnamlen, int attrlen) { _fcd attrs = _cptofcd(attrptr, attrlen); _fcd fname = _cptofcd(fnamptr, fnamlen); #endif /* _SOLARIS */ int ret; char *atstr; char *cfname; if ((cfname = _fc_acopy(fname)) == NULL) { *istat = FENOMEMY; } ret = _get_a_options(0, cfname, (unum_t) 0, 0, NULL, &atstr, _LELVL_RETURN); free(cfname); switch (ret) { case -1: /* an error condition was encountered */ *istat = errno; break; case 0: /* attributes were not found */ *istat = NOT_FOUND; break; case 1: /* attributes were found */ *istat = FOUND; if (_c2fcpy(atstr, attrs) == -1) *istat = ERAS_ATTSPC; free(atstr); break; } if (*istat != FOUND) (void)_c2fcpy("", attrs); /* fill with blanks */ return; }
/* * ASNQUNIT - returns the assign attributes for a Fortran unit number. * * Call from Fortran: * * CALL ASNQUNIT(IUN, ATTR, ISTAT) * * Parameters * * IUN (I) unit number * ATTR (O) receives the assign options for this unit number * ISTAT (O) 0 if any options were found, -1 if not found, * >0 error code on error. */ void #ifdef _UNICOS ASNQUNIT( _f_int *iun, _fcd attrs, _f_int *istat) { #else /* _SOLARIS */ asnqunit_( _f_int *iun, char *attrptr, _f_int *istat, int attrlen) { _fcd attrs = _cptofcd(attrptr, attrlen); #endif /* _SOLARIS */ int ret; unum_t unum; char *atstr; unum = *iun; ret = _get_a_options(0, NULL, unum, 0, NULL, &atstr, _LELVL_RETURN); switch (ret) { case -1: /* an error condition was encountered */ *istat = errno; break; case 0: /* attributes were not found */ *istat = NOT_FOUND; break; case 1: /* attributes were found */ *istat = FOUND; if (_c2fcpy(atstr, attrs) == -1) *istat = ERAS_ATTSPC; free(atstr); break; } if (*istat != FOUND) (void)_c2fcpy("", attrs); /* fill with blanks */ return; }
/* * _f_inqu - process INQUIRE statement. * * Return value * Returns 0 on success, positive error code if an error * is encountered and ERR= or IOSTAT= are unspecified. * This routine aborts on error conditions if no ERR= * or IOSTAT= are specified. */ int _f_inqu( FIOSPTR css, /* statement state */ unit *cup, /* locked unit pointer if INQUIRE by * unit and unit is connected. */ inlist *a) /* list of INQUIRE specifiers */ { int aifound; /* Assign info found flag */ int byfile; /* INQUIRE by file/unit flag */ int exists; /* File exists flag */ int opened; /* File opened flag */ int valunit; /* Valid unit number flag */ int errn; char *buf, *fn, *s; struct stat st; /* Stat system call packet */ assign_info ai; /* Assign information packet */ unit *p; p = cup; errn = 0; /* * Lock _openlock to ensure that no other task opens or closes units * during the unit table scan for inquire-by-file processing. */ OPENLOCK(); if (a->infile != NULL) /* if INQUIRE by file */ byfile = 1; else { /* else INQUIRE by unit */ byfile = 0; valunit = GOOD_UNUM(a->inunit) && !RSVD_UNUM(a->inunit); /* Valid Unit Number? */ } if ((buf = malloc(MAX(a->infilen + 1, MXUNITSZ + 1))) == NULL) { errn = FENOMEMY; if (a->inerr) goto out_of_here; _ferr(css, errn); } *buf = '\0'; /* Assume no name */ opened = 0; /* Assume not opened */ fn = buf; if (byfile) { /* If INQUIRE by file */ _copy_n_trim(a->infile, a->infilen, buf); if ((aifound = _get_a_options(0, buf, -1, 0, &ai, NULL, _LELVL_RETURN)) == -1) { errn = errno; if (a->inerr) { free(buf); goto out_of_here; } _ferr(css, errn); } if (aifound && ai.a_actfil_flg) /* If assign alias */ s = ai.a_actfil; /* Use -a attribute as file name */ else s = buf; exists = (stat(s, &st) != -1); if (exists) { p = _get_next_unit(NULL, 1, 1); while (p != NULL) { /* while more open units */ unum_t unum; unum = p->uid; if (! RSVD_UNUM(unum) && (p->uinode == st.st_ino) && (p->udevice == st.st_dev)) { fn = p->ufnm; opened = 1; break; } p = _get_next_unit(p, 1, 1); } /* * If p is non-null here, it points to a locked unit. * The unit is locked to ensure a consistent set of * INQUIRE'd attributes is returned. */ } } else { /* Else INQUIRE by unit */ if (valunit) { opened = (cup != NULL); if (opened) { /* If opened, get name */ p = cup; fn = p->ufnm; } } } if (fn == NULL) /* If no name available, return blanks */ fn = ""; /* EXIST specifier */ if (a->inex != NULL) if (byfile) /* If INQUIRE by file */ *a->inex = _btol(exists); else /* INQUIRE by unit */ *a->inex = _btol(valunit); /* OPENED specifier */ if (a->inopen != NULL) *a->inopen = _btol(opened); /* NAMED specifier */ if (a->innamed != NULL) if (byfile) /* If INQUIRE by file */ *a->innamed = _btol(1); /* .TRUE. */ else /* INQUIRE by unit */ *a->innamed = _btol(opened && p->ufnm != NULL); /* NUMBER specifier */ if (a->innum != NULL) { if (opened) { if (byfile) /* If INQUIRE by file */ *a->innum = (opened) ? p->uid : -1; else /* INQUIRE by unit */ *a->innum = a->inunit; /* The law of identity */ } else *a->innum = -1; } /* RECL specifier */ if (a->inrecl != NULL) if (opened) { if (p->urecl > 0) /* If recl was specified */ *a->inrecl = p->urecl; else /* Recl not specified (i.e., sequential) */ *a->inrecl = (p->ufmt) ? p->urecsize : LONG_MAX; } else *a->inrecl = -1; /* NEXTREC specifier */ if (a->innrec != NULL) if (opened && p->useq == 0) /* If opened & direct access */ *a->innrec = p->udalast + 1; else *a->innrec = -1; /* NAME specifier */ if (a->inname != NULL) _b_char(fn, a->inname, a->innamlen); /* ACCESS specifier */ if (a->inacc != NULL) { if (opened) s = (p->useq) ? "SEQUENTIAL" : "DIRECT"; else s = "UNDEFINED"; _b_char(s, a->inacc, a->inacclen); } /* SEQUENTIAL specifier */ if (a->inseq != NULL) { if (opened) s = (p->useq) ? "YES" : "NO"; else s = "UNKNOWN"; _b_char(s, a->inseq, a->inseqlen); } /* DIRECT specifier */ if (a->indir != NULL) { if (opened) s = (p->useq) ? "NO" : "YES"; else s = "UNKNOWN"; _b_char(s, a->indir, a->indirlen); } /* FORM specifier */ if (a->inform != NULL) { if (opened) s = (p->ufmt) ? "FORMATTED" : "UNFORMATTED"; else s = "UNDEFINED"; _b_char(s, a->inform, (ftnlen)a->informlen); } /* FORMATTED specifier */ if (a->infmt != NULL) { if (opened) s = (p->ufmt) ? "YES" : "NO"; else s = "UNKNOWN"; _b_char(s, a->infmt, a->infmtlen); } /* UNFORMATTED specifier */ if (a->inunf != NULL) { if (opened) s = (p->ufmt) ? "NO" : "YES"; else s = "UNKNOWN"; _b_char(s, a->inunf, a->inunflen); } /* BLANK specifier */ if (a->inblank != NULL) { if (opened && p->ufmt) s = (p->ublnk) ? "ZERO" : "NULL"; else s = "UNDEFINED"; _b_char(s, a->inblank, a->inblanklen); } /* POSITION specifier */ if (a->inposit != NULL) { /* Fortran 90 position control */ if (opened && p->useq) { switch (p->uposition) { case OS_REWIND: s = "REWIND"; break; case OS_ASIS: s = "ASIS"; break; case OS_APPEND: s = "APPEND"; break; case 0: s = "UNKNOWN"; break; default: _ferr(css, FEINTUNK); } } else s = "UNDEFINED"; _b_char(s, a->inposit, a->inpositlen); } /* ACTION specifier */ if (a->inaction != NULL) { /* Fortran 90 action control */ if (opened) { switch (p->uaction) { case OS_READWRITE: s = "READWRITE"; break; case OS_READ: s = "READ"; break; case OS_WRITE: s = "WRITE"; break; default: _ferr(css, FEINTUNK); } } else /* for an unconnected file */ s = "UNDEFINED"; _b_char(s, a->inaction, a->inactonlen); } /* READ specifier */ if (a->inread != NULL) { /* Fortran 90 read action control */ if (opened) { if ((p->uaction == OS_READ) || (p->uaction == OS_READWRITE)) s = "YES"; else s = "NO"; } else s = "UNKNOWN"; _b_char(s, a->inread, a->inreadlen); } /* WRITE specifier */ if (a->inwrite != NULL) { /* Fortran 90 write action control */ if (opened) { if ((p->uaction == OS_WRITE) || (p->uaction == OS_READWRITE)) s = "YES"; else s = "NO"; } else s = "UNKNOWN"; _b_char(s, a->inwrite, a->inwritelen); } /* READWRITE specifier */ if (a->inredwrit != NULL) { /* Fortran 90 read/write action control */ if (opened) { if (p->uaction == OS_READWRITE) s = "YES"; else s = "NO"; } else s = "UNKNOWN"; _b_char(s, a->inredwrit, a->inrdwrtlen); } /* DELIM specifier */ if (a->indelim != NULL) { /* Fortran 90 delim control */ if (opened && p->ufmt) { /* if formatted */ switch (p->udelim) { case OS_NONE: s = "NONE"; break; case OS_QUOTE: s = "QUOTE"; break; case OS_APOSTROPHE: s = "APOSTROPHE"; break; default: _ferr(css, FEINTUNK); } } else /* UNDEFINED for unformatted or unconnected file */ s = "UNDEFINED"; _b_char(s, a->indelim, a->indelimlen); } /* PAD specifier */ if (a->inpad != NULL) { /* Fortran 90 pad control */ if(opened && p->ufmt) { /* if formatted */ switch (p->upad) { case OS_YES: s = "YES"; break; case OS_NO: s = "NO"; break; default: _ferr(css, FEINTUNK); } } else /* Fortran 90 missed UNDEFINED if unformatted or unconnected */ s = "YES"; /* set to YES instead of UNDEFINED */ _b_char(s, a->inpad, a->inpadlen); } /* * Unlock the unit if we have a pointer to an open unit. Note that * $INQ/_INQUIRE never unlocks the unit. */ out_of_here: OPENUNLOCK(); if (p != NULL) _release_cup(p); /* unlock the unit */ free(buf); return(errn); }