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; }
static int c_dfe (cilist64 *a, unit **fu) { unit *ftnunit; extern FILE *debugfile; if ((ftnunit = *fu = find_luno (a->ciunit)) == NULL) if (fk_open (DIR, FMT, a->ciunit)) err(a->cierr, 104, "dfe"); while (fu != &f77curunit && test_and_set( &ftnunit->lock_unit, 1L )) ; 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->f77cursor = ftnunit->f77recpos = ftnunit->f77recend = 0; ftnunit->f77scale = 0; ftnunit->ufd = ftnunit->ufd; if (!ftnunit->ufmt) err(a->cierr, 102, "dfe") if (!ftnunit->useek) err(a->cierr, 104, "dfe") if (a->cirec < 1) err(a->cierr, 168, "dfe"); ftnunit->f77fmtbuf = a->cifmt; /* fprintf( debugfile, "At position %d for thread %d, oldrec = %d, newrec = %d\n", ftell( ftnunit->ufd ), mp_my_threadnum_(), ftnunit->uirec, a->cirec ); */ if (FSEEK (ftnunit->ufd, (ftnll)ftnunit->url * (a->cirec - 1), 0)) err( a->cierr, errno, "Direct formatted"); if (ftnunit->uassocv) set_var ((ftnintu *)ftnunit->uassocv, ftnunit->umask, ASSOCV, a->cirec); ftnunit->uend = 0; 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; } }
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); }