int
f_back(alist *a)
{
unit *b;
int n,i;
long x;
char buf[32];
if(a->aunit >= MXUNIT || a->aunit < 0)
err(a->aerr,101,"backspace")
b= &units[a->aunit];
if(b->useek==0) err(a->aerr,106,"backspace")
if(b->ufd==NULL) err(a->aerr,114,"backspace")
if(b->uend==1)
{ b->uend=0;
return(0);
}
if(b->uwrt)
{ t_runc(b);
nowreading(b);
}
if(b->url>0)
{
x=ftell(b->ufd);
x /= b->url;
x *= b->url;
fseek(b->ufd,x,0);
return(0);
}
if(b->ufmt==0)
{ fseek(b->ufd,-(long)sizeof(int),1);
fread((char *)&n,sizeof(int),1,b->ufd);
fseek(b->ufd,-(long)n-2*sizeof(int),1);
return(0);
}
for(;;)
{
x=ftell(b->ufd);
if(x<sizeof(buf)) x=0;
else x -= sizeof(buf);
fseek(b->ufd,x,0);
n=fread(buf,1,sizeof(buf),b->ufd);
for(i=n-1;i>=0;i--)
{
if(buf[i]!='\n') continue;
fseek(b->ufd,(long)(i-n),1);
return(0);
}
if(x==0) return(0);
else if(n==0) err(a->aerr,(EOF),"backspace")
else err(a->aerr,errno,"backspace");
}
}
int
f_end(alist *a)
{
unit *b;
if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
b = &units[a->aunit];
if(b->ufd==NULL) return(0);
b->uend=1;
if( b->useek==0) return(0);
ax=a;
if(b->uwrt) nowreading(b);
return(t_runc(b));
}
int
f_rew(alist *a)
{
unit *b;
if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"rewind");
b = &units[a->aunit];
if(b->ufd==NULL && fk_open(READ,SEQ,FMT,a->aunit)) err(a->aerr,114,"rewind")
if(!b->useek) err(a->aerr,106,"rewind")
if(b->uwrt)
{ nowreading(b);
t_runc(b);
}
rewind(b->ufd);
b->uend=0;
return(0);
}
integer f_end(alist *a)
{
unit *b;
FILE *tf;
if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
b = &f__units[a->aunit];
if(b->ufd==NULL) {
char nbuf[10];
sprintf(nbuf,"fort.%ld",(long)a->aunit);
if (tf = fopen(nbuf, f__w_mode[0]))
fclose(tf);
return(0);
}
b->uend=1;
return(b->useek ? t_runc(a) : 0);
}
integer f_rew(alist *a)
#endif
{
unit *b;
if(a->aunit>=MXUNIT || a->aunit<0)
err(a->aerr,101,"rewind");
b = &f__units[a->aunit];
if(b->ufd == NULL || b->uwrt == 3)
return(0);
if(!b->useek)
err(a->aerr,106,"rewind")
if(b->uwrt) {
(void) t_runc(a);
b->uwrt = 3;
}
rewind(b->ufd);
b->uend=0;
return(0);
}
integer f_rew(alist *a)
#endif
{
unit *b;
if (f__init & 2)
f__fatal (131, "I/O recursion");
if(a->aunit>=MXUNIT || a->aunit<0)
err(a->aerr,101,"rewind");
b = &f__units[a->aunit];
if(b->ufd == NULL || b->uwrt == 3)
return(0);
if(!b->useek)
err(a->aerr,106,"rewind");
if(b->uwrt) {
(void) t_runc(a);
b->uwrt = 3;
}
FSEEK(b->ufd, 0, SEEK_SET);
b->uend=0;
return(0);
}
integer f_clos(cllist *a)
#endif
{ unit *b;
if(a->cunit >= MXUNIT) return(0);
b= &f__units[a->cunit];
if(b->ufd==NULL)
goto done;
if (!a->csta)
if (b->uscrtch == 1)
goto Delete;
else
goto Keep;
switch(*a->csta) {
default:
Keep:
case 'k':
case 'K':
if(b->uwrt == 1)
t_runc((alist *)a);
if(b->ufnm) {
fclose(b->ufd);
free(b->ufnm);
}
break;
case 'd':
case 'D':
Delete:
if(b->ufnm) {
fclose(b->ufd);
unlink(b->ufnm); /*SYSDEP*/
free(b->ufnm);
}
}
b->ufd=NULL;
done:
b->uend=0;
b->ufnm=NULL;
return(0);
}
integer f_end(alist *a)
#endif
{
unit *b;
if(a->aunit>=MXUNIT || a->aunit<0) err(a->aerr,101,"endfile");
b = &f__units[a->aunit];
if(b->ufd==NULL) {
char nbuf[10];
(void) sprintf(nbuf,"fort.%ld",a->aunit);
#ifdef NON_UNIX_STDIO
{ FILE *tf;
if (tf = fopen(nbuf, f__w_mode[0]))
fclose(tf);
}
#else
close(creat(nbuf, 0666));
#endif
return(0);
}
b->uend=1;
return(b->useek ? t_runc(a) : 0);
}
integer f_back(alist *a)
#endif
{ unit *b;
OFF_T v, w, x, y, z;
uiolen n;
FILE *f;
f__curunit = b = &f__units[a->aunit]; /* curunit for error messages */
if(a->aunit >= MXUNIT || a->aunit < 0)
err(a->aerr,101,"backspace")
if(b->useek==0) err(a->aerr,106,"backspace")
if(b->ufd == NULL) {
fk_open(1, 1, a->aunit);
return(0);
}
if(b->uend==1)
{ b->uend=0;
return(0);
}
if(b->uwrt) {
t_runc(a);
if(f__nowreading(b))
err(a->aerr,errno,"backspace")
}
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;
}
}
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);
}
static ftnint
f_clos_com (cllist *a, int lock)
{
unit *ftnunit;
char *cbuf, c, buf[256], tbuf[12];
int n, istat;
if ((ftnunit = find_luno (a->cunit)) == NULL) {
return 0;
}
while (lock && test_and_set( &ftnunit->lock_unit, 1L ))
;
if (ftnunit->uconn <= 0) {
/* could be disconnected by other threads */
ftnunit->uconn = 0;
ftnunit->lock_unit = 0;
return(0);
}
ftnunit->uend = 0;
if (cbuf = a->csta)
switch (up_low (*cbuf++)) {
case 'd':
ftnunit->udisp = DELETE;
break;
case 'p':
ftnunit->udisp = PRINT;
goto checkdelete;
/*
* Fix BN 7869.
* This is very sloppy code for checking the specifiers to close. Currently
* both DISP and STATUS cannot be used as specifiers to close. This is a kludge
* that allows SAVE to be passed and treats it like KEEP instead of SUBMIT.
* ---ravi--- 10/30/91
* case 's': ftnunit->udisp = SUBMIT;
*/
case 's':
ftnunit->udisp = up_low (*cbuf) == 'a' ? KEEP : SUBMIT;
checkdelete:
while (c = (*cbuf++))
if ((c == '/') && (c = (*cbuf)) && (up_low (c) == 'd'))
ftnunit->udisp |= DELETE;
break;
case 'k':
if (ftnunit->uscrtch == 1)
err(a->cerr, F_ERKEEPSCRATCH, "close");
default:
ftnunit->udisp = KEEP;
}
if (ftnunit->uscrtch == 1)
ftnunit->udisp |= DELETE;
if (ftnunit->uacc == KEYED) {
n = idxclose(ftnunit, a->cerr);
ftnunit->lock_unit = 0;
return (n);
}
#ifdef I90
/* If in Fortran-90 nonadvancing mode, write endfile record (\n only). */
if ( (ftnunit->f90sw == 1) && (ftnunit->f90nadv == 1) && (ftnunit->uwrt & WR_OP) ) {
putc ('\n', ftnunit->ufd);
ftnunit->f90nadv = 0;
}
#endif
if (ftnunit->ucc == CC_FORTRAN && ftnunit->ucchar)
putc (ftnunit->ucchar, ftnunit->ufd);
if (ftnunit->ufd == stdin || ftnunit->ufd == stdout || ftnunit->ufd == stderr) {
/*
* Don't close stdin, stdout, and stderr otherwise other files
* can be opened using those pointers and caused a lot of confusion
*/
fflush(ftnunit->ufd);
goto cont;
}
if (ftnunit->uwrt & WR_OP)
(void) t_runc (ftnunit, a->cerr);
/* Close the file. */
if ((ftnunit->uacc == DIRECT) && (ftnunit->ufmt == 0)) { /* direct unformatted */
while (lock && test_and_set( &io_lock, 1L ))
;
if (ftnunit->uistty) {
_fio_du_close ((int) ftnunit->ufd); /* no error */
} else if (((int)ftnunit->ufd) != _fio_du_close ((int) ftnunit->ufd)) {
io_lock = 0;
if (lock) ftnunit->lock_unit = 0;
err (a->cerr, errno, "close");
}
io_lock = 0;
} else {
if (ftnunit->uistty) { /* have to call isatty() first to get
* correct result */
/* obtain exclusive lock for special I/O operation */
while (lock && test_and_set( &io_lock, 1L ))
;
istat = fclose (ftnunit->ufd);
io_lock = 0;
} else {
/* obtain exclusive lock for special I/O operation */
while (lock && test_and_set( &io_lock, 1L ))
;
istat = fclose (ftnunit->ufd);
io_lock = 0;
if (istat) {
if (lock) ftnunit->lock_unit = 0;
err (a->cerr, errno, "close");
}
}
}
if (ftnunit->ufnm) {
if (ftnunit->udisp & SUBMIT) {
(void) strcpy (tbuf, "tmp.FXXXXXX");
(void) mktemp (tbuf);
sprintf (buf, "cp %s %s", ftnunit->ufnm, tbuf);
system (buf);
sprintf (buf, "( chmod +x %s; %s; rm %s ) &",
tbuf, tbuf, tbuf);
system (buf);
} else if (ftnunit->udisp & PRINT) {
sprintf (buf, "lpr %s", ftnunit->ufnm);
system (buf);
}
if (ftnunit->udisp & DELETE)
(void) unlink (ftnunit->ufnm); /* SYSDEP */
free (ftnunit->ufnm);
ftnunit->ufnm = NULL;
}
cont:
/*
The following fixes bug #231656. The pointers involved are initialized
to zero (both when originally allocated in f_init() and when reallocated
in map_luno()). So, if non-zero, the buffers must have been allocated,
and we should free them.
*/
if (ftnunit->f77syl) {
free(ftnunit->f77syl);
ftnunit->f77syl = NULL;
}
if (ftnunit->f77fio_buf) {
free(ftnunit->f77fio_buf);
ftnunit->f77fio_buf = NULL;
ftnunit->f77fio_size = 0;
}
if (ftnunit->ukeys) {
free(ftnunit->ukeys);
ftnunit->ukeys = NULL;
}
ftnunit->ufd = NULL;
ftnunit->uconn = 0;
ftnunit->luno = 0;
if (lock) ftnunit->lock_unit = 0;
/* added in MIPS version 2.20 fix bug 6084 BN-8077. Undo 6084 fix */
return (0);
}
