/* Keeping this for backward compatibility, sigh */
void
flush_(_f_int4 *unump) {
unum_t unum = (0 == unump) ? 0 : *unump;
__flush_f90((0 == unump) ? 0 : (&unum), 0);
}
#else /* KEY Bug 6433 */
void
flush_( const unum_t *unump)
{
_f_int istt; /* Optional error status is present */
__flush_f90(unump, &istt);
return;
}
int _flush08(int unit0, void *iostat, int iostat_kind,
char *iomsg, int iomsg_len) {
_f_int status;
unum_t unit;
char *p;
unit = unit0;
__flush_f90(&unit, &status);
switch(iostat_kind) {
case 1: *((char *) iostat) = status; break;
case 2: *((short *) iostat) = status; break;
case 4: *((int *) iostat) = status; break;
case 8: *((long long *) iostat) = status; break;
default:
break;
}
if (status == 0)
return 0;
p = (status < 0)
? "Unit does not support FLUSH"
: strerror(errno);
while(*p != '\0' && iomsg_len > 0) {
*iomsg++ = *p++;
iomsg_len--;
}
while(iomsg_len > 0)
*iomsg++ = ' ';
return 1;
}
void
flush_stat_4_(
unum_t *unump, /* Fortran unit number */
_f_int *istat) /* Optional error status present */
{
__flush_f90(unump, istat);
return;
}
void
flush_f90_8_( _f_int8 *unump) /* Fortran unit number */
{
_f_int istat; /* status word */
unum_t unum; /* Fortran unit number */
unum = *unump;
__flush_f90(&unum, &istat);
return;
}
void
flush_stat_8_4_(
_f_int8 *unump, /* Fortran unit number */
_f_int *istat) /* Optional error status present */
{
unum_t unum; /* Fortran unit number */
unum = *unump;
__flush_f90(&unum, istat);
return;
}
void
flush_stat_4_8_(
_f_int *unump, /* Fortran unit number */
_f_int8 *istat) /* Optional error status present */
{
unum_t unum;
_f_int istt; /* Optional error status is present*/
unum = *unump;
__flush_f90(&unum, &istt);
*istat = (_f_int8) istt;
return;
}
/* None of the existing fcns takes integer*4 for both args, sigh */
void
pathf90_flush(_f_int *unump, _f_int *istat)
{
unum_t unum = (0 == unump) ? 0 : *unump;
__flush_f90((0 == unump) ? 0 : (&unum), istat);
}
/* Keeping this for backward compatibility, sigh */
void
flush_(_f_int4 *unump) {
unum_t unum = (0 == unump) ? 0 : *unump;
__flush_f90((0 == unump) ? 0 : (&unum), 0);
}
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;
}
