long
_frch(
unit *cup,
long *uda,
long chars,
int mode,
long *status)
{
register int bytsiz;
register int chr;
register long nchr;
register long ncnt;
unsigned char tbuf[TBUFSZB], *tp; /* Line buffer */
FILE *fptr;
struct ffsw stat;
struct fdinfo *fio;
#if defined(_SOLARIS) || (defined(_LITTLE_ENDIAN) && !defined(__sv2))
register long count;
char *tpinterim;
#endif
switch (cup->ufs) {
case FS_TEXT:
case STD:
fptr = cup->ufp.std;
/*
* Switch the FILE structure into read mode
*/
#if !defined(_LITTLE_ENDIAN) || (defined(_LITTLE_ENDIAN) && defined(__sv2))
if ((FILE_FLAG(fptr) & (_IOREAD | _IORW)) == _IORW) {
if (FILE_FLAG(fptr) & _IOWRT)
(void) fseek(fptr, 0, SEEK_CUR);
FILE_FLAG(fptr) |= _IOREAD;
}
#endif
/*
* Loop on getc until the character count has been
* exhausted, an end of file is encountered, or end
* of record.
*/
nchr = 0;
#if defined(_SOLARIS) || (defined(_LITTLE_ENDIAN) && !defined(__sv2))
while (nchr < chars) {
fill:
errno = 0;
count = chars - nchr;
tp = tbuf;
count = MIN(TBUFSZB, (count + 1));
tpinterim = fgets((char *)tp, count, fptr);
if (tpinterim == NULL) {
/*
* Search for the newline char in the buffer, but
* search only the number of characters left in
* the request, plus one in case it is the
* newline (if it is in the buffer). If we find
* newline, we're done.
*/
/* EOF here means incomplete record. */
if (ferror(fptr)) {
if ( errno == EINTR && _GINTIO == 0) {
clearerr(fptr);
goto fill;
}
if (errno == 0)
errno = FESTIOER;
return(IOERR);
}
/*
* If nchr > zero, file has no newline.
* Make sure we handle it properly.
*/
if (feof(fptr)) {
if (nchr == 0) {
*status = EOD;
return(0);
}
*status = CNT;
return(nchr);
}
} else {
unsigned char *tmpptr;
ncnt = count - 1;
#ifdef KEY /* Bug 3797 */
/* no newline if fgets encountered eof */
tmpptr = strchr(tp, '\n');
#ifdef KEY /* Bug 3975 */
char *nlptr = memchr(tp, '\n', ncnt);
/* Temporary fix to deal with the situation
* in which nulls appear before the newline.
* Correct fix is to eliminate those nulls.
*/
if (NULL == tmpptr && NULL != nlptr) {
tmpptr = nlptr;
}
#endif /* KEY Bug 3975 */
#else
tmpptr = memchr(tp, '\n', ncnt);
#endif /* KEY Bug 3797 */
if (tmpptr != NULL) { /* eor */
*status = EOR;
ncnt = tmpptr - tp;
nchr += ncnt;
_unpack(tp, uda, ncnt, -1);
/* Return number of chars read */
return(nchr);
}
#ifdef KEY /* Bug 3797 */
/* fgets got chars ending in eof, not newline */
else if (feof(fptr)) {
*status = EOR;
ncnt = strlen(tp);
nchr += ncnt;
_unpack(tp, uda, ncnt, -1);
return nchr;
}
#endif /* KEY Bug 3797 */
_unpack(tp, uda, ncnt, -1);
nchr += ncnt;
uda += ncnt;
/* go refill the buffer */
}
}
#else
while (nchr < chars) {
if (FILE_CNT(fptr) <= 0) {
fill:
errno = 0;
chr = _filbuf(fptr);
/* EOF here means incomplete record. */
if (chr == EOF) {
if (ferror(fptr)) {
if ( errno == EINTR &&
_GINTIO == 0 ) {
clearerr(fptr);
goto fill;
}
if (errno == 0)
errno = FESTIOER;
return(IOERR);
}
/*
* If nchr > zero, file has no newline.
* Make sure we handle it properly.
*/
if (nchr == 0) {
*status = EOD;
return(0);
}
*status = CNT;
return(nchr);
}
/*
* Put character returned by filbuf() back
*/
FILE_CNT(fptr)++;
FILE_PTR(fptr)--;
}
/*
* Search for a newline char in the buffer, but search
* only the number of characters left in the request,
* plus one in case it is the newline (if it is in
* the buffer). If we find the newline, we're done.
*/
if ((chars - nchr) < FILE_CNT(fptr)) {
ncnt = chars - nchr;
tp = memchr(FILE_PTR(fptr), '\n', ncnt + 1);
}
else {
ncnt = FILE_CNT(fptr); /* assume no EOR yet */
tp = memchr(FILE_PTR(fptr), '\n', ncnt);
}
if (tp != NULL) { /* Found end of record */
*status = EOR;
ncnt = tp - FILE_PTR(fptr);
nchr += ncnt;
_unpack((char *)FILE_PTR(fptr), uda, ncnt, -1);
FILE_CNT(fptr) -= ncnt + 1;
FILE_PTR(fptr) += ncnt + 1;
return(nchr); /* Return number of characters read */
}
_unpack((char *)FILE_PTR(fptr), uda, ncnt, -1);
FILE_CNT(fptr) -= ncnt;
FILE_PTR(fptr) += ncnt;
nchr += ncnt;
uda += ncnt;
/* go refill the buffer */
}
#endif
/*
* Get the next character to see if at end of record.
* Set the user's status word accordingly.
*/
chr = getc(fptr);
*status = CNT;
if (chr == '\n' ) {
*status = EOR;
return(nchr); /* Return number of characters read */
}
/*
* We are not at end of record. Thus if reading in full
* record mode skip until EOR is found. If reading in
* partial record mode, unget the last character read.
*/
if (mode == FULL)
#if defined(_SOLARIS) || (defined(_LITTLE_ENDIAN) && !defined(__sv2))
{
fill2:
count = TBUFSZB;
tp = tbuf;
tpinterim = fgets((char *)tp, count, fptr);
if (tpinterim == NULL) {
/* EOF means incomplete record. */
if (ferror(fptr)) {
if ( errno == EINTR && _GINTIO == 0 ) {
clearerr(fptr);
goto fill2;
}
}
/* Return number of chars read. */
return(nchr);
} else {
unsigned char *tmpptr;
ncnt = count - 1;
tmpptr = memchr(tp, '\n', ncnt);
if (tmpptr != NULL) { /* Found eor */
/* Return number of chars read */
return(nchr);
} else
goto fill2;
}
}
#else
while (1) {
if (FILE_CNT(fptr) <= 0) {
fill2:
chr = _filbuf(fptr);
/* EOF here means incomplete record. */
if (chr == EOF) {
if (ferror(fptr)) {
if ( errno == EINTR &&
_GINTIO == 0 ) {
clearerr(fptr);
goto fill2;
}
}
/* Return number of characters read */
return(nchr);
}
FILE_CNT(fptr)++;
FILE_PTR(fptr)--;
}
tp = memchr(FILE_PTR(fptr), '\n', FILE_CNT(fptr));
if (tp != NULL) {
tp++;
FILE_CNT(fptr) -= tp - FILE_PTR(fptr);
FILE_PTR(fptr) = tp;
return(nchr);
}
else
FILE_CNT(fptr) = 0;
}
#endif
else {
ungetc ((char) chr, fptr);
}
return(nchr); /* return number of character read */
case FS_FDC:
nchr = 0;
fio = cup->ufp.fdc;
/*
* If no conversion is to be done, or no characters requested
* (usually for null request, FULL mode), make it simple and direct.
*/
if (cup->ucharset == 0 || chars == 0) {
register long breq;
register int ffstat;
register int ret;
/*
* If file is direct access, we know that all reads are
* going to be whole records in FULL mode. We also
* know that the open code would not let us get this far
* if we were not dealing with a stream layer.
*/
breq = chars;
ret = XRCALL(fio, readcrtn) fio, CPTR2BP(uda),
breq, &stat, mode);
if (ret < 0) {
errno = stat.sw_error;
return(IOERR);
}
ffstat = FFSTAT(stat);
if (!cup->useq && !cup->ublkd && ffstat == FFCNT)
ffstat = FFEOR;
*status = FF2FTNST(ffstat);
nchr = ret;
return(nchr); /* Return number of characters read */
}
/*
* Get proper byte size (might not be 8-bits if doing conversion).
*/
#if NUMERIC_DATA_CONVERSION_ENABLED
bytsiz = __fndc_charsz[cup->ucharset];
#else
bytsiz = 8;
#endif
FFSTAT(cup->uffsw) = FFCNT;
*status = CNT;
while (nchr < chars && FFSTAT(cup->uffsw) != FFEOR) {
register long bgot;
register long breq;
register long padc;
register int ret;
register long totbits;
int ubc;
/*
* Calculate the number of bits that need to be taken
* from the foreign data stream.
*
* ncnt = number of resultant bytes
*/
ncnt = chars - nchr;
if (ncnt > TBUFSZB)
ncnt = TBUFSZB;
totbits = bytsiz * ncnt; /* bit count */
breq = (totbits + 7) >> 3; /* full 8-bit bytes */
ubc = (breq << 3) - totbits;/* unused bits */
ret = XRCALL(fio, readrtn) fio, CPTR2BP(tbuf),
breq, &cup->uffsw, PARTIAL, &ubc);
if (ret < 0) { /* if an error */
errno = cup->uffsw.sw_error;
return(IOERR);
}
/* if end of file */
if (ret == 0) {
if (nchr == 0)
*status = FF2FTNST(FFSTAT(stat));
return(nchr); /* Return number of characters read */
}
/*
* how many bits did we get? Convert back to foreign
* character count.
*/
totbits = (ret << 3) - ubc;
bgot = totbits / bytsiz; /* foreign bytes */
ubc = totbits - (bgot * bytsiz);
if (ubc != 0) {
errno = FEINTUNK;
return(IOERR);
}
padc = 0;
if (FFSTAT(cup->uffsw) == FFEOR) {
padc = chars - (bgot + nchr);
*status = EOR;
}
if (_fdc_unpackc(tbuf, &uda[nchr], bgot, padc,
cup->ucharset) < 0) {
return(IOERR);
}
nchr += bgot;
}
/* check for null request, non-EOR */
if (FFSTAT(cup->uffsw) == FFCNT && mode == FULL) {
register int ret;
int ubc;
ret = XRCALL(fio, readrtn) fio, CPTR2BP(tbuf), 0,
&cup->uffsw, FULL, &ubc);
if (ret < 0) { /* if an error */
errno = cup->uffsw.sw_error;
return(IOERR);
}
}
return(nchr);
case FS_AUX:
errno = FEMIXAUX;
return(IOERR);
default:
errno = FEINTFST;
return(IOERR);
}
long
_fwch(
unit *cup,
long *uda,
long chars,
int mode)
{
register int bytsiz;
register long nchr;
unsigned char tbuf[TBUFSZB]; /* Line packing buffer */
FILE *fptr;
/*
* If positioned after an endfile, and the file does not
* support multiple endfiles, a write is invalid.
*/
if (cup->uend && !cup->umultfil && !cup->uspcproc) {
errno = FEWRAFEN;
return(IOERR);
}
nchr = 0;
switch (cup->ufs) {
case FS_TEXT:
case STD:
fptr = cup->ufp.std;
/* switch the FILE structure into write mode */
#if !defined(_LITTLE_ENDIAN) || (defined(_LITTLE_ENDIAN) && defined(__sv2))
if ((FILE_FLAG(fptr) & (_IOWRT | _IORW)) == _IORW) {
if (FILE_FLAG(fptr) & _IOREAD)
(void) fseek(fptr, 0, SEEK_CUR);
FILE_FLAG(fptr) |= _IOWRT;
}
#endif
#if defined(_SOLARIS) || (defined(_LITTLE_ENDIAN) && !defined(__sv2))
while (nchr < chars) {
register long count;
register int ret;
/* Pack chars into temp buffer and write them */
count = chars - nchr;
if (count > TBUFSZB)
count = TBUFSZB;
#ifdef KEY /* Bug 5926 */
count = _pack(&uda[nchr], (char *)tbuf, count,
terminator(&mode, nchr, count, chars));
#else /* KEY Bug 5926 */
_pack(&uda[nchr], (char *)tbuf, count, -1);
#endif /* KEY Bug 5926 */
ret = fwrite(tbuf, 1, count, fptr);
if ( ret != count || ferror(fptr) ) {
if ( ret != count || errno == 0)
errno = FESTIOER;
return(IOERR);
}
nchr += count;
}
#else
/* If the stream is unbuffered... */
if (FILE_FLAG(fptr) & (_IONBF | _IOLBF)) {
while (nchr < chars) {
register long count;
register long ret;
/* Pack chars into temp buffer and write them */
count = chars - nchr;
if (count > TBUFSZB)
count = TBUFSZB;
#ifdef KEY /* Bug 5926 */
count= _pack(&uda[nchr], (char *)tbuf, count,
terminator(&mode, nchr, count, chars));
#else /* KEY Bug 5926 */
_pack(&uda[nchr], (char *)tbuf, count, -1);
#endif /* KEY Bug 5926 */
ret = fwrite(tbuf, 1, count, fptr);
if ( ret != count || ferror(fptr) ) {
if ( ret != count || errno == 0)
errno = FESTIOER;
return(IOERR);
}
nchr += count;
}
}
else { /* for a buffered stream... */
while (FILE_CNT(fptr) < chars - nchr) {
register long count;
register int ret;
count = FILE_CNT(fptr); /* space left in buffer */
if (count > 0) {
/* pack data into the buffer */
_pack(&uda[nchr], (char *)FILE_PTR(fptr),
count, -1);
FILE_PTR(fptr) += count;
FILE_CNT(fptr) = 0;
}
/*
* We set errno to 0 here in case the following
* buffer flush fails. UNICOS 8.2 fputc (and
* previous) was not X/Open compliant and did
* not always set errno when a buffer flush
* completed partially due to a disk full
* conditon. The zeroing of errno may be
* removed when we can assume that the fputc()
* from UNICOS and Solaris are X/Open compliant.
*/
errno = 0;
/*
* This fputc() will either trigger a buffer
* flush or cause the buffer to be allocated
* for the first time.
*/
ret = fputc(uda[nchr + count], fptr);
if (ret == EOF && ferror(fptr)) {
if (errno == 0)
errno = FESTIOER;
return(IOERR);
}
nchr += count + 1;
}
if (nchr < chars) { /* Put data in buffer */
_pack(&uda[nchr], (char *)FILE_PTR(fptr),
chars - nchr, -1);
FILE_CNT(fptr) -= chars - nchr;
FILE_PTR(fptr) += chars - nchr;
}
}
#endif
if (mode == FULL) {
register int ret;
ret = putc('\n', fptr);;
if (ret == EOF && ferror(fptr)) {
if (errno == 0)
errno = FESTIOER;
return(IOERR);
}
chars++;
}
return(chars);
case FS_FDC:
/*
* If a logical endfile record had just been read,
* replace it with a physical endfile record before
* starting the current data record.
*/
if ((cup->uend == LOGICAL_ENDFILE) && !(cup->uspcproc)) {
if (XRCALL(cup->ufp.fdc, weofrtn)cup->ufp.fdc,
&cup->uffsw) < 0){
errno = cup->uffsw.sw_error;
return(IOERR);
}
}
cup->uend = BEFORE_ENDFILE;
if (cup->ucharset == 0) {
register long ret;
ret = XRCALL(cup->ufp.fdc, writecrtn) cup->ufp.fdc,
WPTR2BP(uda),
chars, &cup->uffsw, mode);
if (ret < 0) {
errno = cup->uffsw.sw_error;
return(IOERR);
}
return(chars);
}
/*
* Get proper byte size (might not be 8-bits if doing conversion).
*/
#if NUMERIC_DATA_CONVERSION_ENABLED
bytsiz = __fndc_charsz[cup->ucharset];
#else
bytsiz = 8;
#endif
do {
register long breq;
register int fulp;
register long ncnt;
register long ret;
int ubc;
ncnt = TBUFSZB;
breq = 0;
ubc = 0;
if ((chars - nchr) > 0) {
register long totbits;
if (ncnt > (chars - nchr))
ncnt = chars - nchr;
if (_fdc_packc((char *)tbuf, &uda[nchr], ncnt,
cup->ucharset) < 0) {
return(IOERR);
}
totbits = bytsiz * ncnt; /* bit count */
breq = (totbits + 7) >> 3; /* 8-bit bytes */
ubc = (breq << 3) - totbits;
}
nchr += ncnt;
if ((nchr >= chars) && ( mode == FULL ))
fulp = FULL;
else
fulp = PARTIAL;
ret = XRCALL(cup->ufp.fdc, writertn) cup->ufp.fdc,
CPTR2BP(tbuf),
breq, &cup->uffsw, fulp, &ubc);
if (ret != breq) { /* if an error */
errno = cup->uffsw.sw_error;
return(IOERR);
}
} while (nchr < chars);
return(chars);
/*
* unsupported structure if not TEXT/STD, or FDC
*/
default:
errno = FEINTFST;
return(IOERR);
}
}
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;
}
