The attached patch fixes numerous ICE's where a program
writed invalid code (see testcase). Regression tested
on i386-*-freebsd. OK to commit?
2015-07-05 Steven G. Kargl <ka...@gcc.gnu.org>
* io.c (check_char_variable): New function.
(match_open_element, match_close_element, match_file_element,
match_dt_element, match_inquire_element, match_wait_element): Use it.
2015-07-05 Steven G. Kargl <ka...@gcc.gnu.org>
* gfortran.dg/iomsg_2.f90: New test.
--
Steve
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c (revision 225415)
+++ gcc/fortran/io.c (working copy)
@@ -1181,7 +1181,7 @@ check_format_string (gfc_expr *e, bool i
}
-/************ Fortran 95 I/O statement matchers *************/
+/************ Fortran I/O statement matchers *************/
/* Match a FORMAT statement. This amounts to actually parsing the
format descriptors in order to correctly locate the end of the
@@ -1242,6 +1242,21 @@ gfc_match_format (void)
}
+/* Check for a CHARACTER variable. The check for scalar is done in
+ resolve_tag. */
+
+static bool
+check_char_variable (gfc_expr *e)
+{
+ if (e->expr_type != EXPR_VARIABLE || e->ts.type != BT_CHARACTER)
+ {
+ gfc_error("IOMSG must be a scalar-default-char-variable at %L", &e->where);
+ return false;
+ }
+ return true;
+}
+
+
static bool
is_char_type (const char *name, gfc_expr *e)
{
@@ -1570,7 +1585,9 @@ match_open_element (gfc_open *open)
m = match_etag (&tag_unit, &open->unit);
if (m != MATCH_NO)
return m;
- m = match_out_tag (&tag_iomsg, &open->iomsg);
+ m = match_etag (&tag_iomsg, &open->iomsg);
+ if (m == MATCH_YES && !check_char_variable (open->iomsg))
+ return MATCH_ERROR;
if (m != MATCH_NO)
return m;
m = match_out_tag (&tag_iostat, &open->iostat);
@@ -2234,7 +2251,9 @@ match_close_element (gfc_close *close)
m = match_etag (&tag_status, &close->status);
if (m != MATCH_NO)
return m;
- m = match_out_tag (&tag_iomsg, &close->iomsg);
+ m = match_etag (&tag_iomsg, &close->iomsg);
+ if (m == MATCH_YES && !check_char_variable (close->iomsg))
+ return MATCH_ERROR;
if (m != MATCH_NO)
return m;
m = match_out_tag (&tag_iostat, &close->iostat);
@@ -2395,7 +2414,9 @@ match_file_element (gfc_filepos *fp)
m = match_etag (&tag_unit, &fp->unit);
if (m != MATCH_NO)
return m;
- m = match_out_tag (&tag_iomsg, &fp->iomsg);
+ m = match_etag (&tag_iomsg, &fp->iomsg);
+ if (m == MATCH_YES && !check_char_variable (fp->iomsg))
+ return MATCH_ERROR;
if (m != MATCH_NO)
return m;
m = match_out_tag (&tag_iostat, &fp->iostat);
@@ -2760,7 +2781,9 @@ match_dt_element (io_kind k, gfc_dt *dt)
m = match_etag (&tag_spos, &dt->pos);
if (m != MATCH_NO)
return m;
- m = match_out_tag (&tag_iomsg, &dt->iomsg);
+ m = match_etag (&tag_iomsg, &dt->iomsg);
+ if (m == MATCH_YES && !check_char_variable (dt->iomsg))
+ return MATCH_ERROR;
if (m != MATCH_NO)
return m;
@@ -3939,7 +3962,9 @@ match_inquire_element (gfc_inquire *inqu
m = match_etag (&tag_unit, &inquire->unit);
RETM m = match_etag (&tag_file, &inquire->file);
RETM m = match_ltag (&tag_err, &inquire->err);
- RETM m = match_out_tag (&tag_iomsg, &inquire->iomsg);
+ RETM m = match_etag (&tag_iomsg, &inquire->iomsg);
+ if (m == MATCH_YES && !check_char_variable (inquire->iomsg))
+ return MATCH_ERROR;
RETM m = match_out_tag (&tag_iostat, &inquire->iostat);
RETM m = match_vtag (&tag_exist, &inquire->exist);
RETM m = match_vtag (&tag_opened, &inquire->opened);
@@ -4222,7 +4247,9 @@ match_wait_element (gfc_wait *wait)
RETM m = match_ltag (&tag_err, &wait->err);
RETM m = match_ltag (&tag_end, &wait->eor);
RETM m = match_ltag (&tag_eor, &wait->end);
- RETM m = match_out_tag (&tag_iomsg, &wait->iomsg);
+ RETM m = match_etag (&tag_iomsg, &wait->iomsg);
+ if (m == MATCH_YES && !check_char_variable (wait->iomsg))
+ return MATCH_ERROR;
RETM m = match_out_tag (&tag_iostat, &wait->iostat);
RETM m = match_etag (&tag_id, &wait->id);
RETM return MATCH_NO;
Index: gcc/testsuite/gfortran.dg/iomsg_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/iomsg_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/iomsg_2.f90 (working copy)
@@ -0,0 +1,44 @@
+! { dg-do compile }
+subroutine foo1
+ implicit none
+ integer i
+ open(1, iomsg=666) ! { dg-error "IOMSG must be" }
+ open(1, iomsg='sgk') ! { dg-error "IOMSG must be" }
+ open(1, iomsg=i) ! { dg-error "IOMSG must be" }
+ close(1, iomsg=666) ! { dg-error "IOMSG must be" }
+ close(1, iomsg='sgk') ! { dg-error "IOMSG must be" }
+ close(1, iomsg=i) ! { dg-error "IOMSG must be" }
+end subroutine foo1
+
+subroutine foo
+ implicit none
+ integer i
+ real :: x = 1
+ write(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" }
+ write(1, *, iomsg=i) x ! { dg-error "IOMSG must be" }
+ read(1, *, iomsg='sgk') x ! { dg-error "IOMSG must be" }
+ read(1, *, iomsg=i) x ! { dg-error "IOMSG must be" }
+ flush(1, iomsg='sgk') ! { dg-error "IOMSG must be" }
+ flush(1, iomsg=i) ! { dg-error "IOMSG must be" }
+ rewind(1, iomsg='sgk') ! { dg-error "IOMSG must be" }
+ rewind(1, iomsg=i) ! { dg-error "IOMSG must be" }
+ backspace(1,iomsg='sgk') ! { dg-error "IOMSG must be" }
+ backspace(1,iomsg=i) ! { dg-error "IOMSG must be" }
+ wait(1, iomsg='sgk') ! { dg-error "IOMSG must be" }
+ wait(1, iomsg=i) ! { dg-error "IOMSG must be" }
+end subroutine foo
+
+subroutine bar
+ implicit none
+ integer i
+ real :: x = 1
+ character(len=20) s(2)
+ open(1, iomsg=s) ! { dg-error "must be scalar" }
+ close(1, iomsg=s) ! { dg-error "must be scalar" }
+ write(1, *, iomsg=s) x ! { dg-error "must be scalar" }
+ read(1, *, iomsg=s) x ! { dg-error "must be scalar" }
+ flush(1, iomsg=s) ! { dg-error "must be scalar" }
+ rewind(1, iomsg=s) ! { dg-error "must be scalar" }
+ backspace(1,iomsg=s) ! { dg-error "must be scalar" }
+ wait(1, iomsg=s) ! { dg-error "must be scalar" }
+end subroutine bar
