This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
gfortran patch for pr19314 - segfault on INQUIRE(POSITION=)
- From: Bud Davis <bdavis9659 at comcast dot net>
- To: gfortran <fortran at gcc dot gnu dot org>, "gcc-patches at gcc dot gnu dot org" <gcc-patches at gcc dot gnu dot org>
- Cc: Thomas dot Koenig at online dot de
- Date: Sun, 16 Jan 2005 22:38:50 -0600
- Subject: gfortran patch for pr19314 - segfault on INQUIRE(POSITION=)
POSITION= was not implemented, correctly.
tested with no additional testsuite failures on
AMD-64 / linux-gnu and i686/ linux-gnu.
no change to the NIST F77 tests.
a test suite file is provided that fails prior
and passes after this patch is applied. The test
checks all of the possible outcomes of INQUIRE(POSITION=.
this is not a g77 regression, but IMHO is the kind of bug
fix that should still go in prior to gcc-4.0 (small change,
corrects a segfault at runtime)
--bud
2005-01-17 Bud Davis <bdavis9659@comcast.net>
PR fortran/19314
* io/inquire.c(inquire_via_unit): implement POSITION=.
* io/transfer.c(next_record): update position for
INQUIRE.
* io/rewind.c(st_rewind): update position for
INQUIRE.
Index: gcc/libgfortran/io/inquire.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/inquire.c,v
retrieving revision 1.7
diff -c -3 -p -r1.7 inquire.c
*** gcc/libgfortran/io/inquire.c 12 Jan 2005 21:27:31 -0000 1.7
--- gcc/libgfortran/io/inquire.c 17 Jan 2005 04:02:11 -0000
*************** inquire_via_unit (gfc_unit * u)
*** 166,178 ****
if (ioparm.position != NULL)
{
if (u == NULL || u->flags.access == ACCESS_DIRECT)
! p = undefined;
else
! {
! p = NULL; /* TODO: Try to decode what the standard says... */
! }
!
! cf_strcpy (ioparm.blank, ioparm.blank_len, p);
}
if (ioparm.action != NULL)
--- 166,192 ----
if (ioparm.position != NULL)
{
if (u == NULL || u->flags.access == ACCESS_DIRECT)
! p = undefined;
else
! switch (u->flags.position)
! {
! case POSITION_REWIND:
! p = "REWIND";
! break;
! case POSITION_APPEND:
! p = "APPEND";
! break;
! case POSITION_ASIS:
! p = "ASIS";
! break;
! default:
! /* if not direct access, it must be
! either REWIND, APPEND, or ASIS.
! ASIS seems to be the best default */
! p = "ASIS";
! break;
! }
! cf_strcpy (ioparm.position, ioparm.position_len, p);
}
if (ioparm.action != NULL)
Index: gcc/libgfortran/io/rewind.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/rewind.c,v
retrieving revision 1.8
diff -c -3 -p -r1.8 rewind.c
*** gcc/libgfortran/io/rewind.c 12 Jan 2005 21:27:31 -0000 1.8
--- gcc/libgfortran/io/rewind.c 17 Jan 2005 04:02:11 -0000
*************** st_rewind (void)
*** 66,71 ****
--- 66,73 ----
u->current_record = 0;
test_endfile (u);
}
+ /* update position for INQUIRE */
+ u->flags.position = POSITION_REWIND;
}
library_end ();
Index: gcc/libgfortran/io/transfer.c
===================================================================
RCS file: /cvsroot/gcc/gcc/libgfortran/io/transfer.c,v
retrieving revision 1.27
diff -c -3 -p -r1.27 transfer.c
*** gcc/libgfortran/io/transfer.c 16 Jan 2005 20:44:01 -0000 1.27
--- gcc/libgfortran/io/transfer.c 17 Jan 2005 04:02:12 -0000
*************** next_record (int done)
*** 1363,1368 ****
--- 1363,1371 ----
else
next_record_w (done);
+ /* keep position up to date for INQUIRE */
+ current_unit->flags.position = POSITION_ASIS;
+
current_unit->current_record = 0;
if (current_unit->flags.access == ACCESS_DIRECT)
{
! pr19314 inquire(..position=..) segfaults
! test by Thomas.Koenig@online.de
! bdavis9659@comcast.net
implicit none
character*20 chr
logical debug
data debug /.FALSE./
open(7,STATUS='SCRATCH')
inquire(7,position=chr)
if (debug) then
if (chr.EQ.'ASIS') then
print*,chr,'OK'
else
print*,chr,'NOTOK'
endif
else
if (chr.NE.'ASIS') CALL ABORT
endif
close(7)
open(7,STATUS='SCRATCH',ACCESS='DIRECT',RECL=100)
inquire(7,position=chr)
if (debug) then
if (chr.EQ.'UNDEFINED') then
print*,chr,'OK'
else
print*,chr,'NOTOK'
endif
else
if (chr.NE.'UNDEFINED') CALL ABORT
endif
close(7)
open(7,STATUS='SCRATCH',POSITION='REWIND')
inquire(7,position=chr)
if (debug) then
if (chr.EQ.'REWIND') then
print*,chr,'OK'
else
print*,chr,'NOTOK'
endif
else
if (chr.NE.'REWIND') CALL ABORT
endif
close(7)
open(7,STATUS='SCRATCH',POSITION='ASIS')
inquire(7,position=chr)
if (debug) then
if (chr.EQ.'ASIS') then
print*,chr,'OK'
else
print*,chr,'NOTOK'
endif
else
if (chr.NE.'ASIS') CALL ABORT
endif
close(7)
open(7,STATUS='SCRATCH',POSITION='APPEND')
inquire(7,position=chr)
if (debug) then
if (chr.EQ.'APPEND') then
print*,chr,'OK'
else
print*,chr,'NOTOK'
endif
else
if (chr.NE.'APPEND') CALL ABORT
endif
close(7)
open(7,STATUS='SCRATCH',POSITION='REWIND')
write(7,*)'this is a record written to the file'
inquire(7,position=chr)
if (debug) then
if (chr.EQ.'ASIS') then
print*,chr,'OK'
else
print*,chr,'NOTOK'
endif
else
if (chr.NE.'ASIS') CALL ABORT
endif
rewind(7)
inquire(7,position=chr)
if (debug) then
if (chr.EQ.'REWIND') then
print*,chr,'OK'
else
print*,chr,'NOTOK'
endif
else
if (chr.NE.'REWIND') CALL ABORT
endif
close(7)
end