/* Don't pollute the Fortran namespace with library functions */ static #endif /* KEY Bug 1683 */ _f_int4 putcf90_(char *c, int clen) { _f_int4 res; struct fiostate cfs; /* fiosp */ unit *cup; /* Unit table pointer */ unum_t unum = 6; res = 0; /* lock the unit */ STMT_BEGIN( unum, 0, T_WSF, NULL, &cfs, cup); if (!cup) return((errno=FEIVUNIT)); if (_fwch(cup, (long *)c, 1, PARTIAL) == -1) res = errno; /* unlock the unit */ STMT_END( cup, TF_WRITE, NULL, &cfs); return(res); }
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; }
_f_int8 fputcf90_8_(_f_int8 *u, char *c, int clen) { _f_int8 res; struct fiostate cfs; /* fiosp */ unit *cup; /* Unit table pointer */ unum_t unum; unum = *u; res = 0; /* lock the unit */ STMT_BEGIN( unum, 0, T_WSF, NULL, &cfs, cup); if (unum < 0 || !cup) return((errno=FEIVUNIT)); if (_fwch(cup, (long *)c, 1, PARTIAL) == -1) res = errno; /* unlock the unit */ STMT_END( cup, TF_WRITE, NULL, &cfs); return(res); }
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)); }
_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 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 */ }
/* * unum logical unit number * cfs I/O state used in locking the file * return unit * corresponding to that logical unit, having performed * an implicit open if need be and locked the file. errno is * 0 unless an error occurred */ static unit * setup(unum_t unum, struct fiostate *cfs) { unit *cup = 0; /* Lock the unit */ errno = 0; STMT_BEGIN( unum, 0, T_RSF, NULL, cfs, cup); if (cup == NULL) { int stat; int errf = 0; cup = _imp_open(cfs, SEQ, FMT, unum, errf, &stat); errno = (0 == cup) ? stat : 0; } if (unum < 0 || !cup) { errno = FEIVUNIT; } return cup; }
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; }
/* Don't pollute the Fortran namespace with library functions */ static #endif /* KEY Bug 1683 */ _f_int fputcf90_(_f_int *u, char *c, int clen) { _f_int res; struct fiostate cfs; /* fiosp */ unit *cup; /* Unit table pointer */ unum_t unum; long inpbuf; unum = *u; res = 0; /* lock the unit */ STMT_BEGIN( unum, 0, T_WSF, NULL, &cfs, cup); #ifdef KEY /* Bug 1683 */ /* Copied from rf90.c; list-directed uses SEQ, so we do too */ if (cup == NULL) { /* If not connected */ int stat; int errf = 0; cup= _imp_open(&cfs, SEQ, FMT, unum, errf, &stat); if (0 == cup) { return errno = stat; } } #endif /* KEY Bug 1683 */ if (unum < 0 || !cup) return((errno=FEIVUNIT)); /* move the character to a character per word for fwch */ inpbuf = (long) *c; if (_fwch(cup, &inpbuf, 1, PARTIAL) == -1) res = errno; /* unlock the unit */ STMT_END( cup, TF_WRITE, NULL, &cfs); return(res); }
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; }
int _REWF( _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; /* Error status */ register unum_t unum; unit *cup; struct ffsw fst; struct fiostate cfs; errn = 0; unum = *unump; STMT_BEGIN(unum, 0, T_REWIND, NULL, &cfs, cup); /* lock the unit */ if (!GOOD_UNUM(unum)) { errn = FEIVUNIT; /* Invalid unit number */ goto rewind_done; } /* * REWIND on unopened unit is OK, and does nothing. */ if (cup == NULL) goto rewind_done; if (cup->useq == 0) { /* If file opened for direct access */ errn = FERWNDIV; /* REWIND invalid on dir. acc.*/ goto rewind_done; } /* * Wait for completion of a preceding asynchronous BUFFER IN/OUT. */ WAITIO(cup, {errn = cup->uffsw.sw_error;});
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 _INQ( _f_int *unitn, _f_int *iostat, int errf, _f_log *exist, _f_log *opened, _f_int *number, _f_log *named, _fcd name, _fcd access, _fcd sequent, _fcd direct, _fcd form, _fcd formatt, _fcd unform, _f_int *recl, _f_int *nextrec, _fcd blank, _fcd file, _fcd pos, _fcd action, _fcd red, _fcd writ, _fcd redwrit, _fcd delim, _fcd pad ) #endif { inlist a; /* INQUIRE parameter list */ int errn; /* IOSTAT error number */ int error; /* Error flag */ unum_t unum; /* Unit number */ long stmt; /* Statement type */ unit *cup; /* Unit pointer if inquire by unit */ struct fiostate cfs; #ifdef _CRAYMPP va_list args; _fcd name; _fcd access; _fcd sequent; _fcd direct; _fcd form; _fcd formatt; _fcd unform; _f_int *recl; _f_int *nextrec; _fcd blank; _fcd file; _fcd pos; _fcd action; _fcd red; _fcd writ; _fcd redwrit; _fcd delim; _fcd pad; va_start(args,named); name = va_arg(args, _fcd); access = va_arg(args, _fcd); sequent = va_arg(args, _fcd); direct = va_arg(args, _fcd); form = va_arg(args, _fcd); formatt = va_arg(args, _fcd); unform = va_arg(args, _fcd); recl = va_arg(args, _f_int *); nextrec = va_arg(args, _f_int *); blank = va_arg(args, _fcd); file = va_arg(args, _fcd); #endif /* Initialize the inlist structure */ (void) memset(&a, 0, sizeof(inlist)); a.inunit = -1; /* Determine type of INQUIRE */ if (_fcdtocp(file) != NULL) { a.infile = _fcdtocp(file); a.infilen = _fcdlen (file); /* CFT77 */ stmt = T_INQF; /* INQUIRE by FILE */ unum = -1; } else { stmt = T_INQU; /* INQUIRE by UNIT */ unum = *unitn; a.inunit = unum; } /* * Here unum is -1 if this is an inquire by file. This will suppress * any unit locking in STMT_BEGIN. */ STMT_BEGIN(unum, 0, stmt, NULL, &cfs, cup); /* Process rest of parameters */ if (_fcdtocp(name) != NULL) { a.inname = _fcdtocp(name); a.innamlen = _fcdlen (name); /* CFT77 */ if (a.innamlen == 0) a.innamlen = strlen(a.inname); /* CFT2 */ } if (_fcdtocp(access) != NULL) { a.inacc = _fcdtocp(access); a.inacclen = _fcdlen (access); } if (_fcdtocp(sequent) != NULL) { a.inseq = _fcdtocp(sequent); a.inseqlen = _fcdlen (sequent); } if (_fcdtocp(direct) != NULL) { a.indir = _fcdtocp(direct); a.indirlen = _fcdlen (direct); } if (_fcdtocp(form) != NULL) { a.inform = _fcdtocp(form); a.informlen = _fcdlen (form); } if (_fcdtocp(formatt) != NULL) { a.infmt = _fcdtocp(formatt); a.infmtlen = _fcdlen (formatt); } if (_fcdtocp(unform) != NULL) { a.inunf = _fcdtocp(unform); a.inunflen = _fcdlen (unform); } if (_fcdtocp(blank) != NULL) { a.inblank = _fcdtocp(blank); a.inblanklen = _fcdlen (blank); } #ifdef _UNICOS if (_numargs() <= (9 + 9*sizeof(_fcd)/sizeof(long))) goto old_inq; #endif #ifdef _CRAYMPP pos = va_arg(args, _fcd); action = va_arg(args, _fcd); red = va_arg(args, _fcd); writ = va_arg(args, _fcd); redwrit = va_arg(args, _fcd); delim = va_arg(args, _fcd); pad = va_arg(args, _fcd); #endif if (_fcdtocp(pos) != NULL) { a.inposit = _fcdtocp(pos); a.inpositlen = _fcdlen (pos); } if (_fcdtocp(action) != NULL) { a.inaction = _fcdtocp(action); a.inactonlen = _fcdlen (action); } if (_fcdtocp(red) != NULL) { a.inread = _fcdtocp(red); a.inreadlen = _fcdlen (red); } if (_fcdtocp(writ) != NULL) { a.inwrite = _fcdtocp(writ); a.inwritelen = _fcdlen (writ); } if (_fcdtocp(redwrit) != NULL) { a.inredwrit = _fcdtocp(redwrit); a.inrdwrtlen = _fcdlen (redwrit); } if (_fcdtocp(delim) != NULL) { a.indelim = _fcdtocp(delim); a.indelimlen = _fcdlen (delim); } if (_fcdtocp(pad) != NULL) { a.inpad = _fcdtocp(pad); a.inpadlen = _fcdlen (pad); } old_inq: a.inerr = (errf || iostat) ? 1 : 0; a.inex = exist; a.inopen = opened; a.innum = number; a.innamed = named; a.inrecl = recl; a.innrec = nextrec; errn = _f_inqu(&cfs, cup, &a); error = (errn != 0) ? IO_ERR : IO_OKAY; if (iostat != NULL) *iostat = errn; #ifdef _CRAYMPP va_end(args); #endif STMT_END(NULL, 0, NULL, NULL); return(CFT77_RETVAL(error)); }
int _FRU(ControlListType *cilist, iolist_header *iolist, void *stck) { register int errf; /* ERR processing flag */ register int errn; /* Error number */ register int endf; /* END processing flag */ register int iost; /* I/O statement type */ register int retval; /* _FRU Return value */ register recn_t errarg; /* Extra _ferr argument */ register unum_t unum; /* Unit number */ unit *cup; /* Unit table pointer */ FIOSPTR css; /* I/O statement state */ /* * Assertions */ /* Validate that the size of *stck is large enough */ assert ( cilist->stksize >= sizeof(struct fiostate)/sizeof(long) ); css = stck; errn = 0; errarg = 0; retval = IO_OKAY; if (iolist->iolfirst == 0) { cup = css->f_cu; goto data_transfer; } /******************************************************************************* * * Statement Initialization Section * ******************************************************************************/ errf = (cilist->errflag || cilist->iostatflg); endf = (cilist->endflag || cilist->iostatflg); unum = *cilist->unit.wa; iost = cilist->dflag ? T_RDU : T_RSU; STMT_BEGIN(unum, 0, iost, NULL, css, cup); if (cup == NULL) { /* If not connected */ int stat; /* Status */ cup = _imp_open(css, (cilist->dflag ? DIR : SEQ), UNF, unum, errf, &stat); /* * If the open failed, cup is NULL and stat contains * the error number. */ if (cup == NULL) { errn = stat; goto handle_exception; } } /* Record error processing options in the unit. (used in _rdunf()) */ cup->uflag = (cilist->errflag ? _UERRF : 0) | (cilist->endflag ? _UENDF : 0) | (cilist->iostat_spec != NULL ? _UIOSTF : 0); /* If sequential and writing, disallow read after write */ if (cup->useq && cup->uwrt != 0) { errn = FERDAFWR; /* Read after write */ goto handle_exception; } /* Preset fields in unit table */ cup->ueor_found = NO; /* Clear EOR */ cup->uwrt = 0; cup->ulastyp = DVTYPE_TYPELESS; if (cilist->dflag) { /* If direct access */ if (!cup->ok_rd_dir_unf) errn = _get_mismatch_error(errf, iost, cup, css); else { register recn_t recn; /* Record number */ recn = (recn_t) *cilist->rec_spec; errarg = recn; errn = _unit_seek(cup, recn, iost); } } else /* Else sequential access */ if (!cup->ok_rd_seq_unf) errn = _get_mismatch_error(errf, iost, cup, css); if (errn != 0) goto handle_exception; /******************************************************************************* * * Data Transfer Section * ******************************************************************************/ data_transfer: errn = _xfer_iolist(css, cup, iolist, _rdunf); if (errn != 0) goto handle_exception; if (! iolist->iollast) return(IO_OKAY); /****************************************************************************** * * Statement Finalization Section * ******************************************************************************/ finalization: if (cup != NULL) { cup->ulrecl = cup->urecpos; cup->urecpos = 0; } #ifdef _CRAYMPP if (css->f_shrdput) { css->f_shrdput = 0; _remote_write_barrier(); } #endif if (errn == 0 && cup->useq) { if (cup->ufs == FS_FDC) { /* * Do a full record read to advance to the * end of the record for sequential access. */ if (cup->ublkd && !cup->ueor_found) { char dummy; /* Unused data */ int ubc = 0; /* Unused bit count */ struct ffsw fst; /* FFIO status block */ (void) XRCALL(cup->ufp.fdc, readrtn) cup->ufp.fdc, CPTR2BP(&dummy), 0, &fst, FULL, &ubc); switch (fst.sw_stat) { case FFERR: errn = fst.sw_error; break; case FFEOF: cup->uend = PHYSICAL_ENDFILE; errn = FERDPEOF; break; case FFEOD: if (cup->uend == BEFORE_ENDFILE) { cup->uend = LOGICAL_ENDFILE; errn = FERDPEOF; } else errn = FERDENDR; break; } /* switch */ } } if (errn != 0) goto handle_exception; }
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; }
int @WNL( _f_int *unump, /* Unit number or dataset name */ Namelist *nl, /* Namelist structure */ int errf /* Nonzero if ERR specified */ ) { unum_t unum; int errn; int n, ss; void *vaddr; /* variable address */ unsigned elsize; /* size in bytes of the variable */ long recsize; /* number of characters to output per * line. Used by REPFLUSH.*/ char c; /* needed by NLPUTS macro */ char *s; /* needed by NLPUTS macro */ unit *cup; /* unit pointer */ Nlentry *nlent; FIOSPTR css; struct BUFFERS wnlbuffers; struct BUFFERS *bptr; bptr = &wnlbuffers; bptr->f_lbuf = NULL; unum = *unump; GET_FIOS_PTR(css); STMT_BEGIN(unum, 0, T_WNL, NULL, css, cup); if (cup == NULL) { /* if not connected */ cup = _imp_open77(css, SEQ, FMT, unum, errf, &errn); /* * If the open failed, cup is NULL and errn contains * the error number. */ if (cup == NULL) RERR(css, errn); } /* Set various unit table fields */ cup->uflag = (errf != 0 ? _UERRF : 0); cup->ulineptr = cup->ulinebuf; cup->uwrt = 1; /* Set write flag */ /* Set fields in the Fortran statement state structure */ css->u.fmt.nonl = 0; /* Clear no-newline flag */ if (cup->useq == 0) /* If direct access file */ RERR(css, FESEQTIV); /* Sequential attempted on direct access */ if (!cup->ufmt) /* If unformatted file */ RERR(css, FEFMTTIV); /* Formatted attempted on unformatted */ if ((cup->uaction & OS_WRITE) == 0) RERR(css, FENOWRIT); bptr = &wnlbuffers; bptr->lcomma = 0; /* * Set up record size. The hierarchy for determining Namelist * output record size is as follows: * 1) RECL, if specified * 2) WNLLONG(), if set and does not exceed cup->urecsize * 3) list-directed output record size (cup->uldwsize) * * Note that while (1) and (3) are established at OPEN time, (2) * can be changed ``on the fly''; therefore, this check has to * be performed here. */ recsize = cup->uldwsize; if (cup->urecl == 0 && _wnlrecsiz > 0) /* No RECL and WNLLONG() set */ recsize = MIN(cup->urecsize, _wnlrecsiz); bptr->outcnt = recsize - 1; /* First char. for carriage control */ bptr->outbuff = cup->ulinebuf; bptr->outptr = bptr->outbuff; *bptr->outptr++ = OUT_ECHO; /* First character of first line */ bptr->f_lbuf = (long *) malloc((recsize + 1) * sizeof(long)); if (bptr->f_lbuf == NULL) RERR(css, FENOMEMY); /* No memory */ /* NAMELIST delimiter to output line */ NLPUT(OUT_CHAR); /* output delimiter */ NLPUTS(nl->nlname); /* unpack group name to buffer */ NLPUT(' '); NLPUT(' '); NLINE(); /* Did user specify new line for each variable? */ nlent = nl->nlvnames; do { int ntype; ntype = _old_namelist_to_f77_type_cnvt[nlent->na.type]; /* * Always format output into f_lbufptr. * After formatting, if it will fit, move it into outbuff. * If it will not fit, write out what is already in outbuff, * and then move in the newly formatted data. */ bptr->f_lbufptr = bptr->f_lbuf; bptr->f_lbufcnt = 0; LPUTS(nlent->varname); /* output variable name */ LPUT(' '); LPUT(OUT_EQ); /* output the replacement * character. '=' by default. */ n = (nlent->na.offdim) ? nlent->na.nels : 1; if (ntype == DT_CHAR) { _fcd f; f = *(_fcd *)(((unsigned long) nlent->va.varaddr + (long *)nl)); vaddr = _fcdtocp(f); elsize = _fcdlen(f); } else { vaddr = (void *)nlent->va.varaddr; elsize = 0; } LPUT(' '); /* Output value */ ss = l_write(css, cup, vaddr, elsize, n, 1, ntype, recsize, errf, bptr); if (ss != 0) { RERR(css, ss); } NLINE(); nlent++; /* point to next variable description */ } while (nlent->varname[0]); if (bptr->outcnt < 6) { REPFLUSH(); /* Make sure there's room for " &END" */ bptr->outptr--; /* start in col. 2 */ bptr->outcnt++; } NLPUT(OUT_CHAR); NLPUTS("END"); REPFLUSH(); ret: STMT_END(cup, T_WNL, NULL, css); /* Unlock the unit */ if (bptr->f_lbuf != NULL) /* Free formatting buffer */ free(bptr->f_lbuf); return(CFT77_RETVAL(ss)); }
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 }