io.c (check_char_variable): New function.

2015-07-06  Steven G. Kargl  <kargl@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-06  Steven G. Kargl  <kargl@gcc.gnu.org>

	* gfortran.dg/iomsg_2.f90: New test.

From-SVN: r225462

gcc/fortran/ChangeLog

+2015-07-06  Steven G. Kargl  <kargl@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-06  Andre Vehreschild  <vehre@gmx.de>
 
 	PR fortran/58586

gcc/fortran/io.c

@@ -1181,7 +1181,7 @@ check_format_string (gfc_expr *e, bool is_input)
 }
 
 
-/************ 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 *inquire)
   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;

gcc/testsuite/ChangeLog

+2015-07-06  Steven G. Kargl  <kargl@gcc.gnu.org>
+
+	* gfortran.dg/iomsg_2.f90: New test.
+
 2015-07-06  Richard Biener  <rguenther@suse.de>
 
 	PR tree-optimization/66772

gcc/testsuite/gfortran.dg/iomsg_2.f90

+! { 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