This is the mail archive of the fortran@gcc.gnu.org mailing list for the GNU Fortran project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

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


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?

Thanks,
Daniel

--
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_code): New ext.transfer_io_kind.
	(gfc_resolve_dt): Add new argument gfc_exec_op op.
	* io.c (resolve_tag): F2008 check for NEWUNIT and variable
	definition checks for NEWUNIT, IOSTAT, SIZE and IOMSG.
	(gfc_resolve_dt): New argument op and check variable definitions.
	(match_io_element): Remove INTENT and PURE checks here and
	initialize new gfc_code->ext.transfer_io_kind member.
	(gfc_resolve_inquire): Check variable definition for all tags
	except UNIT, FILE and ID.
	* resolve.c (resolve_transfer): Variable definition check.
	(resolve_code): Pass op argument to gfc_resolve_dt.

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)
@@ -2111,6 +2111,13 @@ typedef struct gfc_code
     gfc_inquire *inquire;
     gfc_wait *wait;
     gfc_dt *dt;
+
+    /* For transfer, store whether this is reading or writing.  */
+    /* XXX: Can we in some other way determine in resolve_transfer whether
+       we are reading or writing?  Possibly via global variables, but that
+       does not feel right.  */
+    io_kind transfer_io_kind;
+
     gfc_forall_iterator *forall_iterator;
     struct gfc_code *which_construct;
     int stop_code;
@@ -2827,7 +2834,7 @@ gfc_try gfc_resolve_filepos (gfc_filepos
 void gfc_free_inquire (gfc_inquire *);
 gfc_try gfc_resolve_inquire (gfc_inquire *);
 void gfc_free_dt (gfc_dt *);
-gfc_try gfc_resolve_dt (gfc_dt *, locus *);
+gfc_try gfc_resolve_dt (gfc_dt *, locus *, gfc_exec_op);
 void gfc_free_wait (gfc_wait *);
 gfc_try gfc_resolve_wait (gfc_wait *);
 
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;
 }
 
@@ -2716,10 +2734,16 @@ gfc_free_dt (gfc_dt *dt)
 /* Resolve everything in a gfc_dt structure.  */
 
 gfc_try
-gfc_resolve_dt (gfc_dt *dt, locus *loc)
+gfc_resolve_dt (gfc_dt *dt, locus *loc, gfc_exec_op op)
 {
   gfc_expr *e;
 
+  /* XXX: Is there a way to get whether we are READing or WRITing without
+     this new extra argument?  Note that below there is code doing something
+     like that based on extra_comma, but it does not really look like
+     a general method to me.  What if extra_comma is not present?  */
+  gcc_assert (op == EXEC_READ || op == EXEC_WRITE);
+
   RESOLVE_TAG (&tag_format, dt->format_expr);
   RESOLVE_TAG (&tag_rec, dt->rec);
   RESOLVE_TAG (&tag_spos, dt->pos);
@@ -2790,6 +2814,12 @@ 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.  */
+      if (op == EXEC_WRITE
+	  && gfc_check_vardef_context (e, false, _("internal unit in WRITE"))
+	       == FAILURE)
+	return FAILURE;
     }
 
   if (e->rank && e->ts.type != BT_CHARACTER)
@@ -2801,10 +2831,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 (op == EXEC_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 +2910,7 @@ gfc_resolve_dt (gfc_dt *dt, locus *loc)
 		 &dt->format_label->where);
       return FAILURE;
     }
+
   return SUCCESS;
 }
 
@@ -3012,50 +3069,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 +3081,7 @@ match_io_element (io_kind k, gfc_code **
   cp = gfc_get_code ();
   cp->op = EXEC_TRANSFER;
   cp->expr1 = expr;
+  cp->ext.transfer_io_kind = k;
 
   *cpp = cp;
   return MATCH_YES;
@@ -3973,41 +3989,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.transfer_io_kind == M_READ
+      && gfc_check_vardef_context (exp, false, _("item in READ")) == FAILURE)
+    return;
+
   sym = exp->symtree->n.sym;
   ts = &sym->ts;
 
@@ -9059,7 +9064,7 @@ resolve_code (gfc_code *code, gfc_namesp
 
 	case EXEC_READ:
 	case EXEC_WRITE:
-	  if (gfc_resolve_dt (code->ext.dt, &code->loc) == FAILURE)
+	  if (gfc_resolve_dt (code->ext.dt, &code->loc, code->op) == FAILURE)
 	    break;
 
 	  resolve_branch (code->ext.dt->err, code);
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" } }

Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]