_f_int8 ftellf90_8_( _f_int8 *unump) { _f_int8 pos; register unum_t unum; unit *cup; struct fiostate cfs; unum = *unump; /* lock the unit */ STMT_BEGIN(unum, 0, T_GETPOS, NULL, &cfs, cup); /* * If not connected, do implicit open. Abort if open fails. */ if (cup == NULL) cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL); /* if direct access file */ if (cup->useq == 0) _ferr(&cfs, FEBIONDA, "GETPOS"); /* * Make the appropriate call depending on file structure to * get the current file position. Postion routines are file * structure dependent. * * Simulate the IPOS=GETPOS(IUN) call */ pos = 0; switch( cup->ufs ) { case FS_TEXT: case STD: pos = ftell(cup->ufp.std); break; case FS_FDC: _ferr(&cfs, FDC_ERR_NOSUP); break; case FS_AUX: _ferr(&cfs, FEMIXAUX); break; default: _ferr(&cfs, FEINTFST); } getpos_done: STMT_END(cup, T_GETPOS, NULL, &cfs); return(pos); }
void ttynamf90_(char *name, int strlen, int *u) { int rtrn, errval; unum_t unum; unit *cup; struct fiostate cfs; char *t = NULL; #if defined(_LITTLE_ENDIAN) char *ttyname(int); #endif unum = *u; STMT_BEGIN(unum, 0, T_INQU, NULL, &cfs, cup); errval = 0; if (cup == NULL && !GOOD_UNUM(unum)) _ferr(&cfs, FEIVUNIT, unum); /* invalid unit number */ if (cup == NULL) errval = FEIVUNIT; /* unit is not open */ else if (cup->usysfd == -1) errval = FEIVUNIT; /* file is not disk-resident */ else { t = ttyname(cup->usysfd); } STMT_END(cup, T_INQU, NULL, &cfs); /* unlock the unit */ if (t==NULL) t=""; _b_char(t, name, strlen); return; }
int fnum_(int *u) #endif /* KEY Bug 1683 */ { int n, retval; unum_t unum; unit *cup; struct stat buf; struct fiostate cfs; int stat; register int errf; /* ERR processing flag */ unum = *u; retval = -1; if (unum != 0 && unum != 5 && unum != 6) return retval; STMT_BEGIN(unum, 0, T_INQU, NULL, &cfs, cup); if (cup == NULL && !GOOD_UNUM(unum)) _ferr(&cfs, FEIVUNIT, unum); /* invalid unit number */ if (cup == NULL) cup = _imp_open( &cfs, SEQ, FMT, unum, errf, &stat); retval = fileno ( cup->ufp.std ); STMT_END(cup, T_INQU, NULL, &cfs); /* unlock the unit */ return retval; }
void SETPOS( _f_int *unump, _f_int *len, _f_int *pa, _f_int *stat) { register int errn; register int narg; register unum_t unum; unit *cup; struct fiostate cfs; unum = *unump; STMT_BEGIN(unum, 0, T_SETPOS, NULL, &cfs, cup); /* lock the unit */ /* * If not connected, do an implicit open. Abort if the open fails. */ if (cup == NULL) cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL); if (cup->useq == 0) /* If direct access file */ _ferr(&cfs, FEBIONDA, "SETPOS"); /* * Do the setpos. */ narg = _numargs(); if ( narg == OLD ) { errn = _setpos(&cfs, cup, len, 1); } else { if (*len <= 0) errn = FEBIOSNT; else errn = _setpos(&cfs, cup, pa, *len); } if (narg >= STAT) *stat = errn; else if (errn != OK) _ferr(&cfs, errn); STMT_END(cup, T_SETPOS, NULL, &cfs); /* unlock the unit */ }
int $RFI( _fcd funit, /* Address of unit number or FCD */ _fcd format, /* Address of format (FCD or hollerith) */ long *err, /* Address of error processing address */ long *end, /* Address of end processing address */ _f_int *iostat, /* Address of IOSTAT variable */ _f_int *rec, /* Address of direct access record no. */ fmt_type **pform, /* Address of address of parsed format */ long *inumelt, /* Address of int. array element count */ long *inumcfe /* Address of number of format elements */ ) #endif { register int endf; /* END processing flag */ register int errf; /* ERR processing flag */ register int errn; /* Error number */ register int iost; /* I/O statement type */ register int iotp; /* I/O type */ register recn_t recn; /* Record number */ register unum_t unum; /* Unit number */ fmt_type **prsfmt; /* Parsed format info. */ unit *cup; /* Unit table pointer */ FIOSPTR css; /* I/O statement state */ #ifdef _CRAYMPP va_list args; _fcd format; /* Address of format (FCD or hollerith) */ long *err; /* Address of error processing address */ long *end; /* Address of end processing address */ _f_int *iostat; /* Address of IOSTAT variable */ _f_int *rec; /* Address of direct access record no. */ fmt_type **pform; /* Address of address of parsed format */ long *inumelt; /* Address of int. array element count */ long *inumcfe; /* Address of number of format elements */ #endif GET_FIOS_PTR(css); /* Check if recursive triple-call I/O */ if (css->f_iostmt != 0) _ferr(css, FEIOACTV); #ifdef _CRAYMPP va_start(args, funit); format = va_arg(args, _fcd); err = va_arg(args, long *); end = va_arg(args, long *); iostat = va_arg(args, _f_int *); rec = va_arg(args, _f_int *); if (_numargs() > ARGS_6) { pform = va_arg(args, fmt_type **); if (_numargs() > ARGS_7) { inumelt = va_arg(args, long *); if (_numargs() > ARGS_8) { inumcfe = va_arg(args, long *); }
int _BACK( _f_int *unump, /* Fortran unit number */ _f_int *iostat, /* IOSTAT= variable address, or NULL */ int errf) /* 1 if ERR= specifier is present */ { register int errn; /* nonzero when error is encountered */ register unum_t unum; unit *cup; struct fiostate cfs; errn = 0; unum = *unump; STMT_BEGIN(unum, 0, T_BACKSPACE, NULL, &cfs, cup); /* lock the unit */ if (!GOOD_UNUM(unum)) { errn = FEIVUNIT; /* Invalid unit number */ goto backspace_done; } /* * BACKSPACE on unopened unit is OK, and does nothing. For opened units, * call the low level backspace routine. */ if (cup == NULL) goto backspace_done; if (cup->pnonadv) { /* There is a current record */ if (cup->uwrt) { errn = _nonadv_endrec(&cfs, cup); if (errn != 0) goto backspace_done; } cup->pnonadv = 0; /* Flag no current record */ } errn = _unit_bksp(cup); backspace_done: if (iostat != NULL) *iostat = errn; else if (errn != 0 && (errf == 0)) _ferr(&cfs, errn, unum); /* Pass unum to _ferr * in case of FEIVUNIT error */ STMT_END(cup, T_BACKSPACE, NULL, &cfs); /* unlock the unit */ errn = (errn != 0) ? IO_ERR : IO_OKAY;/* 1 if error; 0 if no error */ return(CFT77_RETVAL(errn)); }
int $DFI( long *len, /* Address of length (in characters) */ _fcd format, /* Address of format (FCD or hollerith) */ _fcd fwa, /* Address of output character string */ fmt_type **_arg4, /* Unused (old pform arugment) */ long *_arg5, /* Unused */ long *_arg6, /* Unused */ fmt_type **pform, /* Address of address of parsed format */ long *inumelt, /* Address of int. array element count */ long *inumcfe /* Address of number of format elements */ ) #endif { long mone = -1L; _fcd fch; int nargs; #ifdef _CRAYMPP va_list args; _fcd format; /* Address of format (FCD or hollerith) */ _fcd fwa; /* Address of output character string */ fmt_type **_arg4; /* Unused (old pform arugment) */ long *_arg5; /* Unused */ long *_arg6; /* Unused */ fmt_type **pform; /* Address of address of parsed format */ long *inumelt; /* Address of int. array element count */ long *inumcfe; /* Address of number of format elements */ va_start(args, len); format = va_arg(args, _fcd); fwa = va_arg(args, _fcd); #endif if (*len <= 0) /* If length is zero or negative */ _ferr(NULL, FEDECDRL); /* Invalid DECODE record length */ /* Insert length in character descriptor */ fch = _cptofcd(_fcdtocp(fwa), *len); nargs = _numargs(); #ifdef _CRAYMPP if (nargs >= ARGS_7) { _arg4 = va_arg(args, fmt_type **); _arg5 = va_arg(args, long *); _arg6 = va_arg(args, long *); pform = va_arg(args, fmt_type **); if (nargs >= ARGS_9) { inumelt = va_arg(args, long *); inumcfe = va_arg(args, long *); }
void $RB$( _f_int *biunit, /* Unit */ _f_int *recmode, /* Mode */ gfptr_t bloc, /* Beginning location */ gfptr_t eloc, /* Ending location */ int *type) /* Data type */ { register short type77; register unum_t unum; type_packet tip; struct f90_type ts; unit *cup; struct fiostate cfs; unum = *biunit; STMT_BEGIN(unum, 0, T_BUFIN, NULL, &cfs, cup); /* * If not connected, do an implicit open. Abort if the open fails. */ if (cup == NULL) cup = _imp_open77(&cfs, SEQ, UNF, unum, 0, NULL); type77 = *type & 017; CREATE_F90_INFO(ts, tip, type77); #if NUMERIC_DATA_CONVERSION_ENABLED if (cup->unumcvrt || cup->ucharset) { register int ret; ret = _get_dc_param(&cfs, cup, ts, &tip); if (ret != 0) _ferr(&cfs, ret); } #endif _PRAGMA_INLINE(_rb) _rb(&cfs, cup, recmode, bloc, eloc, &tip); return; }
/* * _BUFFERIN f90 BUFFER IN wrapper (also a headache remedy) */ void _BUFFERIN(struct bio_spec_list *bisl) { register unum_t unum; type_packet tip; struct f90_type ts; unit *cup; struct fiostate cfs; assert ( bisl->version == 0 ); unum = *bisl->unit; ts = *bisl->tiptr; STMT_BEGIN(unum, 0, T_BUFIN, NULL, &cfs, cup); /* * If not connected, do an implicit open. Abort if the open fails. */ if (cup == NULL) cup = _imp_open(&cfs, SEQ, UNF, unum, 0, NULL); tip.type77 = -1; tip.type90 = ts.type; tip.intlen = ts.int_len; tip.extlen = ts.int_len; tip.elsize = ts.int_len >> 3; tip.stride = 1; #if NUMERIC_DATA_CONVERSION_ENABLED if (cup->unumcvrt || cup->ucharset) { register int ret; ret = _get_dc_param(&cfs, cup, ts, &tip); if (ret != 0) _ferr(&cfs, ret); } #endif _PRAGMA_INLINE(_rb); _rb( &cfs, cup, bisl->recmode, bisl->bloc, bisl->eloc, &tip); return; }
void TSYNC(_f_int *unump, _f_int *istat) { register int ret; unit *cup; /* Unit table pointer */ FIOSPTR css; /* I/O statement state */ GET_FIOS_PTR(css); STMT_BEGIN(*unump, 0, T_TAPE, NULL, css, cup); if (cup == NULL) _ferr(css, FENOTOPN); *istat = 0; if (cup->ufs == FS_FDC) { ret = XRCALL(cup->ufp.fdc, fcntlrtn) cup->ufp.fdc, FC_TSYNC, 0, &cup->uffsw); if (ret < 0) *istat = cup->uffsw.sw_error; }
void ENDSP(_f_int *unump, _f_int *istat) { register int ret; unit *cup; FIOSPTR css; GET_FIOS_PTR(css); STMT_BEGIN(*unump, 0, T_TAPE, NULL, css, cup); if (cup == NULL) _ferr(css, FENOTOPN); *istat = 0; if (cup->ufs == FS_FDC) { ret = XRCALL(cup->ufp.fdc, fcntlrtn) cup->ufp.fdc, FC_ENDSP, 0, &cup->uffsw); if (ret < 0) *istat = cup->uffsw.sw_error; else cup->uspcproc = 0; }
/* * _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); }
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 _RUI( _fcd _Unitid, /* Pointer to unit identifier */ _fcd _arg2, /* Unused */ long *err, /* Address of error processing address */ long *end, /* Address of end processing address */ _f_int *iostat, /* Address of IOSTAT variable */ _f_int *rec /* Address of direct access record no. */ #ifndef _UNICOS ,FIOSPTR cssa /* Statement state structure */ #endif ) #endif { register int errf; /* Error processing flag */ register int errn; /* Error number */ register int iost; /* I/O statement type */ register int iotp; /* I/O type */ register recn_t recn; /* Direct access record number */ register unum_t unum; /* Actual unit number */ unit *cup; /* Pointer to unit table entry */ FIOSPTR css; /* Statement state structure */ #ifdef _CRAYMPP va_list args; _fcd _arg2; /* Unused */ long *err; /* Address of error processing address*/ long *end; /* Address of end processing address */ _f_int *iostat; /* Address of IOSTAT variable */ _f_int *rec; /* Address of direct access record no.*/ #endif #ifdef _UNICOS GET_FIOS_PTR(css); /* Check if recursive triple-call I/O */ if (css->f_iostmt != 0) _ferr(css, FEIOACTV); #else css = cssa; #endif #ifdef _CRAYMPP va_start(args, _Unitid); _arg2 = va_arg(args, _fcd); err = va_arg(args, long *); end = va_arg(args, long *); iostat = va_arg(args, _f_int *); rec = va_arg(args, _f_int *); va_end(args); #endif errn = 0; /* Establish error processing options */ if (iostat != NULL) *iostat = 0; /* Clear IOSTAT variable, if extant */ errf = ((err != NULL) || (iostat != NULL)); iost = T_RSU; iotp = SEQ; /* Assume sequential */ unum = **(_f_int **)&_Unitid; if (rec != NULL) { /* If direct access */ iost = T_RDU; /* Set direct unformatted read */ iotp = DIR; recn = *rec; } STMT_BEGIN(unum, 0, iost, NULL, css, cup); if (cup == NULL) { /* if not connected */ int stat; cup = _imp_open77(css, iotp, UNF, unum, errf, &stat); if (cup == NULL) { errn = stat; goto error; } } /* Record error processing options in the unit */ cup->uiostat = iostat; cup->uflag = (err != NULL ? _UERRF : 0) | (end != NULL ? _UENDF : 0) | (iostat != NULL ? _UIOSTF : 0); /* Perform error checking */ if (cup->ufs == FS_AUX) { errn = FEMIXAUX; /* Can't mix auxiliary and Fortran I/O */ ERROR0(errf, errn); } if ((cup->uaction & OS_READ) == 0) { errn = FENOREAD; /* No read permission */ ERROR0(errf, errn); } if (cup->ufmt) { /* If unformatted attempted on formatted file */ errn = FEUNFMIV; /* Unformatted not allowed */ ERROR0(errf, errn); } /* If sequential and writing, disallow read after write */ if (cup->useq && cup->uwrt != 0) { errn = FERDAFWR; /* Read after write */ ERROR0(errf, errn); } /* Preset fields in unit table */ cup->ueor_found = NO; /* Clear EOR */ cup->uwrt = 0; cup->ulastyp = DVTYPE_TYPELESS; if (iotp == DIR) { /* If direct access */ if (cup->useq) /* If direct attempted on seq. file */ errn = FEDIRTIV; /* Direct access not allowed */ else errn = _unit_seek(cup, recn, iost); if (errn != 0) { ERROR1(errf, errn, recn); } } else { /* Else sequential access */ if (cup->useq == 0) { /* If seq. attempted on direct file */ errn = FESEQTIV; /* Sequential not allowed */ ERROR0(errf, errn); } #if PURE_ENABLED if (cup->upure && cup->upuretype != P_RDWR) { /* * Set the upuretype field to P_RDWR mode unless it has * previously been set to P_BUFIO by a BUFFER IN/OUT * statement. This check prevents the intermixing of * READ/WRITE I/O with BUFFER IN/BUFFER OUT I/O when * '-s pure' is assigned. */ if (cup->upuretype == P_BUFIO) { errn = FEMIXBUF; ERROR0(errf, errn); } cup->upuretype = P_RDWR; } #endif } if (errn != 0) ERROR0(errf, errn); return(CFT77_RETVAL(IO_OKAY)); error: if (iostat != NULL) *iostat = errn; /* Set IOSTAT variable to error */ if (cup != NULL) /* If we have a unit */ cup->uflag |= (errn > 0) ? _UERRC : _UENDC;/* Set status */ #ifdef _UNICOS return(CFT77_RETVAL(_RUF())); #else return(CFT77_RETVAL(_RUF(css))); #endif }
static void _rb( FIOSPTR css, /* Current Fortran I/O state */ unit *cup, /* Unit pointer */ _f_int *recmode, /* Mode */ gfptr_t bloc, /* Beginning location */ gfptr_t eloc, /* Ending location */ type_packet *tip) /* Type information packet */ { register int bytshft; register int mode; register long bytes; register long elsize; register long itemlen; register long items; register long stat; register ftype_t type90; int state; char *uda, *udax; #ifdef _CRAYT3D register short shared; register long ntot; register long numleft; long shrd[MAXSH]; #endif if (cup->useq == 0) /* If direct access file */ _ferr(css, FEBIONDA, "BUFFER IN"); if (cup->ufmt) /* If formatted file */ _ferr(css, FEBIONFM, "BUFFER IN"); if (cup->uerr && !cup->unitchk) _ferr(css, cup->uffsw.sw_error); /* * This check taken out temporarily because we'd like to be able to * follow an ENDFILE statement or a READ which encounters an endfile * record with a BUFFER IN statement. The sticky EOF principle should * permit such a BUFFER IN to simply return an EOF status. But what * really happens is the preceding ENDFILE or READ statement sets * cup->uend, triggering an error here. We really need a flag to * store the status of the previous BUFFER IN/OUT statement which is * separate from cup->uend. * * if (cup->uend && !cup->unitchk) * _ferr(css, FERDPEOF); */ cup->unitchk = 0; cup->uerr = 0; elsize = tip->elsize; /* Data size in bytes */ type90 = tip->type90; /* * Adjust the word count depending on the type. */ bytshft = ((sizeof(elsize) << 3) - 1) - _leadz(elsize); /* log2(elsize) */ if (type90 == DVTYPE_ASCII) { /* If character item */ uda = _fcdtocp(bloc.fcd); udax = _fcdtocp(eloc.fcd); itemlen = _fcdlen (eloc.fcd); } else { #ifdef _CRAYT3D shared = 0; if (_issddptr(bloc.v)) { int *tmpptr; /* Shared data */ if (!_issddptr(eloc.v)) { _ferr(css, FEINTUNK); } shared = 1; ntot = 0; if ((cup->ufs == FS_FDC) && (cup->uflagword & FFC_ASYNC)) { /* When we can do I/O from shared memory */ /* we can support this. */ _ferr(css, FESHRSUP); } /* * When compiler spr 76429 (on T3D) is closed, we can try replacing * the lines that use tmpptr with this. * items = _sdd_read_offset((void *)eloc.v) - * _sdd_read_offset((void *)bloc.v) + 1; */ uda = bloc.v; /* temporary */ udax = eloc.v; tmpptr = (int *)((int)udax & 0x7fffffffffffffff); items = *(tmpptr + 1); tmpptr = (int *)((int)uda & 0x7fffffffffffffff); items = items - *(tmpptr + 1) + 1; } else #endif /* _CRAYT3D */ { uda = bloc.v; udax = eloc.v; } itemlen = elsize; } #ifdef _CRAYT3D if (shared) { bytes = items << bytshft; } else #endif { bytes = (udax - uda) + itemlen; items = bytes >> bytshft; } if (bytes < 0) _ferr(css, FEBIOFWA, "BUFFER IN"); mode = (*recmode < 0) ? PARTIAL : FULL; cup->urecmode = mode; cup->uwrt = 0; state = CNT; if ((items << bytshft) != bytes) _ferr(css, FEBIOFWD); #ifdef _CRAYT3D if ( !shared && cup->uasync ) { #else if (cup->uasync) { #endif int ubc = 0; WAITIO(cup, _ferr(css, cup->uffsw.sw_error)); #if defined(_UNICOS) || defined(NUMERIC_DATA_CONVERSION_ENABLED) /* * Pad word-aligned numeric data on word boundaries within * the record for CRI and some foreign data formats. */ if ((cup->urecpos & cup->ualignmask) != 0 && type90 != DVTYPE_ASCII && elsize > 4 ) { int padubc; register int pbytes; int padval; COMPADD(cup, pbytes, padubc, padval); if (pbytes != 0) { stat = XRCALL(cup->ufp.fdc, readrtn) cup->ufp.fdc, WPTR2BP(&padval), pbytes, &cup->uffsw, PARTIAL, &padubc); if (stat != pbytes || FFSTAT(cup->uffsw) != FFCNT) { cup->uerr = 1; goto badpart; } cup->urecpos += (stat << 3) - padubc; } }
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; }
int _rdunf( #endif FIOSPTR css, /* Current Fortran I/O statement state */ unit *cup, /* Unit pointer */ void *ptr, /* Pointer to data */ type_packet *tip, /* Type information packet */ int _Unused /* Unused by this routine */ ) { register short shared; /* 1 iff ptr points to shared data */ register int errn; /* Error number */ register int64 fillen; /* bit size of each element, on disk */ register long count; /* Number of data items */ register long elsize; /* element size in bytes */ register long i; register long incb; /* inc (in units of bytes) */ register long items; int status; long lbuf[LOCBUFLN]; void *frwdbuf; /* ptr to buffer passed to _frwd */ #ifdef _CRAYT3D register long elwords; /* element size in words */ #endif errn = 0; /* Clear error number */ shared = 0; /* Assume data is not shared */ count = tip->count; elsize = tip->elsize; fillen = tip->extlen; if (count == 0) return(0); if (tip->type90 == DVTYPE_ASCII) fillen = fillen * elsize; incb = tip->stride * elsize; /* Stride in bytes */ if ( cup->ueor_found ) { errn = FERDPEOR; goto done; } if (cup->useq == 0) { /* If direct access file */ register int64 newpos; register int64 recl; newpos = cup->urecpos + count * fillen; /* in bits */ recl = (int64) (cup->urecl); if ((recl << 3) < newpos) { /* * The user is asking for more data than can fit in a * RECL-sized record, so we abort here. */ errn = FERDPEOR; goto done; } } #ifdef _CRAYT3D if (_issddptr(ptr)) { /* ptr points to shared data descriptor. */ /* If we have a layer that handles sdds someday, we */ /* could check for that here and not set shared. */ /* We'd also probably want to make sure that we are */ /* not doing foreign data conversion */ css->f_shrdput = 1; shared = 1; elwords = elsize / sizeof(long); } #endif /* * If contiguous memory, transfer all data at once. */ if ((shared == 0) && ((count == 1) || (incb == elsize))) { register long ret; ret = _frwd(cup, ptr, tip, PARTIAL, (int *) NULL, (long *) NULL, &status); if ( ret == IOERR ) { errn = errno; goto done; } if ( status == EOR ) { cup->ueor_found = YES; cup->uend = BEFORE_ENDFILE; } else if ( status == CNT ) cup->uend = BEFORE_ENDFILE; if ( ret < count ) { if (status == EOF || status == EOD) goto endfile_record; errn = FERDPEOR; goto done; } return(0); } /* * Stride is such that memory is not contiguous, break the request * into chunks and do a scatter on the items when read. */ items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it into chunks */ assert( ! (shared && items == 0) ); /* don't support shared char */ if (items == 0) items = 1; /* must be character*BIG array*/ frwdbuf = lbuf; for ( i = 0; i < count; i += items ) { register long ret; /* trim the item count if not a full buffer's worth */ if (items > count - i) items = count - i; tip->count = items; /* * Read data into lbuf, scatter items from lbuf into the * user array, and then write out a chunk. If items == 1, * we suppress the extra data copy for performance and because * it might not fit in the lbuf if it is character*BIG data. * * We don't have to worry about shared data not fitting in * lbuf since character data is never shared. */ if ((items == 1) && (shared == 0)) frwdbuf = ptr; /* read directly to user array */ ret = _frwd(cup, frwdbuf, tip, PARTIAL, (int *) NULL, (long *) NULL, &status); #ifdef _CRAYT3D if (shared) _cpytosdd(ptr, lbuf, items, elwords, tip->stride, i); else #endif if (items > 1) _scatter_data (ptr, items, incb, elsize, lbuf); if ( ret == IOERR ) { errn = errno; goto done; } if ( status == EOR ) { cup->ueor_found = YES; /* If not last iteration, this is an error */ if ((i + ret) < count) { errn = FERDPEOR; goto done; } } if (i == 0) if (status == EOR || status == CNT) cup->uend = BEFORE_ENDFILE; /* * We know that items > 0 */ if ( ret < items ) { if (status == EOF || status == EOD) goto endfile_record; errn = FERDPEOR; goto done; } if (!shared) ptr = (char *) ptr + (ret * incb); } done: /* Process any error which occurred */ if (errn > 0) { if ((cup->uflag & (_UERRF | _UIOSTF)) == 0) _ferr(css, errn); /* Run-time error */ } else if (errn < 0) { if ((cup->uflag & (_UENDF | _UIOSTF)) == 0) _ferr(css, errn); /* EOF-type error */ } return(errn); endfile_record: /* * EOF/EOD is an error on direct access, an end * condition on sequential access. */ if (status == EOF) { cup->uend = PHYSICAL_ENDFILE; errn = FERDPEOF; } else { /* End of data */ if (cup->uend == 0) { cup->uend = LOGICAL_ENDFILE; errn = FERDPEOF; } else errn = FERDENDR; } if (!(cup->useq)) /* If direct access */ errn = FENORECN; /* Record does not exist */ goto done; }
int _wrunf( #endif FIOSPTR css, /* Current Fortran I/O statement state */ unit *cup, /* Unit pointer */ void *ptr, /* Pointer to data */ type_packet *tip, /* Type information packet */ int mode /* Mode argument to _fwwd() */ ) { register short shared; /* 1 iff ptr points to sdd */ register int errn; /* Error number */ register int64 fillen; /* bit size of each element, on disk */ register long count; /* Number of data items */ register long elsize; /* element size in bytes */ register long i; register long incb; /* inc (in units of bytes) */ register long items; long lbuf[LOCBUFLN]; void *fwwdbuf; /* ptr to buffer passed to _fwwd */ #ifdef _CRAYT3D register long elwords; /* element size in words */ #endif errn = 0; shared = 0; count = tip->count; elsize = tip->elsize; fillen = tip->extlen; if (count == 0) return(0); if (tip->type90 == DVTYPE_ASCII) fillen = fillen * elsize; incb = tip->stride * elsize; /* Stride in bytes */ if (cup->useq == 0) { /* If direct access file */ register int64 newpos; register int64 recl; newpos = cup->urecpos + count * fillen; /* in bits */ recl = (int64) (cup->urecl); if ((recl << 3) < newpos) { errn = FEWRLONG; /* output record too long */ goto done; } } #ifdef _CRAYT3D if (_issddptr(ptr)) { /* ptr points to a shared data descriptor */ /* If we have a layer that handles sdds someday, we */ /* could check for that here and not set shared to one. */ /* We'd also probably want to make sure that we're not */ /* doing foreign data converion */ shared = 1; elwords = elsize / sizeof(long); } #endif /* * If only one item, or stride is such that data is contiguous, * do it all at once */ if ((shared == 0) && ((count == 1) || (incb == elsize))) { register long ret; int status; if (mode == FULL) cup->f_lastwritten = 1; ret = _fwwd(cup, ptr, tip, mode, (int *) NULL, (long *) NULL, &status); if ( ret == IOERR ) { errn = errno; goto done; } return(0); } /* * Stride is such that memory is not contiguous, break the request * into chunks and do a gaterh on the items before writing. */ items = (LOCBUFLN * sizeof(long)) / elsize; /* chop it in chunks */ assert( ! (shared && items == 0) ); /* don't support shared char */ if (items == 0) items = 1; /* must be character*BIG array*/ fwwdbuf = lbuf; for ( i = 0; i < count; i = i + items ) { register long ret; int status; /* trim the item count if not a full buffer's worth */ if (items > count - i) items = count - i; tip->count = items; /* * Gather items from user array into lbuf, and then write * out a chunk. If items == 1, we suppress the extra data * copy for performance and because it might not fit in the * lbuf if it is character*BIG data. * * We don't have to worry about shared data not fitting * in lbuf since character data is never shared. */ #ifdef _CRAYT3D if (shared) _cpyfrmsdd(ptr, lbuf, items, elwords, tip->stride, i); else #endif { if (items > 1) _gather_data (lbuf, items, incb, elsize, ptr); else fwwdbuf = ptr; } if ( mode == FULL && (i+items >= count)) { cup->f_lastwritten = 1; ret = _fwwd(cup, fwwdbuf, tip, FULL, (int *) NULL, (long *) NULL, &status); } else ret = _fwwd(cup, fwwdbuf, tip, PARTIAL, (int *) NULL, (long *) NULL, &status); if ( ret == IOERR ) { errn = errno; goto done; } if (!shared) ptr = (char *)ptr + (ret * incb); } done: if (errn > 0) { if ((cup->uflag & (_UERRF | _UIOSTF)) == 0) _ferr(css, errn); /* Run-time error */ } return(errn); }
int $RUA$( _fcd fwa, /* Address of first word of data */ long *count, /* Address of count of data items */ long *stride, /* Address of stride between data items */ long *type /* Address of data type */ ) { register short type77; /* Fortran 77 data type */ register int errn; /* Error number */ type_packet tip; /* Type information packet */ struct f90_type ts; /* F90 type structure */ void *dptr; unit *cup; /* Pointer to unit table entry */ FIOSPTR css; GET_FIOS_PTR(css); cup = css->f_cu; type77 = *type & 017; CREATE_F90_INFO(ts, tip, type77); tip.count = *count; tip.stride = *stride; if (type77 == DT_CHAR) { dptr = (void *) _fcdtocp(fwa); tip.elsize = tip.elsize * _fcdlen(fwa); } else dptr = *(void **)&fwa; #if NUMERIC_DATA_CONVERSION_ENABLED if (cup->unumcvrt || cup->ucharset) { errn = _get_dc_param(css, cup, ts, &tip); if (errn != 0) goto error; } #endif #pragma _CRI inline _inline_rdunf errn = _inline_rdunf(css, cup, dptr, &tip, 0); if (errn == 0) return(CFT77_RETVAL(IO_OKAY)); error: if (cup->uiostat != NULL) *(cup->uiostat) = errn; cup->uflag |= (errn > 0) ? _UERRC : _UENDC; /* Set status */ if (cup->uflag & (_UIOSTF | _UERRF | _UENDF)) return(CFT77_RETVAL(_RUF())); _ferr(css, FEINTUNK); /* Deep weeds */ }