Re: [Patch, Fortran] PR fortran/45776: More variable definition checks

[Daniel Kraft <d at domob dot eu>]

Here's an updated patch with the suggestions and IRC discussion 
incorporated -- earlier than I expected, but anyways ;)

What do you think about the new solution?  I will run a fresh regtest 
tomorrow, but at least the io_*, write_*, read_* and namelist_* tests 
seem to pass.  Ok?

Yours,
Daniel

Daniel Kraft wrote:
> Hi,
>
> the attached patch implements the missing IO related variable definition 
> checks (which is now PR 45776).  Except the LOCK/UNLOCK cases which can 
> not yet be implemented because locks are not yet in gfortran, the full 
> list of variable definition contexts of F2008, 16.6.7 should be 
> implemented with that.
>
> It fixes some accepts-invalid cases that my last patch created, but also 
> adds some checks that were missing before it.  As a bonus, it adds a 
> F2008 check when using NEWUNIT (which was missing before).
>
> As I'm not really familiar with the IO related data-structures, I left 
> two XXX comments in the patch asking for possible better solutions (when 
> they exist), please take a look at them.
>
> Regression testing on GNU/Linux-x86-32.  Ok for trunk if no failures?


--
http://www.pro-vegan.info/
--
Done:  Arc-Bar-Cav-Kni-Ran-Rog-Sam-Tou-Val-Wiz
To go: Hea-Mon-Pri

2010-09-24  Daniel Kraft  <d@domob.eu>

	PR fortran/45776
	* gfortran.h (struct gfc_dt): New member `dt_io_kind'.
	* io.c (resolve_tag): F2008 check for NEWUNIT and variable
	definition checks for NEWUNIT, IOSTAT, SIZE and IOMSG.
	(gfc_free_dt): Correctly handle freeing of `dt_io_kind' and
	`extra_comma' with changed semantics.
	(gfc_resolve_dt): Check variable definitions.
	(match_io_element): Remove INTENT and PURE checks here and
	initialize code->ext.dt member.
	(match_io): Set dt->dt_io_kind.
	(gfc_resolve_inquire): Check variable definition for all tags
	except UNIT, FILE and ID.
	* resolve.c (resolve_transfer): Variable definition check.

2010-09-24  Daniel Kraft  <d@domob.eu>

	PR fortran/45776
	* gfortran.dg/io_constraints_6.f03: New test.
	* gfortran.dg/io_constraints_7.f03: New test.
	* gfortran.dg/newunit_2.f90: New test.

Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 164550)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -1999,7 +1999,7 @@ typedef struct
 {
   gfc_expr *io_unit, *format_expr, *rec, *advance, *iostat, *size, *iomsg,
 	   *id, *pos, *asynchronous, *blank, *decimal, *delim, *pad, *round,
-	   *sign, *extra_comma;
+	   *sign, *extra_comma, *dt_io_kind;
 
   gfc_symbol *namelist;
   /* A format_label of `format_asterisk' indicates the "*" format */
Index: gcc/fortran/io.c
===================================================================
--- gcc/fortran/io.c	(revision 164549)
+++ gcc/fortran/io.c	(working copy)
@@ -1505,13 +1505,31 @@ resolve_tag (const io_tag *tag, gfc_expr
 	return FAILURE;
     }
 
+  if (tag == &tag_newunit)
+    {
+      if (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: NEWUNIT specifier"
+			  " at %L", &e->where) == FAILURE)
+	return FAILURE;
+    }
+
+  /* NEWUNIT, IOSTAT, SIZE and IOMSG are variable definition contexts.  */
+  if (tag == &tag_newunit || tag == &tag_iostat
+      || tag == &tag_size || tag == &tag_iomsg)
+    {
+      char context[64];
+
+      sprintf (context, _("%s tag"), tag->name);
+      if (gfc_check_vardef_context (e, false, context) == FAILURE)
+	return FAILURE;
+    }
+  
   if (tag == &tag_convert)
     {
       if (gfc_notify_std (GFC_STD_GNU, "Extension: CONVERT tag at %L",
 			  &e->where) == FAILURE)
 	return FAILURE;
     }
-  
+
   return SUCCESS;
 }
 
@@ -2707,8 +2725,9 @@ gfc_free_dt (gfc_dt *dt)
   gfc_free_expr (dt->round);
   gfc_free_expr (dt->blank);
   gfc_free_expr (dt->decimal);
-  gfc_free_expr (dt->extra_comma);
   gfc_free_expr (dt->pos);
+  gfc_free_expr (dt->dt_io_kind);
+  /* dt->extra_comma is a link to dt_io_kind if it is set.  */
   gfc_free (dt);
 }
 
@@ -2719,6 +2738,11 @@ gfc_try
 gfc_resolve_dt (gfc_dt *dt, locus *loc)
 {
   gfc_expr *e;
+  io_kind k;
+
+  /* This is set in any case.  */
+  gcc_assert (dt->dt_io_kind);
+  k = dt->dt_io_kind->value.iokind;
 
   RESOLVE_TAG (&tag_format, dt->format_expr);
   RESOLVE_TAG (&tag_rec, dt->rec);
@@ -2761,16 +2785,13 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
 	     type character, we assume its really the "format" form of the I/O
 	     statement.  We set the io_unit to the default unit and format to
 	     the character expression.  See F95 Standard section 9.4.  */
-	  io_kind k;
-	  k = dt->extra_comma->value.iokind;
 	  if (e->ts.type == BT_CHARACTER && (k == M_READ || k == M_PRINT))
 	    {
 	      dt->format_expr = dt->io_unit;
 	      dt->io_unit = default_unit (k);
 
-	      /* Free this pointer now so that a warning/error is not triggered
-		 below for the "Extension".  */
-	      gfc_free_expr (dt->extra_comma);
+	      /* Nullify this pointer now so that a warning/error is not
+		 triggered below for the "Extension".  */
 	      dt->extra_comma = NULL;
 	    }
 
@@ -2790,6 +2811,13 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
 	  gfc_error ("Internal unit with vector subscript at %L", &e->where);
 	  return FAILURE;
 	}
+
+      /* If we are writing, make sure the internal unit can be changed.  */
+      gcc_assert (k != M_PRINT);
+      if (k == M_WRITE
+	  && gfc_check_vardef_context (e, false, _("internal unit in WRITE"))
+	       == FAILURE)
+	return FAILURE;
     }
 
   if (e->rank && e->ts.type != BT_CHARACTER)
@@ -2801,10 +2829,36 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
   if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_INTEGER
       && mpz_sgn (e->value.integer) < 0)
     {
-      gfc_error ("UNIT number in statement at %L must be non-negative", &e->where);
+      gfc_error ("UNIT number in statement at %L must be non-negative",
+		 &e->where);
       return FAILURE;
     }
 
+  /* If we are reading and have a namelist, check that all namelist symbols
+     can appear in a variable definition context.  */
+  if (k == M_READ && dt->namelist)
+    {
+      gfc_namelist* n;
+      for (n = dt->namelist->namelist; n; n = n->next)
+	{
+	  gfc_expr* e;
+	  gfc_try t;
+
+	  e = gfc_get_variable_expr (gfc_find_sym_in_symtree (n->sym));
+	  t = gfc_check_vardef_context (e, false, NULL);
+	  gfc_free_expr (e);
+
+	  if (t == FAILURE)
+	    {
+	      gfc_error ("NAMELIST '%s' in READ statement at %L contains"
+			 " the symbol '%s' which may not appear in a"
+			 " variable definition context",
+			 dt->namelist->name, loc, n->sym->name);
+	      return FAILURE;
+	    }
+	}
+    }
+
   if (dt->extra_comma
       && gfc_notify_std (GFC_STD_GNU, "Extension: Comma before i/o "
 			 "item list at %L", &dt->extra_comma->where) == FAILURE)
@@ -2854,6 +2908,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
 		 &dt->format_label->where);
       return FAILURE;
     }
+
   return SUCCESS;
 }
 
@@ -3012,50 +3067,8 @@ match_io_element (io_kind k, gfc_code **
 		   io_kind_name (k));
     }
 
-  if (m == MATCH_YES)
-    switch (k)
-      {
-      case M_READ:
-	if (expr->symtree->n.sym->attr.intent == INTENT_IN)
-	  {
-	    gfc_error ("Variable '%s' in input list at %C cannot be "
-		       "INTENT(IN)", expr->symtree->n.sym->name);
-	    m = MATCH_ERROR;
-	  }
-
-	if (gfc_pure (NULL)
-	    && gfc_impure_variable (expr->symtree->n.sym)
-	    && current_dt->io_unit
-	    && current_dt->io_unit->ts.type == BT_CHARACTER)
-	  {
-	    gfc_error ("Cannot read to variable '%s' in PURE procedure at %C",
-		       expr->symtree->n.sym->name);
-	    m = MATCH_ERROR;
-	  }
-
-	if (gfc_check_do_variable (expr->symtree))
-	  m = MATCH_ERROR;
-
-	break;
-
-      case M_WRITE:
-	if (current_dt->io_unit
-	    && current_dt->io_unit->ts.type == BT_CHARACTER
-	    && gfc_pure (NULL)
-	    && current_dt->io_unit->expr_type == EXPR_VARIABLE
-	    && gfc_impure_variable (current_dt->io_unit->symtree->n.sym))
-	  {
-	    gfc_error ("Cannot write to internal file unit '%s' at %C "
-		       "inside a PURE procedure",
-		       current_dt->io_unit->symtree->n.sym->name);
-	    m = MATCH_ERROR;
-	  }
-
-	break;
-
-      default:
-	break;
-      }
+  if (m == MATCH_YES && k == M_READ && gfc_check_do_variable (expr->symtree))
+    m = MATCH_ERROR;
 
   if (m != MATCH_YES)
     {
@@ -3066,6 +3079,7 @@ match_io_element (io_kind k, gfc_code **
   cp = gfc_get_code ();
   cp->op = EXEC_TRANSFER;
   cp->expr1 = expr;
+  cp->ext.dt = current_dt;
 
   *cpp = cp;
   return MATCH_YES;
@@ -3657,14 +3671,14 @@ get_io_list:
   /* Used in check_io_constraints, where no locus is available.  */
   spec_end = gfc_current_locus;
 
+  /* Save the IO kind for later use.  */
+  dt->dt_io_kind = gfc_get_iokind_expr (&gfc_current_locus, k);
+
   /* Optional leading comma (non-standard).  We use a gfc_expr structure here
      to save the locus.  This is used later when resolving transfer statements
      that might have a format expression without unit number.  */
   if (!comma_flag && gfc_match_char (',') == MATCH_YES)
-    {
-      /* Save the iokind and locus for later use in resolution.  */
-      dt->extra_comma = gfc_get_iokind_expr (&gfc_current_locus, k);
-    }
+    dt->extra_comma = dt->dt_io_kind;
 
   io_code = NULL;
   if (gfc_match_eos () != MATCH_YES)
@@ -3973,41 +3987,54 @@ gfc_resolve_inquire (gfc_inquire *inquir
 {
   RESOLVE_TAG (&tag_unit, inquire->unit);
   RESOLVE_TAG (&tag_file, inquire->file);
-  RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
-  RESOLVE_TAG (&tag_iostat, inquire->iostat);
-  RESOLVE_TAG (&tag_exist, inquire->exist);
-  RESOLVE_TAG (&tag_opened, inquire->opened);
-  RESOLVE_TAG (&tag_number, inquire->number);
-  RESOLVE_TAG (&tag_named, inquire->named);
-  RESOLVE_TAG (&tag_name, inquire->name);
-  RESOLVE_TAG (&tag_s_access, inquire->access);
-  RESOLVE_TAG (&tag_sequential, inquire->sequential);
-  RESOLVE_TAG (&tag_direct, inquire->direct);
-  RESOLVE_TAG (&tag_s_form, inquire->form);
-  RESOLVE_TAG (&tag_formatted, inquire->formatted);
-  RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
-  RESOLVE_TAG (&tag_s_recl, inquire->recl);
-  RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
-  RESOLVE_TAG (&tag_s_blank, inquire->blank);
-  RESOLVE_TAG (&tag_s_position, inquire->position);
-  RESOLVE_TAG (&tag_s_action, inquire->action);
-  RESOLVE_TAG (&tag_read, inquire->read);
-  RESOLVE_TAG (&tag_write, inquire->write);
-  RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
-  RESOLVE_TAG (&tag_s_delim, inquire->delim);
-  RESOLVE_TAG (&tag_s_pad, inquire->pad);
-  RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
-  RESOLVE_TAG (&tag_s_round, inquire->round);
-  RESOLVE_TAG (&tag_iolength, inquire->iolength);
-  RESOLVE_TAG (&tag_convert, inquire->convert);
-  RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
-  RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
-  RESOLVE_TAG (&tag_s_sign, inquire->sign);
-  RESOLVE_TAG (&tag_s_round, inquire->round);
-  RESOLVE_TAG (&tag_pending, inquire->pending);
-  RESOLVE_TAG (&tag_size, inquire->size);
   RESOLVE_TAG (&tag_id, inquire->id);
 
+  /* For INQUIRE, all tags except FILE, ID and UNIT are variable definition
+     contexts.  Thus, use an extended RESOLVE_TAG macro for that.  */
+#define INQUIRE_RESOLVE_TAG(tag, expr) \
+  RESOLVE_TAG (tag, expr); \
+  if (expr) \
+    { \
+      char context[64]; \
+      sprintf (context, _("%s tag with INQUIRE"), (tag)->name); \
+      if (gfc_check_vardef_context ((expr), false, context) == FAILURE) \
+	return FAILURE; \
+    }
+  INQUIRE_RESOLVE_TAG (&tag_iomsg, inquire->iomsg);
+  INQUIRE_RESOLVE_TAG (&tag_iostat, inquire->iostat);
+  INQUIRE_RESOLVE_TAG (&tag_exist, inquire->exist);
+  INQUIRE_RESOLVE_TAG (&tag_opened, inquire->opened);
+  INQUIRE_RESOLVE_TAG (&tag_number, inquire->number);
+  INQUIRE_RESOLVE_TAG (&tag_named, inquire->named);
+  INQUIRE_RESOLVE_TAG (&tag_name, inquire->name);
+  INQUIRE_RESOLVE_TAG (&tag_s_access, inquire->access);
+  INQUIRE_RESOLVE_TAG (&tag_sequential, inquire->sequential);
+  INQUIRE_RESOLVE_TAG (&tag_direct, inquire->direct);
+  INQUIRE_RESOLVE_TAG (&tag_s_form, inquire->form);
+  INQUIRE_RESOLVE_TAG (&tag_formatted, inquire->formatted);
+  INQUIRE_RESOLVE_TAG (&tag_unformatted, inquire->unformatted);
+  INQUIRE_RESOLVE_TAG (&tag_s_recl, inquire->recl);
+  INQUIRE_RESOLVE_TAG (&tag_nextrec, inquire->nextrec);
+  INQUIRE_RESOLVE_TAG (&tag_s_blank, inquire->blank);
+  INQUIRE_RESOLVE_TAG (&tag_s_position, inquire->position);
+  INQUIRE_RESOLVE_TAG (&tag_s_action, inquire->action);
+  INQUIRE_RESOLVE_TAG (&tag_read, inquire->read);
+  INQUIRE_RESOLVE_TAG (&tag_write, inquire->write);
+  INQUIRE_RESOLVE_TAG (&tag_readwrite, inquire->readwrite);
+  INQUIRE_RESOLVE_TAG (&tag_s_delim, inquire->delim);
+  INQUIRE_RESOLVE_TAG (&tag_s_pad, inquire->pad);
+  INQUIRE_RESOLVE_TAG (&tag_s_encoding, inquire->encoding);
+  INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
+  INQUIRE_RESOLVE_TAG (&tag_iolength, inquire->iolength);
+  INQUIRE_RESOLVE_TAG (&tag_convert, inquire->convert);
+  INQUIRE_RESOLVE_TAG (&tag_strm_out, inquire->strm_pos);
+  INQUIRE_RESOLVE_TAG (&tag_s_async, inquire->asynchronous);
+  INQUIRE_RESOLVE_TAG (&tag_s_sign, inquire->sign);
+  INQUIRE_RESOLVE_TAG (&tag_s_round, inquire->round);
+  INQUIRE_RESOLVE_TAG (&tag_pending, inquire->pending);
+  INQUIRE_RESOLVE_TAG (&tag_size, inquire->size);
+#undef INQUIRE_RESOLVE_TAG
+
   if (gfc_reference_st_label (inquire->err, ST_LABEL_TARGET) == FAILURE)
     return FAILURE;
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 164550)
+++ gcc/fortran/resolve.c	(working copy)
@@ -7916,6 +7916,11 @@ resolve_transfer (gfc_code *code)
 		      && exp->expr_type != EXPR_FUNCTION))
     return;
 
+  /* If we are reading, the variable will be changed.  */
+  if (code->ext.dt->dt_io_kind->value.iokind == M_READ
+      && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
+    return;
+
   sym = exp->symtree->n.sym;
   ts = &sym->ts;
 
Index: gcc/testsuite/gfortran.dg/io_constraints_7.f03
===================================================================
--- gcc/testsuite/gfortran.dg/io_constraints_7.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/io_constraints_7.f03	(revision 0)
@@ -0,0 +1,37 @@
+! { dg-do compile }
+
+! PR fortran/45776
+! Variable definition context checks related to IO.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+module m
+  implicit none
+  integer, protected :: a
+  character(len=128), protected :: msg
+end module m
+
+program main
+  use :: m
+  integer :: x
+  logical :: bool
+
+  write (*, iostat=a) 42 ! { dg-error "variable definition context" }
+  write (*, iomsg=msg) 42 ! { dg-error "variable definition context" }
+  read (*, '(I2)', advance='no', size=a) x ! { dg-error "variable definition context" }
+
+  ! These are ok.
+  inquire (unit=a)
+  inquire (file=msg, id=a, pending=bool)
+  inquire (file=msg)
+
+  ! These not, but list is not extensive.
+  inquire (unit=1, number=a) ! { dg-error "variable definition context" }
+  inquire (unit=1, encoding=msg) ! { dg-error "variable definition context" }
+  inquire (unit=1, formatted=msg) ! { dg-error "variable definition context" }
+
+  open (newunit=a, file="foo") ! { dg-error "variable definition context" }
+  close (unit=a)
+end program main
+
+! { dg-final { cleanup-modules "m" } }
Index: gcc/testsuite/gfortran.dg/newunit_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/newunit_2.f90	(revision 0)
+++ gcc/testsuite/gfortran.dg/newunit_2.f90	(revision 0)
@@ -0,0 +1,15 @@
+! { dg-do compile }
+! { dg-options "-std=f95" }
+
+! PR40008 F2008: Add NEWUNIT= for OPEN statement 
+! Check for rejection with pre-F2008 standard.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+program main
+  character(len=25) :: str
+  integer(1) :: myunit
+
+  open (newunit=myunit, file="some_file") ! { dg-error "Fortran 2008" }
+  close (unit=myunit)
+end program main
Index: gcc/testsuite/gfortran.dg/io_constraints_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/io_constraints_6.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/io_constraints_6.f03	(revision 0)
@@ -0,0 +1,40 @@
+! { dg-do compile }
+
+! PR fortran/45776
+! Variable definition context checks related to IO.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+module m
+  implicit none
+
+  integer, protected :: a
+  character(len=128), protected :: str
+end module m
+
+program main
+  use :: m
+  integer, parameter :: b = 42
+  integer :: x
+  character(len=128) :: myStr
+
+  namelist /definable/ x, myStr
+  namelist /undefinable/ x, a
+
+  ! These are invalid.
+  read (myStr, *) a ! { dg-error "variable definition context" }
+  read (myStr, *) x, b ! { dg-error "variable definition context" }
+  write (str, *) 5 ! { dg-error "variable definition context" }
+  read (*, nml=undefinable) ! { dg-error "contains the symbol 'a' which may not" }
+
+  ! These are ok.
+  read (str, *) x
+  write (myStr, *) a
+  write (myStr, *) b
+  print *, a, b
+  write (*, nml=undefinable)
+  read (*, nml=definable)
+  write (*, nml=definable)
+end program main
+
+! { dg-final { cleanup-modules "m" } }