/* * This routine is like ffopen, except it expects all parameters */ ffopenf(const char *name, int flags, mode_t mode, long cbits, int cblks, struct ffsw *pstat) { int narg; _ffopen_t fd; int retfd; int aifound; union spec_u *fdspec; struct gl_o_inf gloinf; assign_info ai; struct fdinfo *nfio; extern union spec_u *_g_fdc_spec(); aifound = _assign_asgcmd_info(name, -1, ASN_G_FF | ASN_G_ALL, &ai, NULL, 1); if (aifound == -1) { ERETURN(pstat, errno, 0); } if (aifound == 1 && ai.F_filter_flg) fdspec = &ai.F_filter[0]; else fdspec = NULL; (void) memset(&gloinf, 0, sizeof(gloinf)); gloinf.aip = aifound ? &ai : NULL; fd = _ffopen(name, flags, mode, fdspec, pstat, cbits, cblks, NULL, &gloinf); #if defined(_CRAY1) || defined(__mips) if (fd != _FFOPEN_ERR && MULTI_ON) { nfio = NULL; if (_ff_top_lock(fd, &nfio, pstat) < 0) fd = _FFOPEN_ERR; if (nfio != NULL) fd = (_ffopen_t)nfio; } #endif /* * ffopen returns an int. Call a routine which associates an * int with what is returned by _ffopen */ #if defined(__mips) || defined(_LITTLE_ENDIAN) retfd = _ff_fdinfo_to_int(fd, pstat); #else retfd = (int)fd; #endif /* should check chain of layers here for sanity */ return(retfd); }
void OPENWA( long *dn, /* pointer to null-terminated file name */ long *index, long *eoi, long **addr, long *blocks, long *sector, long *ier /* optional error return. If this parameter is */ /* not present, we abort on error */ ) { WAFIL *f; assign_info ai; int aifound; char *nmstr; unum_t unitnum; unum_t unitid; int rfd; char c; char *ptr; struct ffc_info_s ffi; struct fdinfo *fio; struct ffsw iostat; int errflg = 0; long *erptr; unitnum = -1; /* assume no unit number */ unitid = *(unum_t *) dn; /* unit ID is 'name' */ if (_numargs() > 6) errflg = 1; /* * Check the assign environment for user requested changes to the * default file characteristics. */ if (strncmp((char *)dn, "fort.", 5) == 0) { register unum_t unum; ptr = (char *)dn + 5; unum = 0; while (isdigit(c = *ptr++)) { unum = unum * 10; unum = unum + ((int) c - (int) '0'); } if (c == '\0') { unitnum = unum; unitid = unum; } } aifound = _assign_asgcmd_info((char *)dn, unitnum, ASN_G_ALL, &ai, NULL, 1); if (aifound == -1) { if (errflg) { *ier = -errno; _errwa_msg(errno); return; } else _errwa_abort(errno); } if (aifound == 1 && ai.a_actfil_flg) /* if actual file assigned */ nmstr = ai.a_actfil; else nmstr = (char *)dn; if (errflg) erptr = ier; else erptr = NULL; G@OPENWA(nmstr, index, eoi, addr, blocks, &aifound, &ai, NULL, erptr, sector); if (erptr && *erptr != 0) { _errwa_msg(-(*erptr)); return; } f = wafils + (*index-1); /* * The file name is stored only if we're not being called from libf * via the '-s bin' mechanism. */ (void) strncpy(f->wa_idn, (char*)dn, WA_NAMLEN); fio = GETIOB(f->wa_fd); if (f->wa_fdc == YES) { if (XRCALL(fio, fcntlrtn)fio, FC_GETINFO, &ffi, &iostat) < 0) { if (errflg) { *ier = -iostat.sw_error; _errwa_msg(iostat.sw_error); return; } else _errwa("OPENWA", "Fcntlrtn error on", f, iostat.sw_error); } rfd = ffi.ffc_fd; } else
int _f_open( FIOSPTR css, /* Fortran statement state */ unit **cup_p,/* input: pointer to currently open unit. output: */ /* pointer to new unit. */ olist *olptr, /* OPEN information */ int isf90) /* 1 if being opened from CF90, 0 if CF77 */ { register short is_bin; /* 1 if binary; else 0 */ register short is_fmt; /* 1 if formatted; 0 if unformatted */ register short is_seq; /* 1 if sequential; 0 if direct */ register short is_sys; /* 1 if system; else 0 */ register short no_mem; /* 1 if malloc() fails */ register int aifound; /* 1 if assign/asgcmd info found */ register int errn; /* Error code */ register int gamask; /* Global assign mask */ register int oflags; /* O_EXCL/O_CREAT */ register int P_value; /* -P option value */ register int stdfn; /* 1 if std file stdin/stdout/stderr */ register int stdfnum; /* standard file descriptor number */ register int stat_ok; /* 1 if statbuf is valid */ register int tufs; /* requested file structure (default) */ register int uscope; /* File scope */ register unum_t unum; /* unit number */ char namebuf[MXUNITSZ]; /* buffer to construct file name */ char *fname; /* FILE= specifier or default filename*/ char *aname; /* actual file name */ char *atstr; /* assign attributes string */ unit *cup; assign_info ai; struct stat statbuf; unum = olptr->ounit; if (! GOOD_UNUM(unum)) FERROR1(olptr->oerr, FEIVUNIT, unum); /* * Check for a re-open before initializing any unit table fields. */ if (OPEN_UPTR(*cup_p)) { /* * The unit is connected, but we have already checked in * $OPN for reconnection to the same file with unchanged * attributes. Thus, we know that we may disconnect the unit * here before continuing the set up of the new connection. * * We unlock it so that _alloc_unit may find it again and * lock it. */ errn = _unit_close(*cup_p, CLST_UNSPEC, NULL); if (errn != 0) FERROR(olptr->oerr, errn); _release_cup(*cup_p); /* unlock the unit */ } /* * "aname" receives the actual name to be opened by the system. * It starts out the same as fname, but might later be reassigned * by assign. */ aname = NULL; fname = NULL; stdfn = 0; no_mem = 0; if (olptr->ofile == NULL) { /* If no name specified */ if (olptr->ostatus == OS_SCRATCH) { /* If SCRATCH */ int scratchfd; /* * Scratch files have no name (see INQUIRE). */ fname = NULL; aname = strdup("FXXXXXX"); scratchfd = mkstemp(aname); close(scratchfd); /* because mkstemp opens the file */ } else if (unum == 0 || unum == 5 || unum == 6 || RSVD_UNUM(unum)) { stdfn = 1; /* Possible standard file */ stdfnum = -1; switch (unum) { case 5: /* Connect 5 and 100 to stdin */ case 100: stdfnum = STDIN_FILENO; break; case 6: /* Connect 6 and 101 to stdout */ case 101: stdfnum = STDOUT_FILENO; break; case 0: /* Connect 0 and 102 to stderr/errfile */ case 102: /* (see finit.c) */ stdfnum = fileno(errfile); break; default: _ferr(css, FEINTUNK); /* deep weeds */ } } else { /* not scratch nor standard file */ (void) _fortname(namebuf, unum); /* Make default name */ fname = strdup(namebuf); aname = strdup(namebuf); no_mem = (aname == NULL) || (fname == NULL); } } else { /* Copy user supplied name */ if ((fname = malloc(olptr->ofilelen + 1)) != NULL) { _copy_n_trim(olptr->ofile, olptr->ofilelen, fname); aname = strdup(fname); } no_mem = (aname == NULL) || (fname == NULL); } if (no_mem) { /* If malloc() failed */ freeit(aname); freeit(fname); FERROR(olptr->oerr, FENOMEMY); /* No memory */ } is_bin = (olptr->oform == OS_BINARY) ? 1 : 0; is_fmt = (olptr->oform == OS_FORMATTED) ? 1 : 0; is_seq = (olptr->oaccess == OS_SEQUENTIAL ? 1 : 0); is_sys = (olptr->oform == OS_SYSTEM) ? 1 : 0; /* * The ASN_G_SF/SU/DF/DU masks map to the ACCESS/FORM specifiers on OPEN. */ switch ((is_seq << 3) | is_fmt) { case 011: /* Sequential Formatted */ gamask = ASN_G_SF; break; case 010: /* Sequential Unformatted */ gamask = ASN_G_SU; break; case 001: /* Direct Formatted */ gamask = ASN_G_DF; break; case 000: /* Direct Unformatted */ gamask = ASN_G_DU; break; } gamask = gamask | ASN_G_ALL; atstr = NULL; aifound = _assign_asgcmd_info(fname, unum, gamask, &ai, &atstr, olptr->oerr); #ifdef KEY /* Bug 4924 */ /* Ignore "-F f77.mips" if the file is not sequential and thus has no * headers. Otherwise, we would select an ffio layer which gives a * runtime error on non-sequential files. Today f77.mips is the only * value we support; if we supported some other value which permitted * non-sequential access, this test would need to be made more precise. */ if (!is_seq) { ai.F_filter_flg = 0; } #endif /* KEY Bug 4924 */ if (aifound == -1) { freeit(fname); freeit(aname); freeit(atstr); FERROR(olptr->oerr, errno); } /* * Set up the scoping of this unit. -P process is default. */ uscope = AS_PROCESS; /* actual scope */ P_value = AS_PROCESS; /* -P option value, if any */ if (aifound == 1 && ai.P_ioscop_flg) { uscope = ai.P_ioscop; P_value = ai.P_ioscop; /* Map -P private and -P global to the new spelling */ #ifdef _CRAYMPP if (ai.P_ioscop == AS_PRIVATE) uscope = AS_PROCESS; #else if (ai.P_ioscop == AS_PRIVATE) uscope = AS_THREAD; if (ai.P_ioscop == AS_GLOBAL) uscope = AS_PROCESS; #endif } #ifdef _CRAYMPP if (uscope == AS_GLOBAL) FERROR(olptr->oerr, FENOGLOB); if (uscope == AS_THREAD) FERROR(olptr->oerr, FENOTHRD); if (uscope == AS_TEAM) FERROR(olptr->oerr, FENOTEAM); #else if (uscope == AS_TEAM) FERROR(olptr->oerr, FENOTEAM); #endif /* * Now that we know the unit number and scope we can get a pointer to the * unit table. */ #ifdef _CRAYMPP cup = _alloc_unit(unum, 1); /* TEMPORARY */ #else cup = _alloc_unit(unum, (uscope == AS_THREAD)); #endif if (cup == NULL) FERROR1(olptr->oerr, errno, unum); *cup_p = cup; /* * Record OPEN specifiers in unit table */ cup->ubinary = is_bin; cup->ufmt = is_fmt; cup->useq = is_seq; cup->usystem = is_sys; cup->ublnk = (olptr->oblank == OS_ZERO ? 1 : 0); cup->uposition = olptr->oposition; cup->uaction = olptr->oaction; cup->udelim = olptr->odelim; cup->upad = olptr->opad; cup->urecl = olptr->orecl; /* * Initialize the cf77/f90 mode. It might be changed in f_asgn() later. */ cup->uft90 = isf90; if (aifound == 1 && ai.a_actfil_flg) { stdfn = 0; /* standard file overridden */ freeit(aname); aname = strdup(ai.a_actfil); if (aname == NULL) { freeit(atstr); freeit(fname); FERROR(olptr->oerr, FENOMEMY); } } if (aifound == 1 && ai.D_fildes_flg) { stdfn = 1; /* indicate standard file */ stdfnum = ai.D_fildes; freeit(aname); aname = NULL; } /* * Units connected to stdin, stdout, or stderr may not have thread scope * on PVP systems. */ #ifdef _CRAYMPP if (stdfn && uscope == AS_TEAM) { freeit(fname); freeit(aname); freeit(atstr); FERROR(olptr->oerr, FENOTEAM); } #else if (stdfn && uscope == AS_THREAD) { freeit(fname); freeit(aname); freeit(atstr); FERROR(olptr->oerr, (P_value==AS_PRIVATE)? FENOPRIV: FENOTHRD); } #endif /* * Set up cup->urecsize, the maximum record size. If RECL was * specified (it's required on direct access files; optional * on sequential access files), then RECL becomes the maximum * record size for all formatted I/O on this unit. Otherwise * we use default values for the maximum record size for both * regular I/O and list-directed/namelist output. */ if (cup->ufmt) { /* If formatted file */ if (cup->urecl > 0) { /* If RECL specified */ cup->urecsize = cup->urecl; cup->uldwsize = cup->urecl; } else { /* Else set defaults */ cup->urecsize = _f_rcsz; cup->uldwsize = _f_ldsz; } /* Allocate line buffer for formatted files */ cup->ulinebuf = (long *) malloc(sizeof(long) * (cup->urecsize + 1)); if (cup->ulinebuf == NULL) { freeit(fname); freeit(aname); freeit(atstr); FERROR(olptr->oerr, FENOMEMY); } } /* * See if the file exists. We don't know the filename for sure if FFIO * is being used though. */ errn = 0; stat_ok = 0; if (stdfn) { errn = fstat(stdfnum, &statbuf); stat_ok = 1; } else if (aifound == 0 || ai.F_filter_flg == 0) { errn = stat(aname, &statbuf); stat_ok = 1; } /* * ENOENT means the file doesn't exist. EINTR means the request * was interrupted. If we got an EINTR error, retry the stat * request a few times. A persistent EINTR error or any other * stat error besides ENOENT is fatal. * * On UNICOS and UNICOS/mk systems, a EINTR error should never * occur on a stat request... but we've seen some on UNICOS/mk * for a reason the kernel developers do not understand. */ if (stat_ok && errn == -1) { /* If we did a stat and it failed */ register short retry = 0; while (errn == -1 && errno == EINTR && retry++ < 10) { if (stdfn) errn = fstat(stdfnum, &statbuf); else errn = stat(aname, &statbuf); } if (errn == -1) { /* We have a hard failure */ stat_ok = 0; if (errno != ENOENT) { /* If not ENOENT, abort */ freeit(fname); freeit(aname); freeit(atstr); freeit(cup->ulinebuf); FERROR(olptr->oerr, errno); } } } /* Select the file structure */ if (aifound == 1 && (ai.s_fstrct_flg || ai.F_filter_flg)) { if (ai.F_filter_flg) tufs = FS_FDC; else tufs = ai.s_fstrct; } else { /* Select default file structure */ if ( cup->ufmt ) /* if formatted */ #if defined(__mips) || defined(_LITTLE_ENDIAN) tufs = (cup->useq) ? FS_TEXT : FS_UNBLOCKED; #else tufs = FS_TEXT; #endif else { /* else unformatted */ #ifdef _UNICOS tufs = (cup->useq) ? FS_COS : FS_UNBLOCKED; #else /* else NOT _UNICOS */ tufs = (cup->useq) ? FS_F77 : FS_UNBLOCKED; #endif /* END _UNICOS */ if (is_bin || is_sys) { /* * Use UNBLOCKED layer for direct or * sequential unformatted IO that does * not contain record control images. * Formatted IO is not allowed (i.e., a) */ tufs = FS_UNBLOCKED; } } /* See if the device is a tape and handle it accordingly */ if (stat_ok && _gsys_qtape(&statbuf) != 0) tufs = FS_TAPE; }
ffopen(const char *name, int flags, ...) { int narg; int cblks; _ffopen_t fd; int retfd; int aifound; mode_t mode; long cbits; va_list ap; union spec_u *fdspec; struct gl_o_inf gloinf; assign_info ai; struct fdinfo *nfio; extern union spec_u *_g_fdc_spec(); struct ffsw *pstat, locstat; #ifdef _CRAY NUMARG(narg); #elif defined(__mips) || defined(_LITTLE_ENDIAN) /* mode is passed only when O_CREAT is set */ if (flags & O_CREAT) narg = 3; else narg = 2; #else narg = 6; #endif mode = 0; cbits = 0; cblks = 0; pstat = &locstat; /* * New usage only allows 5 params. (what does this mean ???) */ va_start(ap, flags); if (narg >= 3) #if defined(BUILD_OS_DARWIN) mode = (mode_t) va_arg(ap, int); #else /* defined(BUILD_OS_DARWIN) */ mode = va_arg(ap, mode_t); #endif /* defined(BUILD_OS_DARWIN) */ if (narg >= 4) cbits = va_arg(ap, long); if (narg >= 5) pstat = va_arg(ap, struct ffsw *); if (narg >= 6) cblks = va_arg(ap, int); va_end(ap); aifound = _assign_asgcmd_info(name, -1, ASN_G_FF | ASN_G_ALL, &ai, NULL, 1); if (aifound == -1) { ERETURN(pstat, errno, 0); } if (aifound == 1 && ai.F_filter_flg) fdspec = &ai.F_filter[0]; else fdspec = NULL; (void) memset(&gloinf, 0, sizeof(gloinf)); gloinf.aip = aifound ? &ai : NULL; fd = _ffopen(name, flags, mode, fdspec, pstat, cbits, cblks, NULL, &gloinf); #if defined(_CRAY1) || defined(__mips) if (fd != _FFOPEN_ERR && MULTI_ON) { nfio = NULL; if (_ff_top_lock(fd, &nfio, pstat) < 0) fd = _FFOPEN_ERR; if (nfio != NULL) fd = (_ffopen_t)nfio; } #endif /* * ffopen returns an int. Call a routine which associates an * int with what is returned by _ffopen */ #if defined(__mips) || defined(_LITTLE_ENDIAN) retfd = _ff_fdinfo_to_int(fd, pstat); #else retfd = (int)fd; #endif /* should check chain of layers here for sanity */ if (narg < 4) errno = locstat.sw_error; return(retfd); }