g77 file truncation bug

[mike at snl951 dot chem dot metro-u dot ac dot jp]

GNU Compiler Bugs                                      Feb.20, 2001
Free Software Foundation
59 Temple Place - Suite 330
Boston, MA 02111-1307, USA

gcc-bugs@gcc.gnu.org

I would like to report a serious defect in the I/O library of g77,
present in versions up to 2.95, and a fix for this.  This E-mail 
consists of three parts:
    1. a description of the problem
    2. a small FORTRAN program demonstrating it
    3. a fix to the endfile.c routine

The problem manifests itself in the GAMESS program for molecular
quantum chemistry.  This is a 200,000+ line FORTRAN code developed
by us and used in thousands of locations around the world, today
many of them running Linux.  While the g77 compiler is able to
generate correct object code for this large program, the associated
I/O library has a serious defect.  This problem was tracked down
by Brett Bode at my laboratory in America, since I myself do not
know anything about the C language which was used to implement 
the libg2c.a interface library.

The problem is that when a disk file is overwritten, and its new
length is shorter than its previous length, the shorter length file
is truncated in a peculiar way.  It seems the file is copied into 
the /tmp partition, reopened so it has zero length, and then the
data is copied back into the file from /tmp.  This is not only very
inefficient, it is sure to fail whenever the file is bigger than
the free space in /tmp.  Since our disk files routinely exceed 1 GB,
this is very often.  The fix for the problem is to use the system
call ftruncate() instead of this double copying.

This problem does not occur in the versions of f2c that were included
in the RedHat 5.x distributions.  However the f2c interpreter is no
longer included in the 6.x RedHat distributions, meaning the users
of our program have little choice but to use g77.  I therefore hope
that a fix for the I/O problem will quickly make its way into the 
g77 library.

My leave of absence in Japan continues until the end of March, where
I am mike@snl951.chem.metro-u.ac.jp.  After April 1, my permanent
E-mail address is mike@si.fi.ameslab.gov.  Brett Bode mentioned
above as devising the fix is brett@scl.ameslab.gov

Thanks,
Mike Schmidt
Visiting Professor of Chemistry
Tokyo Metropolitan University
Hachioji-shi 192-0347
Tokyo-to JAPAN

permanent address:
Department of Chemistry
Iowa State University
Ames, IA 50011 USA

-----------------------------------------------------------------
This short program demonstrates a core dump when trying to
truncate a file whose original length exceeds the free space
in /tmp.  

The OPEN statement needs to have its file name changed:

       program iobug
       implicit double precision(a-h,o-z)
       parameter (mxfile=10)
       dimension fvals(15000), nrec(mxfile)
       data nrec/250,200,600,100,220,50,580,150,250,220/
c
c           Demonstration program illustrating g77's inability to
c           correctly truncate files written to shorter lengths
c           than they were before.  This job fails on the 4th time
c           through loop 700.
c
c           The file name in the open statement below needs to be any
c           place where a file of 600*15000*8 bytes = 68 MBytes is OK.
c           If your /tmp is bigger than 64 MBytes, increase the 3rd
c           value in -nrec- so that the 3rd file is bigger than the
c           available space in the /tmp partition.
c
       io=1
       open(unit=io, file='/spider/mike/scr/iobug.dat',
      *     status='new', access='sequential', form='unformatted')
c
       do i=1,15000
          fvals(i) = i
       enddo
c
       do 700 ifile=1,mxfile
          write(6,9000) ifile
          do irec=1,nrec(ifile)
             write(io) fvals
          enddo
c
          write(6,9001)
          rewind io
c
          write(6,9002)
          do irec=1,nrec(ifile)
             read(io) fvals
          enddo
          write(6,9003)
   700 continue
c
       close(unit=io, status='delete')
       stop
  9000 format('file count',i4,' writing...',$)
  9001 format('rewinding...',$)
  9002 format('reading...',$)
  9003 format('file processed OK')
       end
-----------------------------------------------------------------
Here is a fixed version of endfile.c from Brett Bode:

#include "f2c.h"
#include "fio.h"

#ifdef KR_headers
extern char *strcpy();
extern FILE *tmpfile();
#else
#undef abs
#undef min
#undef max
#include <stdlib.h>
#include <string.h>
#endif

extern char *f__r_mode[], *f__w_mode[];

#ifdef KR_headers
integer f_end(a) alist *a;
#else
integer f_end(alist *a)
#endif
{
	unit *b;
	FILE *tf;

	if (f__init & 2)
		f__fatal (131, "I/O recursion");
	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",a->aunit);
		if (tf = fopen(nbuf, f__w_mode[0]))
			fclose(tf);
		return(0);
		}
	b->uend=1;
	return(b->useek ? t_runc(a) : 0);
}

  static int
#ifdef KR_headers
copy(from, len, to) FILE *from, *to; register long len;
#else
copy(FILE *from, register long len, FILE *to)
#endif
{
	int len1;
	char buf[BUFSIZ];

	while(fread(buf, len1 = len > BUFSIZ ? BUFSIZ : (int)len, 1, from)) {
		if (!fwrite(buf, len1, 1, to))
			return 1;
		if ((len -= len1) <= 0)
			break;
		}
	return 0;
	}

  int
#ifdef KR_headers
t_runc(a) alist *a;
#else
t_runc(alist *a)
#endif
{
	long loc, len;
	unit *b;
	FILE *bf, *tf;
	int rc = 0;

	b = &f__units[a->aunit];
	if(b->url)
		return(0);	/*don't truncate direct files*/
	loc=ftell(bf = b->ufd);
	fseek(bf,0L,SEEK_END);
	len=ftell(bf);
	if (loc >= len || b->useek == 0 || b->ufnm == NULL)
		return(0);

/* BMB The following code is commented out and replaced with
  * the single call to ftruncate (X/Open-UNIX standard) that follows
  * this block. Perhaps the ftruncate return value should be checked
  * for errors? */

/*	fclose(b->ufd);
	if (!loc) {
		if (!(bf = fopen(b->ufnm, f__w_mode[b->ufmt])))
			rc = 1;
		if (b->uwrt)
			b->uwrt = 1;
		goto done;
		}
	if (!(bf = fopen(b->ufnm, f__r_mode[0]))
	|| !(tf = tmpfile())) {
#ifdef NON_UNIX_STDIO
  bad:
#endif
		rc = 1;
		goto done;
		}
	if (copy(bf, loc, tf)) {
  bad1:
		rc = 1;
		goto done1;
		}
	if (!(bf = freopen(b->ufnm, f__w_mode[0], bf)))
		goto bad1;
	rewind(tf);
	if (copy(tf, loc, bf))
		goto bad1;
	b->urw = 2;
#ifdef NON_UNIX_STDIO
	if (b->ufmt) {
		fclose(bf);
		if (!(bf = fopen(b->ufnm, f__w_mode[3])))
			goto bad;
		fseek(bf,0L,SEEK_END);
		b->urw = 3;
		}
#endif
done1:
	fclose(tf);
done:
	f__cf = b->ufd = bf;
	if (rc)
		err(a->aerr,111,"endfile");*/
	ftruncate(b->ufd, loc);
	return 0;
	}