int
c_sue (cilist64 *a, unit **fu)
{
unit *ftnunit;
if ((ftnunit = map_luno (a->ciunit)) == NULL)
errret(a->cierr, 101, "startio");
while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L ))
;
*fu = ftnunit;
if (ftnunit->uconn <= 0 && fk_open (SEQ, UNF, a->ciunit)) {
ftnunit->uconn = 0;
errret(a->cierr, 114, "sue");
}
ftnunit->f77errlist.cierr = a->cierr;
ftnunit->f77errlist.ciend = a->ciend;
ftnunit->f77errlist.cieor = a->cieor;
ftnunit->f77errlist.cisize = a->cisize;
ftnunit->f77errlist.iciunit = 0;
if (ftnunit->ufmt > 0) {
if ((ftnunit->ufd == stdin || ftnunit->ufd == stdout ||
ftnunit->ufd == stderr) && ftnunit->useek)
/* these guys can be redirected so it might not be an error,
** let's assume it is correct here. If there is any error
** it can be caught later
*/
ftnunit->ufmt = 1;
else
errret(a->cierr, 103, "sue");
}
if (!ftnunit->useek && ftnunit->uacc == SEQUENTIAL)
errret(a->cierr, 103, "sue");
return (0);
}
int s_rdfe64_mp(cilist64 *a, unit **fu) {
#else
int
s_rdfe_mp (cilist *a, unit **fu) {
#endif
int n;
unit *ftnunit;
if (!f77init)
f_init ();
if (n = c_dfe (a, fu)) {
if (*fu) (*fu)->lock_unit = 0;
return (n);
}
ftnunit = *fu;
if (ftnunit->uwrt & WR_OP)
(void) f77nowreading (ftnunit);
#ifdef I90
if (ftnunit->uaction == WRITEONLY )
errret(ftnunit->f77errlist.cierr,180,"startread");
#endif
ftnunit->f77getn = y_getc;
ftnunit->f77gets = y_gets;
ftnunit->f77ungetn = y_ungetc;
ftnunit->f77doed = rd_ed;
ftnunit->f77doned = rd_ned;
ftnunit->f77donewrec = yrd_SL;
ftnunit->f77dorevert = ftnunit->f77doend = y_rsk;
if (pars_f (ftnunit, ftnunit->f77fmtbuf) < 0)
errret(a->cierr, 100, "startio");
fmt_bg (ftnunit);
return (0);
}
int
do_ud (unit *ftnunit, XINT *number, char *ptr, ftnlen len)
{
XINT nread = *number * len;
XINT64 disk_loc;
if (ftnunit->url != 1) { /* Normal case. */
disk_loc =(ftnunit->uirec - 1) * ftnunit->url + ftnunit->f77recpos;
ftnunit->f77recpos += nread;
if (ftnunit->f77recpos > ftnunit->url && ftnunit->url != 1)
errret(ftnunit->f77errlist.cierr, 110, "eof/uio");
} else { /* Record length of one. */
disk_loc = ftnunit->uirec;
ftnunit->uirec += nread;
}
/*
* Read or write the data.
*/
if (!(ftnunit->uwrt & WR_OP)) {
if (-1 == _fio_du_read (ftnunit, ptr, nread, disk_loc, (int) ftnunit->ufd))
errret(ftnunit->f77errlist.cierr, errno, "eof/uio");
} else {
if (ftnunit->ureadonly)
errret( ftnunit->f77errlist.cierr, F_ERREADONLY, "direct unformatted write" );
if (-1 == _fio_du_write (ftnunit, ptr, nread, disk_loc, (int) ftnunit->ufd))
errret(ftnunit->f77errlist.cierr, errno, "system write error");
}
return (0);
}
int s_wdfe64_mp (cilist64 *a, unit **fu) {
#else
int
s_wdfe_mp (cilist *a, unit **fu) {
#endif
int n;
unit *ftnunit;
if (!f77init)
f_init ();
if (n = c_dfe (a, fu)) {
if (*fu) (*fu)->lock_unit = 0;
return (n);
}
ftnunit = *fu;
if (ftnunit->uwrt != WR_READY && f77nowwriting (ftnunit))
errret(a->cierr, 160, "startwrt");
ftnunit->f77putn = y_putc;
ftnunit->f77ungetn = y_ungetc;
ftnunit->f77doed = w_ed;
ftnunit->f77doned = w_ned;
ftnunit->f77donewrec = y_wSL;
ftnunit->f77dorevert = y_rev;
ftnunit->f77doend = y_end;
ftnunit->uirec = a->cirec;
if (ftnunit->umaxrec && (a->cirec > ftnunit->umaxrec))
errret(a->cierr, 159, "startwrt");
if (pars_f (ftnunit, ftnunit->f77fmtbuf) < 0)
errret(a->cierr, 100, "startwrt");
fmt_bg (ftnunit);
return (0);
}
int32 wsfe (cilist *a, unit **fu, int f90sw)
#endif
{
int32 n;
unit *ftnunit;
if (!f77init)
f_init ();
if (n = c_sfe (a, fu))
return n;
ftnunit = *fu;
if (ftnunit->uacc == DIRECT)
errret(a->cierr, 171, "sequential write");
ftnunit->f77cursor = ftnunit->f77recpos = ftnunit->f77recend = 0;
ftnunit->f77cplus = 0;
ftnunit->f77scale = 0;
#ifdef I90
ftnunit->f90sw = f90sw;
if (!f90sw) ftnunit->f77recpos = ftnunit->f77recend = 0;
/* in f90 mode we initialize f77recpos and f77recend in the caller, dont
know why. */
#else
ftnunit->f77recpos = ftnunit->f77recend = 0;
#endif
ftnunit->f77errlist.cierr = a->cierr;
ftnunit->f77errlist.ciend = a->ciend;
ftnunit->f77errlist.cieor = a->cieor;
ftnunit->f77errlist.cisize = a->cisize;
ftnunit->f77errlist.iciunit = 0;
ftnunit->f77fmtbuf = a->cifmt;
if (ftnunit->uacc == KEYED) {
ftnunit->f77idxlist.cimatch = a->cimatch;
ftnunit->f77idxlist.cikeytype = a->cikeytype;
ftnunit->f77idxlist.cikeyval.cicharval = a->cikeyval.cicharval;
ftnunit->f77idxlist.cikeyid = a->cikeyid;
ftnunit->f77idxlist.cinml = a->cinml;
ftnunit->f77idxlist.cikeyvallen = a->cikeyvallen;
}
if (pars_f (ftnunit, ftnunit->f77fmtbuf) < 0)
errret(a->cierr, 100, "startio");
ftnunit->f77putn = x_putc;
ftnunit->f77ungetn = x_ungetc;
ftnunit->f77doed = w_ed;
ftnunit->f77doned = w_ned;
ftnunit->f77doend = xw_end;
ftnunit->f77dorevert = xw_rev;
ftnunit->f77donewrec = x_wSL;
fmt_bg (ftnunit);
ftnunit->f77cblank = ftnunit->ublnk;
if (ftnunit->url > ftnunit->f77fio_size)
check_buflen( ftnunit, ftnunit->url > FIO_ALLOC ? ftnunit->url : FIO_ALLOC );
return 0;
}
int
e_rsue_mp (unit **fu)
{
unit *ftnunit = *fu;
int n;
if (ftnunit->uacc != KEYED && ftnunit->url != 1) {
XINT nleft = ftnunit->f77reclen - ftnunit->f77recpos;
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) {
return( e_rdue_mp (fu) );
} else if (ftnunit->uacc == DIRECT) {
if (nleft > 0) {
if (nleft <= ftnunit->f77fio_size && nleft < 1000) {
fread (ftnunit->f77fio_buf, nleft, 1, ftnunit->ufd);
} else {
(void) fseek (ftnunit->ufd, nleft, 1);
}
}
} else {
if (nleft + sizeof (int) <= ftnunit->f77fio_size && nleft < 1000) {
fread (ftnunit->f77fio_buf, nleft + sizeof (int), 1, ftnunit->ufd);
} else {
(void) fseek (ftnunit->ufd, (long) (nleft + sizeof (int)), 1);
}
}
if (ferror (ftnunit->ufd))
errret(ftnunit->f77errlist.cierr, errno, "sue");
}
ftnunit->lock_unit = 0;
return (0);
}
int
s_xsle64_mp (cilist64 *a, unit **fu)
{
int n = s_wsle64_mp(a, fu);
#else
int
s_xsle_mp (cilist *a, unit **fu)
{
int n = s_wsle_mp(a, fu);
#endif
unit *ftnunit = *fu;
if (n) {
return n;
}
ftnunit->f77idxlist.cimatch = a->cimatch;
ftnunit->f77idxlist.cikeytype = a->cikeytype;
ftnunit->f77idxlist.cikeyval.cicharval = a->cikeyval.cicharval;
ftnunit->f77idxlist.cikeyid = a->cikeyid;
ftnunit->f77idxlist.cinml = a->cinml;
ftnunit->f77idxlist.cikeyvallen = a->cikeyvallen;
if (ftnunit->uacc != KEYED)
errret(a->cierr, 162, "rewrite");
ftnunit->dowrite = idxrewrite;
return (0);
}
int
e_rdfe_mp (unit **fu)
{
unit *ftnunit = *fu;
(void) en_fio (fu);
if (ftnunit->ufd && ferror (ftnunit->ufd))
errret(ftnunit->f77errlist.cierr, errno, "dfe");
ftnunit->lock_unit = 0;
return (0);
}
static int
s_wsue_com (cilist64 *a, unit **fu)
{
unit *ftnunit;
int n;
n = wsue(a, fu);
ftnunit = *fu;
if (n) {
errret(a->cierr, n, "s_wsue");
}
if (ftnunit->uacc == KEYED) {
ftnunit->f77idxlist.cimatch = a->cimatch;
ftnunit->f77idxlist.cikeytype = a->cikeytype;
ftnunit->f77idxlist.cikeyval.cicharval = a->cikeyval.cicharval;
ftnunit->f77idxlist.cikeyid = a->cikeyid;
ftnunit->f77idxlist.cinml = a->cinml;
ftnunit->f77idxlist.cikeyvallen = a->cikeyvallen;
ftnunit->f77do_unf = do_ui;
}
else {
if (ftnunit->uacc == DIRECT) {
ftnunit->f77recpos = 0;
ftnunit->f77do_unf = do_ud;
_fio_seq_pos( ftnunit->ufd, ftnunit );
} else {
if (ftnunit->uwrt != WR_READY && f77nowwriting (ftnunit))
errret(a->cierr, 160, "startwrt");
est_reclen = ftnunit->f77reclen = 0;
ftnunit->overflowed = 0;
ftnunit->f77recpos = 4;
ftnunit->f77do_unf = do_us;
if (ftnunit->uerror)
unf_position (ftnunit->ufd, ftnunit);
}
}
return 0;
}
int
c_si (icilist *a, unit *ftnunit)
#endif
{
ftnunit->f77fmtbuf = a->icifmt;
if (f77vfmt_com_.PFI != NULL) {
/*
* If something has been placed in the global static f77vfmt_com_
* structure, then use it. This means we must be running an
* executable built with a pre-mongoose compiler which is using
* variable format I/O.
*/
ftnunit->vfmt = f77vfmt_com_.PFI;
ftnunit->vfmtfp = f77vfmt_com_.static_link;
} else {
/*
* Otherwise, grab the same information from the icilist structure.
* This means one of three things:
* 1) executable built with pre-mongoose compiler, no variable format:
* The civfmt and civfmtfp fields are actually past the end
* of the space allocated for the icilist structure, so we
* are reading something else which is unknown, and it will
* not be used. This is hopefully not a problem.
* 2) executable built with mongoose compiler, no variable format:
* The civfmt and civfmtfp fields are there in the icilist
* structure, but are uninitialized and the values will not
* be used. This is not a problem.
* 3) executable built with mongoose compiler, variable format:
* The values are there, are valid, and will be used.
*/
ftnunit->vfmt = a->icivfmt;
ftnunit->vfmtfp = a->icivfmtfp;
}
ftnunit->f77cblank = ftnunit->f77cplus = ftnunit->f77scale = 0;
ftnunit->f77errlist.cierr = a->icierr;
ftnunit->f77errlist.ciend = a->iciend;
ftnunit->f77errlist.cieor = 0;
ftnunit->f77errlist.cisize = 0;
ftnunit->f77errlist.iciunit = a->iciunit;
ftnunit->f77errlist.icirlen = a->icirlen;
ftnunit->f77errlist.icirnum = a->icirnum;
ftnunit->f77errlist.iciunit = a->iciunit;
ftnunit->f77recpos = ftnunit->f77recend = icnum = icpos = 0;
if (pars_f (ftnunit, ftnunit->f77fmtbuf) < 0)
errret(a->icierr, 100, "startint");
fmt_bg (ftnunit);
icptr = ftnunit->f77errlist.iciunit;
icend = icptr + ftnunit->f77errlist.icirlen * ftnunit->f77errlist.icirnum;
return (0);
}
static int
f_unl_com (alist *a, int lock)
#endif
{
unit *ftnunit = find_luno(a->aunit);
if (ftnunit == NULL)
err (a->aerr, 101, "unlock");
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uconn > 0) {
if (ftnunit->uacc != KEYED)
errret(a->aerr, 163, "unlock");
if (isrelease (ftnunit->isfd) < SUCCESS)
ierrret(a->aerr, iserrno, "unlock");
}
else
err (a->aerr, 101, "delete");
if (lock) ftnunit->lock_unit = 0;
return 0;
}
int
s_xsfe_mp (cilist *a, unit **fu)
#endif
{
int n = wsfe(a, fu, 0);
unit *ftnunit;
ftnunit = *fu;
ftnunit->f77idxlist.cimatch = a->cimatch;
ftnunit->f77idxlist.cikeytype = a->cikeytype;
ftnunit->f77idxlist.cikeyval.cicharval = a->cikeyval.cicharval;
ftnunit->f77idxlist.cikeyid = a->cikeyid;
ftnunit->f77idxlist.cinml = a->cinml;
ftnunit->f77idxlist.cikeyvallen = a->cikeyvallen;
if (n) {
return n;
}
if (ftnunit->uacc != KEYED)
errret(a->cierr, 162, "rewrite");
ftnunit->dowrite = idxrewrite;
return (0);
}
static int32 s_wsfe_com (cilist64 *a, unit **fu)
{
unit *ftnunit;
int n = wsfe(a, fu, 0);
ftnunit = *fu;
if (n)
return n;
if (ftnunit->uacc != KEYED) {
if (f77nowwriting (ftnunit))
errret(a->cierr, 160, "startwrt");
}
#ifdef I90
ftnunit->f90sw = 0;
ftnunit->f90nadv = 0;
ftnunit->f77recpos = 0;
ftnunit->f77recend = 0;
#endif
ftnunit->dowrite = x_wEND;
return (0);
}
static int
s_rsue_com (cilist64 *a, unit **fu)
{
int n;
unit *ftnunit;
int f77reclen_32bit;
if (!f77init)
f_init ();
n = c_sue (a, fu);
ftnunit = *fu;
if (n) {
if (n > 0) {
errret(a->cierr, n, "s_rsue");
} else {
errret(a->ciend, n, "s_rsue");
}
}
ftnunit->f77recpos = ftnunit->f77reclen = 0;
#ifdef I90
if (ftnunit->uaction == WRITEONLY )
errret(ftnunit->f77errlist.cierr,180,"startread");
#endif
/*
* The direct unformatted case, yup, in the sequential unformatted
* file.
*/
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) {
if (ftnunit->url != 1) {
ftnunit->f77do_unf = do_ud;
ftnunit->f77reclen = ftnunit->url;
} else {
/* For 'SYSTEM' file set a very large MAX_INT value for record
length so it cannot be exceeded
*/
#if (_MIPS_SIM == _MIPS_SIM_ABI64)
ftnunit->f77reclen = LONGLONG_MAX;
#else
ftnunit->f77reclen = LONG_MAX;
#endif
ftnunit->f77do_unf = do_ud;
}
_fio_seq_pos( ftnunit->ufd, ftnunit );
ftnunit->uwrt &= ~WR_OP;
return (0);
} else {
if (ftnunit->uwrt & WR_OP)
(void) f77nowreading (ftnunit);
}
/* The normal case. */
if (ftnunit->uacc == KEYED) {
ftnunit->f77do_unf = do_ui;
ftnunit->f77idxlist.cimatch = a->cimatch;
ftnunit->f77idxlist.cikeytype = a->cikeytype;
ftnunit->f77idxlist.cikeyval.cicharval = a->cikeyval.cicharval;
ftnunit->f77idxlist.cikeyid = a->cikeyid;
ftnunit->f77idxlist.cinml = a->cinml;
ftnunit->f77idxlist.cikeyvallen = a->cikeyvallen;
if (n = idxread(ftnunit)) {
if (n > 0) {
errret(a->cierr, n, "s_rsue");
} else {
errret(a->ciend, n, "s_rsue");
}
}
} else if (ftnunit->url != 1) {
ftnunit->f77do_unf = do_us;
if (ftnunit->uerror)
unf_position (ftnunit->ufd, ftnunit);
if (fread ((char *) &f77reclen_32bit, sizeof (int), 1, ftnunit->ufd) != 1) {
if (feof (ftnunit->ufd)) {
ftnunit->uend = 1;
errret(a->ciend, EOF, "start");
}
clearerr(ftnunit->ufd);
errret(a->cierr, errno, "start");
}
ftnunit->f77reclen = f77reclen_32bit;
} else {
ftnunit->f77reclen = INT_MAX;
ftnunit->f77do_unf = do_ud;
}
return (0);
}
int s_rsfe_com (cilist *a, unit **fu)
#endif
{
int n;
unit *ftnunit;
if (!f77init)
f_init ();
if (n = c_sfe (a, fu))
return (n);
ftnunit = *fu;
/* Fix BN 9768.
* If user tries to read from stdout then cause startio to abort with an
* error. This is particularly importrant if a user is tries to read from
* fortran unit 6 , which by default is connected to stdout. Even though
* the standard says nothing about the way unit 5 and unit 6 should be
* handled, I generally think that it is a good idea to distinguish
* between these and not allow users to read from stdout.
* ---ravi---1/7/92
*/
/* Fix 12308: Read error from stdout should occur for only files
* connected to terminal. The change is taken from the 'fix'
* section of the bug description - Bhaskar 08/14/92 */
if (ftnunit->ufd == stdout && isatty (fileno (ftnunit->ufd)))
errret(a->cierr, 173, "startio");
ftnunit->f77errlist.cierr = a->cierr;
ftnunit->f77errlist.ciend = a->ciend;
ftnunit->f77errlist.cieor = a->cieor;
ftnunit->f77errlist.cisize = a->cisize;
ftnunit->f77errlist.iciunit = 0;
ftnunit->f77scale = 0;
ftnunit->f77fmtbuf = a->cifmt;
if (ftnunit->uacc == KEYED) {
ftnunit->f77idxlist.cimatch = a->cimatch;
ftnunit->f77idxlist.cikeytype = a->cikeytype;
ftnunit->f77idxlist.cikeyval.cicharval = a->cikeyval.cicharval;
ftnunit->f77idxlist.cikeyid = a->cikeyid;
ftnunit->f77idxlist.cinml = a->cinml;
ftnunit->f77idxlist.cikeyvallen = a->cikeyvallen;
}
else {
if (ftnunit->uacc == DIRECT)
errret(a->cierr, 171, "sequential read");
if (ftnunit->ualias->ucc == CC_FORTRAN &&
ftnunit->ualias->ucchar) {
putc (ftnunit->ualias->ucchar, ftnunit->ualias->ufd);
ftnunit->ualias->ucchar = '\0';
} else if (ftnunit->ucc == CC_FORTRAN && ftnunit->ucchar) {
putc (ftnunit->ucchar, ftnunit->ufd);
ftnunit->ucchar = '\0';
}
}
#ifdef I90
ftnunit->f90sw = 0;
ftnunit->f90nadv = 0;
#endif
if (pars_f (ftnunit, ftnunit->f77fmtbuf) < 0)
errret(a->cierr, 100, "startio");
ftnunit->f77getn = x_getc;
ftnunit->f77gets = x_gets;
ftnunit->f77ungetn = x_ungetc;
ftnunit->f77doed = rd_ed;
ftnunit->f77doned = rd_ned;
fmt_bg (ftnunit);
ftnunit->f77doend = x_endp;
ftnunit->f77donewrec = xrd_SL;
ftnunit->f77dorevert = x_rev;
ftnunit->f77cblank = ftnunit->ublnk;
ftnunit->f77cplus = 0;
if (ftnunit->ufd == stdin && feof (ftnunit->ufd) && f77vms_flag_[VMS_IN])
clearerr(ftnunit->ufd);
(void) f77nowreading (ftnunit);
check_buflen( ftnunit, ftnunit->url > FIO_ALLOC ? ftnunit->url : FIO_ALLOC );
#ifdef I90
if (ftnunit->uaction == WRITEONLY )
errret(ftnunit->f77errlist.cierr,180,"startread");
ftnunit->f77recpos = 0;
ftnunit->f77recend = 0;
#endif
n = xrd_SL (ftnunit);
if (n > 0) {
errret(a->cierr, n, "s_rsfe");
} else if (n < 0) {
errret(a->ciend, n, "s_rsfe");
} else
return(0);
}
static int
f_rew_com (alist *a, int lock)
{
unit *ftnunit;
if ((ftnunit = find_luno (a->aunit)) == NULL)
return(0);
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uacc == KEYED)
errret(a->aerr, 164, "rewind");
if (ftnunit->uconn <= 0) {
ftnunit->lock_unit = 0;
return (0);
}
if (!ftnunit->useek && !ftnunit->uistty)
errret(a->aerr, 106, "rewind");
ftnunit->uend = 0;
/* Need to reset the associate variable to 1 if exists */
if (ftnunit->uassocv)
set_var (ftnunit->uassocv, ftnunit->umask, ASSOCV, (ftnll) 1);
/* Rewind of a direct unformatted file. */
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) {
if (-1 == lseek ((int) ftnunit->ufd, 0, SEEK_SET)) {
errret(a->aerr, 106, "rewind");
}
/* need to change the internal buffer position in fio_direct_io as well */
_fio_set_seek((int) ftnunit->ufd, (ftnll) 0, 0);
ftnunit->uirec = 0;
ftnunit->lock_unit = 0;
return (1);
}
#ifdef I90
/* Make sure these variables are zeroed out to allow record to be reread. */
ftnunit->f77recpos = 0;
ftnunit->f77recend = 0;
#endif
if (f77vms_flag_[VMS_EF]) { /* rewind to the last endfile record
* or beginning of file */
char buf[513];
XINT64 y, x;
int i, n;
char ch;
/* If last operation was a WRITE, truncate the file and then make
sure that the file mode is switched to READ so the the next
REWIND/BACKSPACE won't truncate the file again
*/
if (ftnunit->uwrt & WR_OP) {
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if (ftnunit->f90sw == 1 && ftnunit->f90nadv == 1 ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
(void) t_runc (ftnunit, a->aerr);
/* If the file is in write-only mode make sure that it is readable */
if (f77nowreading(ftnunit))
errret(a->aerr, 106, "rewind");
}
if (ftnunit->ufmt != 1) {
if (ftell (ftnunit->ufd) == 0) {
ftnunit->lock_unit = 0;
return (0); /* already at beginning of file */
}
if (fseek (ftnunit->ufd, (long) (-sizeof (int)), 1) < 0)
errret(a->aerr, 106, "rewind");
for (i = 0;; i++) {
(void) fread ((char *) &n, sizeof (int), 1, ftnunit->ufd);
if (n != 1 || i == 0) {
if (fseek (ftnunit->ufd, (long) (-n - 3 * sizeof (int)), 1)) {
rewind (ftnunit->ufd);
ftnunit->lock_unit = 0;
return (0);
}
} else {
if (fseek (ftnunit->ufd, -(sizeof (int) + 1), 1)) {
rewind (ftnunit->ufd);
ftnunit->lock_unit = 0;
return (0);
}
(void) fread ((char *) &ch, 1, 1, ftnunit->ufd);
if (ch == '\032') {
fseek (ftnunit->ufd, sizeof (int), 1);
ftnunit->lock_unit = 0;
return (0);
}
fseek (ftnunit->ufd, -(2 * sizeof (int) + 1), 1);
}
}
}
y = x = FTELL (ftnunit->ufd) - 2; /* skip the last endfile
* record */
if (y < 0) {
(void) fseek(ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return(0);
}
ch = '\0';
for (;;) {
if (x < sizeof (buf) - 1)
x = 0;
else
x -= sizeof (buf) - 1;
(void) FSEEK (ftnunit->ufd, x, 0);
n = (int) fread (buf, 1, (int) (y - x), ftnunit->ufd);
buf[n] = ch;
for (i = n - 1; i >= 1; i--) {
if (buf[i] != '\032' || buf[i + 1] != '\n')
continue;
(void) fseek (ftnunit->ufd, (long) (i + 2 - n), 1);
ftnunit->lock_unit = 0;
return (0);
}
if (x == 0) {
(void) fseek (ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return (0);
}
y = x;
ch = buf[0];
}
}
/* If last operation was a WRITE, truncate the file and then make
sure that the file mode is switched to READ so the the next
REWIND/BACKSPACE won't truncate the file again
*/
if (ftnunit->uwrt & WR_OP) {
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if (ftnunit->f90sw == 1 && ftnunit->f90nadv == 1 ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
(void) t_runc (ftnunit, a->aerr);
/* If the file is in write-only mode make sure that it is readable */
if (f77nowreading(ftnunit))
errret(a->aerr, 106, "backspace");
}
rewind (ftnunit->ufd);
ftnunit->lock_unit = 0;
return (0);
}
int
do_us (unit *ftnunit, XINT *number, char *ptr, ftnlen len)
{
if (!(ftnunit->uwrt & WR_OP)) {
XINT nread = *number * len;
ftnunit->f77recpos += nread;
if (ftnunit->f77reclen == 1 && f77vms_flag_[VMS_EF]) {
/* VMS endfile record */
(void) fread (ptr, 1, 1, ftnunit->ufd);
if (*ptr == '\032') {
(void) fseek (ftnunit->ufd, sizeof (int), 1);
return( EOF ); /* Endfile record */
} else if (ftnunit->f77recpos > 1)
errret(ftnunit->f77errlist.cierr, 110, "eof/uio");
return (0);
}
if (ftnunit->f77recpos > ftnunit->f77reclen) {
ftnunit->f77recpos -= nread;
(void) fread (ptr, (int) ftnunit->f77reclen - ftnunit->f77recpos, 1, ftnunit->ufd);
errret(ftnunit->f77errlist.cierr, 110, "eof/uio");
}
(void) fread (ptr, (int) nread, 1, ftnunit->ufd);
return (0);
} else {
/* 7/18/90 MNH REPLACE FWRITE WITH MEMCPY -- FWRITE BEGAN AT BYTE #5 TO */
/* ALLOW SPACE FOR EVENTUAL FRWITE OF "f77reclen" TO BEGINNING OF FILE */
XINT n = *number * len;
int seekdone = 0;
if (ftnunit->f77recpos + n > ftnunit->f77fio_size || n >= BUFSIZ || est_reclen) {
if (!ftnunit->overflowed) {
ftnunit->overflowed = 1;
if (!est_reclen) {
if (ftnunit->f77recpos == 4) {
fseek (ftnunit->ufd, 4, 1);
seekdone = 1;
ftnunit->f77recpos = 0;
}
} else
*(int *) ftnunit->f77fio_buf = est_reclen;
}
if (ftnunit->f77recpos) {
if (fwrite (ftnunit->f77fio_buf, ftnunit->f77recpos, 1, ftnunit->ufd) != 1)
errret(ftnunit->f77errlist.cierr, errno, "system write error");
ftnunit->f77recpos = 0;
}
if (n >= BUFSIZ) {
/* for large user data it's preferable to flush the
* system buffer to disk so that it won't have to copy
* the user array, which could be several megs, to the
* system buffer before writing it out */
if (!seekdone)
fseek (ftnunit->ufd, 0, 1);
if (fwrite (ptr, n, 1, ftnunit->ufd) != 1)
errret(ftnunit->f77errlist.cierr, errno, "system write error");
ftnunit->f77reclen += n;
return (0);
}
}
if (!est_reclen) {
if (ftnunit->f77recpos + n > ftnunit->f77fio_size)
check_buflen( ftnunit, ftnunit->f77recpos + n );
memcpy (ftnunit->f77fio_buf + ftnunit->f77recpos, ptr, n);
ftnunit->f77recpos += n;
} else if (fwrite (ptr, n, 1, ftnunit->ufd) != 1) {
ftnunit->f77recpos = 0;
errret(ftnunit->f77errlist.cierr, errno, "system write error");
}
ftnunit->f77reclen += n;
return (0);
}
}
static ftnint
__f77_f_back_com (alist *a, int lock)
{
unit *ftnunit;
int n, i;
ftnll x, y;
char buf[512];
if ((ftnunit = find_luno (a->aunit)) == NULL)
err(a->aerr, 114, "backspace");
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uacc == APPEND || ftnunit->uacc == KEYED)
errret(a->aerr, 165, "backspace");
if (ftnunit->useek == 0 || ftnunit->url == 1)
errret(a->aerr, 106, "backspace");
if (ftnunit->uend == 1) {
ftnunit->uend = 0;
ftnunit->lock_unit = 0;
return (0);
}
if (ftnunit->uwrt & WR_OP) {
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if (ftnunit->f90sw == 1 && ftnunit->f90nadv == 1 ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
/* Just completed a write operation, a backspace would force
the truncation of the file at the current position.
*/
(void) t_runc (ftnunit, a->aerr);
/* make sure it gets switched back to reading mode so the
file won't get truncated again if it gets backspace/rewind again
*/
if (f77nowreading(ftnunit))
errret(a->aerr, 106, "backspace");
}
/* Backspace a direct unformatted file. */
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) {
if (ftnunit->uirec != 0)
ftnunit->uirec--;
ftnunit->lock_unit = 0;
return (0);
}
if (ftnunit->ufmt != 1) {
if (ftnunit->uerror)
unf_position (ftnunit->ufd, ftnunit);
if (fseek (ftnunit->ufd, -(long) sizeof (int), 1)) {
fseek(ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return(0);
}
/* NEED TO CHANGE HERE DLAI */
(void) fread ((char *) &n, sizeof (int), 1, ftnunit->ufd);
(void) fseek (ftnunit->ufd, (long) (-n - 2 * sizeof (int)), 1);
ftnunit->lock_unit = 0;
return (0);
}
y = x = FTELL (ftnunit->ufd) - 1; /* skip the last CR */
/* If already at the beginning of file, ignore the backspace */
if (x < 0) {
ftnunit->lock_unit = 0;
return (0);
}
#ifdef I90
/* Make sure these variables are zeroed out to allow record to be reread. */
ftnunit->f77recpos = 0;
ftnunit->f77recend = 0;
#endif
for (;;) {
if (x < sizeof (buf))
x = 0;
else
x -= sizeof (buf);
(void) FSEEK (ftnunit->ufd, x, 0);
/* n should be ll for 64 bit records */
n = (int) fread (buf, 1, (int) (y - x), ftnunit->ufd);
for (i = n - 1; i >= 0; i--) {
if (buf[i] != '\n')
continue;
(void) fseek (ftnunit->ufd, (long) (i + 1 - n), 1);
ftnunit->lock_unit = 0;
return (0);
}
if (x == 0) {
(void) fseek (ftnunit->ufd, 0L, 0);
ftnunit->lock_unit = 0;
return (0);
} else if (n <= 0)
errret (a->aerr, (EOF), "backspace")
(void) FSEEK (ftnunit->ufd, x, 0);
y = x;
}
}
