/* * _flushall - flush all connected Fortran units except 100, 101, 102. */ void _flushall(void) { int ret; register short errflag; static short pass = 0; /* incremented when _flushall is called */ unit *uptr; if (pass++ >= 1) return; errflag = 0; /* * Find all open Fortran units not connected by * WOPEN/OPENMS/OPENDR/AQOPEN and flush them. */ uptr = _get_next_unit(NULL, 0, 0); while (uptr != NULL) { /* while more open units */ #ifdef KEY /* Bug 6433 */ _f_int4 unum; #else /* KEY Bug 6433 */ unum_t unum; #endif /* KEY Bug 6433 */ unum = uptr->uid; if (OPEN_UPTR(uptr) && uptr->ufs != FS_AUX) { flush_( &unum ); } uptr = _get_next_unit(uptr, 0, 0); } /* * Flush C files on mips because the C cleanup routine will not * be executed if the code is loaded using the f90 command. So * Fortran fork_ processing must flush stdout and any user C * files in addition to the Fortran files. */ (void) fflush(NULL); return; }
int __OPN( _f_int *unitn, _f_int *iostat, int *errf, _fcd file, _fcd status, _fcd access, _fcd form, _f_int *recl, _fcd blank, _fcd position, _fcd action_arg, _fcd delim_arg, _fcd pad_arg, int unused1, /* for a future CFT77 open specifier */ int unused2, /* for a future CFT77 open specifier */ int isf90_arg) /* =1 iff Fortran-90 OPEN */ #endif { olist a; /* OPEN specifier list */ long fstrlen; /* Length of Fortran string */ int errn; /* IOSTAT error number */ int error; /* Error flag */ unum_t unum; /* Fortran unit number */ _fcd action; _fcd delim; _fcd pad; int isf90; unit *cup; /* Pointer to unit table entry */ enum form_spec formdef; struct fiostate cfs; #ifdef _CRAYMPP va_list args; _fcd file; _fcd status; _fcd access; _fcd form; _f_int *recl; _fcd blank; _fcd position; int unused1; /* for a future CFT77 open specifier */ int unused2; /* for a future CFT77 open specifier */ int isf90_arg; /* =1 iff Fortran-90 OPEN */ #endif /* * The ACTION, DELIM, and PAD specifiers are supported by CFT77 * release 5.0 and later on CX/CEA systems, and by CFT77 release 6.0 and * later on CRAY-2 systems. */ action = _cptofcd(NULL, 0); delim = _cptofcd(NULL, 0); pad = _cptofcd(NULL, 0); #ifdef _CRAYMPP va_start(args,errf); file = va_arg(args, _fcd); status = va_arg(args, _fcd); access = va_arg(args, _fcd); form = va_arg(args, _fcd); recl = va_arg(args, _f_int *); blank = va_arg(args, _fcd); position = va_arg(args, _fcd); #endif if (PASSED_ARG(ARGS_11)) { #ifdef _CRAYMPP action = va_arg(args, _fcd); #else action = action_arg; #endif } if (PASSED_ARG(ARGS_12)) { #ifdef _CRAYMPP delim = va_arg(args, _fcd); #else delim = delim_arg; #endif } if (PASSED_ARG(ARGS_13)) { #ifdef _CRAYMPP pad = va_arg(args, _fcd); #else pad = pad_arg; #endif } /* * The isf90 argument is not passed from CFT77. */ isf90 = 0; if (PASSED_ARG(ARGS_16)) { #ifdef _CRAYMPP unused1 = va_arg(args, int); unused2 = va_arg(args, int); isf90 = va_arg(args, int); #else isf90 = isf90_arg; #endif } #ifdef _CRAYMPP va_end(args); #endif errn = 0; OPENLOCK(); /* prevent other OPENs or CLOSEs right now */ #ifdef KEY /* Bug 4260 */ /* Before we open the first file in the course of execution, we must * set byte-swapping based on __io_byteswap_value defined by Fortran * main in response to command-line options like -byteswapio */ __io_byteswap(); #endif /* KEY Bug 4260 */ unum = *unitn; /* UNIT= is required by compiler */ a.ounit = unum; STMT_BEGIN(unum, 0, T_OPEN, NULL, &cfs, cup); /* lock unit if open */ if (!GOOD_UNUM(unum) || RSVD_UNUM(unum)) OPNERR(FEIVUNTO); a.oerr = (errf || iostat) ? 1 : 0; /* Catch errs if ERR | IOSTAT */ /* * Process FILE= and RECL= specifiers. */ if (_fcdtocp(file) != NULL) { a.ofile = _fcdtocp(file); a.ofilelen = _fcdlen (file); } else { a.ofile = NULL; a.ofilelen = 0; } if (recl != NULL) a.orecl = *recl; else a.orecl = 0; /* 0 means unspecified */ /* * Process remaining specifiers. * * Specifier Default Error Code * Value List */ SETSPEC(status, OS_UNKNOWN, FEOPSTAT, 5, S(OLD) S(NEW) S(SCRATCH) S(UNKNOWN) S(REPLACE)); #if !defined(__mips) && !defined(_LITTLE_ENDIAN) SETSPEC(access, OS_SEQUENTIAL, FEOPACCS, 2, S(DIRECT) S(SEQUENTIAL)); SETSPEC(position, OS_ASIS, FEOPPOSN, 3, S(APPEND) S(ASIS) S(REWIND)); #else /* not __mips and not little endian */ SETSPEC(access, OS_SEQUENTIAL, FEOPACCS, 4, S(DIRECT) S(SEQUENTIAL) S(KEYED) S(APPEND)); if ((_fcdtocp(access) != NULL) && (a.oaccess == OS_OAPPEND)) { if (_fcdtocp(position) != NULL) { OPNERR(FEOPACCS); /* Invalid ACCESS */ } #ifdef KEY /* Bug 86 */ /* The Fortran 90 standard does not place a constraint * on the value of 'access=', so there's no need to * issue an error message in normal or -ansi mode (and * "isf90" seems always to be set anyway). */ #else else if (isf90) { OPNERR(FEOPACCS); /* Invalid ACCESS */ } #endif /* KEY */ else { a.oposition = OS_APPEND; a.oaccess = OS_SEQUENTIAL; } } else { /* use POSITION= if ACCESS='APPEND' is not provided */ SETSPEC(position, OS_ASIS, FEOPPOSN, 3, S(APPEND) S(ASIS) S(REWIND)); } #endif /* not __mips and not little endian */ formdef = (a.oaccess == OS_SEQUENTIAL) ? OS_FORMATTED : OS_UNFORMATTED; SETSPEC(form, formdef, FEOPFORM, 4, S(UNFORMATTED) S(FORMATTED) S(BINARY) S(SYSTEM)); SETSPEC(blank, OS_NULL, FEOPBLNK, 2, S(ZERO) S(NULL)); SETSPEC(action, OS_ACTION_UNSPECIFIED, FEOPACTB, 3, S(READ) S(WRITE) S(READWRITE)); SETSPEC(delim, OS_NONE, FEOPDLMB, 3, S(APOSTROPHE) S(QUOTE) S(NONE)); SETSPEC(pad, OS_YES, FEOPPADB, 2, S(YES) S(NO)); /* * Diagnose errors. */ if (recl != NULL && a.orecl <= 0) OPNERR(FEOPRECL); /* Invalid RECL */ if (recl == NULL && a.oaccess == OS_DIRECT) OPNERR(FEOPRCRQ); /* RECL required for direct */ if (_fcdtocp(blank) != NULL && (a.oform == OS_UNFORMATTED || a.oform == OS_BINARY || a.oform == OS_SYSTEM)) OPNERR(FEOPBKIV); /* BLANK= invalid if unform. */ if (_fcdtocp(delim) != NULL && (a.oform == OS_UNFORMATTED || a.oform == OS_BINARY || a.oform == OS_SYSTEM)) OPNERR(FEOPDLMI); /* DELIM invalid if unform. */ if (_fcdtocp(pad) != NULL && (a.oform == OS_UNFORMATTED || a.oform == OS_BINARY || a.oform == OS_SYSTEM)) OPNERR(FEOPPDIV); /* PAD= invalid if unformatted*/ if (_fcdtocp(position) != NULL && a.oaccess == OS_DIRECT) OPNERR(FEOPPSIV); /* POSITION invalid on direct */ /* * Done with OPEN specifiers. */ if (OPEN_UPTR(cup) && cup->ufs == FS_AUX) OPNERR(FEOPAUXT); /* Unit is opened by AQ/MS/DR/WA IO */ if (OPEN_UPTR(cup) && (_fcdtocp(file) == NULL || (cup->ufnm != NULL && strncmp(cup->ufnm, a.ofile, a.ofilelen) == 0))) { /* * A re-open of the same file occurs when the FILE= specifier * is present and matches the name with which the file was * originally opened, or if the FILE= specifier is absent * (these are re-opens of the same file by definition). * * In this case, only a subset of the OPEN specifiers * (the BLANK=, PAD=, and DELIM= specifiers) may be provided * with values which are different from those currently in * effect. Any new value passed with the BLANK=, PAD=, or * DELIM= specifier will go into effect. * * An attempt to change the other OPEN specifers is an error. */ if (_fcdtocp(status) != NULL && a.ostatus != cup->uostatus) { if (a.ostatus == OS_NEW && cup->uostatus == OS_OLD) { OPNERR(FEOPNNEW); /* STATUS=NEW became OLD */ } else OPNERR(FEOPCBNK); /* Can't change STATUS */ } if (_fcdtocp(access) != NULL && ((a.oaccess == OS_SEQUENTIAL && cup->useq == 0 ) || (a.oaccess == OS_DIRECT && cup->useq == 1) )) OPNERR(FEOPCBNK); /* Can't change ACCESS */ if (_fcdtocp(form) != NULL && ((a.oform == OS_FORMATTED && cup->ufmt == 0) || (a.oform == OS_UNFORMATTED && cup->ufmt == 1) )) OPNERR(FEOPCBNK); /* Can't change FORM */ if (recl != NULL && a.orecl != cup->urecl) OPNERR(FEOPCBNK); /* Can't change RECL */ if (_fcdtocp(position) != NULL && a.oposition != cup->uposition) OPNERR(FEOPCBNK); /* Can't change POSITION */ if (_fcdtocp(action) != NULL && a.oaction != cup->uaction) OPNERR(FEOPCBNK); /* Can't change ACTION */ /* * Place into effect any new BLANK=, DELIM=, or PAD= specifier * provided on the OPEN statement. */ if (_fcdtocp(blank) != NULL) cup->ublnk = (a.oblank == OS_ZERO); if (_fcdtocp(delim) != NULL) cup->udelim = a.odelim; if (_fcdtocp(pad) != NULL) cup->upad = a.opad; } else { /* * Open the unit. If the unit is currently connected, it * will be closed and then reopened for the new file. */ /* KEY: we do want this check */ #if (!defined(__mips) && !defined(_LITTLE_ENDIAN)) || defined(KEY) /* * SGI's F77 and old F90 allowed open with status=NEW, * OLD, or REPLACE without FILE specifier, so we continue * to allow it on MIPS systems. */ if (a.ostatus == OS_REPLACE && a.ofile == NULL) OPNERR(FEOPFNRQ); /* FILE= required for 'REPLACE' */ if (a.ostatus == OS_OLD && a.ofile == NULL) OPNERR(FEOPFNRQ); /* FILE= required for 'OLD' */ if (a.ostatus == OS_NEW && a.ofile == NULL) OPNERR(FEOPFNRQ); /* FILE= required for 'NEW' */ #endif #ifdef _CRAYMPP /* * This check should be added for CX/CEA someday. */ if (a.ostatus == OS_SCRATCH && a.ofile != NULL) OPNERR(FEOPFNIV); /* FILE= should not be specified */ #endif /* * We assume that _f_open does not change cfs.f_cu if * the unit was already open. */ errn = _f_open(&cfs, &cup, &a, isf90); } /* * Process results */ opn_done: error = (errn != 0) ? IO_ERR : IO_OKAY; if (iostat != NULL) *iostat = errn; else if (error != IO_OKAY && errf == 0) if (errn == FEIVUNTO) _ferr(&cfs, errn, unum); else _ferr(&cfs, errn); STMT_END(cup, T_OPEN, NULL, NULL); /* unlock unit */ OPENUNLOCK(); return(CFT77_RETVAL(error)); }
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; }
flush_( #endif const unum_t *unump, /* Fortran unit number */ _f_int *istat /* Optional error status parameter */ ) { register short statp; /* 1 if istat parameter passed */ int *rstat; /* Pointer to return status word */ int errn; /* Error status */ register unum_t unum; /* unit number */ unit *cup; struct fiostate cfs; #ifdef KEY /* Bug 1683 */ /* G77 says that if unit is missing, flush all units */ if (0 == unump) { /* Find all open Fortran units not connected by * WOPEN/OPENMS/OPENDR/AQOPEN */ unit *uptr; for (uptr = _get_next_unit(NULL, 0, 0); uptr != NULL; uptr = _get_next_unit(uptr, 0, 0)) { unum_t unum = uptr->uid; if (OPEN_UPTR(uptr) && uptr->ufs != FS_AUX) { __flush_f90(&unum, 0); } } return; } #endif /* KEY Bug 1683 */ unum = *unump; statp = #ifdef _UNICOS (_numargs() >= 2) #else (istat != NULL) #endif ? 1 : 0; rstat = statp ? istat : &errn; *rstat = FLUSH_OK; /* Assume FLUSH works */ STMT_BEGIN(unum, 0, T_FLUSH, NULL, &cfs, cup); /* lock the unit */ if (cup == NULL) { if (!GOOD_UNUM(unum)) errn = FEIVUNIT; else { #ifdef KEY /* Bug 6433 */ /* G77 ignores flush on an unopened unit, so we do likewise. The test for * RSVD_UNUM is useless because we no longer have any (we automatically open * units 5 and 6 on stdin and stdout, but we do not "reserve" them: the * user can explicitly open them on named files.) */ goto flush_done; #else /* KEY Bug 6433 */ /* * Ignore FLUSH on unopened reserved unit. */ if (RSVD_UNUM(unum)) goto flush_done; errn = FENOTOPN; #endif /* KEY Bug 6433 */ } FLUSH_ERROR1(errn, unum); } if (cup->useq == 0) { /* If file opened for direct access */ *rstat = NOT_SUPPORTED; goto flush_done; } if ( ! cup->uwrt) /* If not writing, do nothing */ goto flush_done; switch (cup->ufs) { struct ffsw fstat; /* ffflush() status */ case FS_FDC: if (__ffflush(cup->ufp.fdc, &fstat) < 0) FLUSH_ERROR(fstat.sw_error); break; case FS_TEXT: #ifdef KEY #if defined(__CYGWIN__) || defined(__APPLE__) #define _IO_NO_WRITES 8 #endif if (!(cup->ufp.std->_flags & _IO_NO_WRITES)) if (fflush(cup->ufp.std) == EOF) FLUSH_ERROR(errno); break; #endif case STD: #if !defined(_LITTLE_ENDIAN) if (FILE_FLAG(cup->ufp.std) & _IOWRT) if (fflush(cup->ufp.std) == EOF) FLUSH_ERROR(errno); #endif break; default: *rstat = NOT_SUPPORTED; } /* switch */ flush_done: STMT_END(cup, T_FLUSH, NULL, &cfs); /* unlock the unit */ return; }
void _fcontext(FIOSPTR css) { register short is_int; /* 1 if internal file I/O */ register int utindex; char *file, *fstruct, *idir, *oprn, *sepr; register unum_t unum; /* Fortran unit number */ long stmt; /* I/O statement type */ unit *cup; /* Pointer to unit table entry */ /* Just return if no Fortran statement info is available */ if (css == NULL) return; /* Retrieve global data */ cup = css->f_cu; unum = css->f_curun; stmt = css->f_iostmt; is_int = css->f_intflg; file = (!OPEN_UPTR(cup) || cup->alfnm == NULL) ? NULL : cup->alfnm; if (stmt & TF_READ) idir = " READ from"; else if (stmt & TF_WRITE) idir = " WRITE to"; else idir = ""; /* Determine the type of error */ switch (stmt) { case T_RSF: /* Sequential formatted READ */ case T_WSF: /* Sequential formatted WRITE */ oprn = " sequential formatted"; break; case T_RSU: /* Sequential unformatted READ */ case T_WSU: /* Sequential unformatted WRITE */ oprn = " sequential unformatted"; break; case T_RDF: /* Direct formatted READ */ case T_WDF: /* Direct formatted WRITE */ oprn = " direct access formatted"; break; case T_RDU: /* Direct unformatted READ */ case T_WDU: /* Direct unformatted WRITE */ oprn = " direct access unformatted"; break; case T_RLIST: /* List-directed READ */ case T_WLIST: /* List-directed WRITE */ oprn = " list-directed"; break; case T_RNL: /* Namelist READ */ case T_WNL: /* Namelist WRITE */ oprn = " namelist"; break; case T_BUFOUT: /* BUFFER OUT */ oprn = " BUFFER OUT on"; idir = ""; break; case T_BUFIN: /* BUFFER IN */ oprn = " BUFFER IN from"; idir = ""; break; case T_OPEN: /* OPEN */ oprn = "n OPEN of"; idir = ""; break; case T_REWIND: /* REWIND */ oprn = " REWIND on"; idir = ""; break; case T_BACKSPACE:/* BACKSPACE */ oprn = " BACKSPACE on"; idir = ""; break; case T_ENDFILE: /* ENDFILE */ oprn = "n ENDFILE on"; idir = ""; break; case T_CLOSE: /* CLOSE */ oprn = " CLOSE of"; idir = ""; break; case T_INQF: /* INQUIRE */ oprn = "n INQUIRE by file on"; unum = -1; idir = ""; break; case T_INQU: /* INQUIRE */ oprn = "n INQUIRE by unit on"; idir = ""; break; case T_GETPOS: /* GETPOS */ oprn = " GETPOS on"; idir = ""; break; case T_SETPOS: /* SETPOS */ oprn = " SETPOS on"; idir = ""; break; case T_LENGTH: /* LENGTH */ oprn = " LENGTH function on"; idir = ""; break; case T_UNIT: /* UNIT */ oprn = " UNIT function on"; idir = ""; break; case T_TAPE: /* TAPE */ oprn = " tape operation on"; idir = ""; break; default: oprn = "n I/O operation on"; break; } /* switch */ (void) fprintf(errfile, "\nEncountered during a%s%s", oprn, idir); if (is_int) (void) fprintf(errfile, " an internal file (character variable)\n"); else { if (unum != -1) { (void) fprintf(errfile, " unit %lld\n", unum); (void) fprintf(errfile, "Fortran unit %lld is ", unum); if (!OPEN_UPTR(cup)) { if (GOOD_UNUM(unum)) (void) fprintf(errfile, "not connected\n"); else (void) fprintf(errfile, "not a valid unit number\n"); } else { (void) fprintf(errfile, "connected to "); utindex = IO_TYPE(cup); fstruct = FIO_STRUCT(_deduce_fstruct( cup->ufs, (struct fdinfo*)cup->ufp.fdc, cup->ufmt)); if (fstruct == NULL) fstruct = ""; (void) fprintf(errfile, "a %s %s file", FIO_METHOD(utindex), fstruct); if (file == NULL && cup->ufs != FS_FDC) { if (cup->ufp.std == stdin) file = "standard input"; else if (cup->ufp.std == stdout) file = "standard output"; else if (cup->ufp.std == stderr) file = "standard error"; else file = "unnamed"; (void) fprintf(errfile, "\n (%s).\n", file); } else { /* Format to under 80 chars. per line */ if ((int)strlen(file) > 8) sepr = ":\n "; else sepr = ": "; (void) fprintf(errfile, "%s\"%s\"\n", sepr, file); } /* * If the connection is formatted and there's * a format, print the format and point to * the current position therein. */ if ((stmt & TF_FMT) && css->u.fmt.u.fe.fmtbuf != NULL) { int i, offset; offset = css->u.fmt.u.fe.fmtcol - 2 + fprintf(errfile, " Current format: "); if (css->u.fmt.u.fe.fmtnum > 0) /* If format label, print it */ offset = offset + fprintf(errfile, "%5d FORMAT", css->u.fmt.u.fe.fmtnum); (void) fprintf(errfile, "%.*s\n", css->u.fmt.u.fe.fmtlen, css->u.fmt.u.fe.fmtbuf); for (i = 0; i <= offset; i++) (void) fprintf(errfile, " "); (void) fprintf(errfile, "^\n"); } } } else /* Unknown state */ if (file == NULL) (void) fprintf(errfile, " an indeterminate file\n"); else (void) fprintf(errfile, " file \"%s\"\n", file); } /* * Print name of the routine which called _ferr() which called us. */ #ifdef _UNICOS { int len, lineno; char name[MAX_ENT_LEN]; len = _who_called_me(&lineno, name, MAX_ENT_LEN, 2); if (len > 0) { /* If no error */ name[len] = '\0'; (void) fprintf(errfile, "Error initiated at line %d in routine '%s'.\n", lineno, name); } } #endif #ifdef _CRAY2 /* * Print traceback * * On CX/CEA systems, the traceback is printed by the abort() call. */ (void) _tracebk(25, errfile); #endif return; }