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

login
register
mail settings
Submitter Daniel Kraft
Date Sept. 25, 2010, 8:43 a.m.
Message ID <4C9DB631.9050208@domob.eu>
Download mbox | patch
Permalink /patch/65738/
State New
Headers show

Comments

Daniel Kraft - Sept. 25, 2010, 8:43 a.m.
And another update.  The last patch segfaulted for INQUIRE with 
transfers, because in this case code->ext.dt was NULL.  I added a check 
for that, since this is also not "reading".  Changed is only the 
resolve_transfer part (and I regard the change as trivial).

Starting a new regtest now ;)  Ok if successful?

Yours,
Daniel

Daniel Kraft wrote:
> 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?
> 
>
Daniel Kraft - Sept. 25, 2010, 9:42 a.m.
Daniel Kraft wrote:
> And another update.  The last patch segfaulted for INQUIRE with 
> transfers, because in this case code->ext.dt was NULL.  I added a check 
> for that, since this is also not "reading".  Changed is only the 
> resolve_transfer part (and I regard the change as trivial).
> 
> Starting a new regtest now ;)  Ok if successful?

No failures this time on x86_64-unknown-linux-gnu.

> 
> Yours,
> Daniel
> 
> Daniel Kraft wrote:
>> 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?
>>
>>
> 
>
Jerry DeLisle - Sept. 25, 2010, 2:20 p.m.
On 09/25/2010 02:42 AM, Daniel Kraft wrote:
> Daniel Kraft wrote:
>> And another update. The last patch segfaulted for INQUIRE with transfers,
>> because in this case code->ext.dt was NULL. I added a check for that, since
>> this is also not "reading". Changed is only the resolve_transfer part (and I
>> regard the change as trivial).
>>
>> Starting a new regtest now ;) Ok if successful?
>
> No failures this time on x86_64-unknown-linux-gnu.
>

OK, thanks for patch!

Jerry
Daniel Kraft - Sept. 25, 2010, 2:34 p.m.
Jerry DeLisle wrote:
> On 09/25/2010 02:42 AM, Daniel Kraft wrote:
>> Daniel Kraft wrote:
>>> And another update. The last patch segfaulted for INQUIRE with 
>>> transfers,
>>> because in this case code->ext.dt was NULL. I added a check for that, 
>>> since
>>> this is also not "reading". Changed is only the resolve_transfer part 
>>> (and I
>>> regard the change as trivial).
>>>
>>> Starting a new regtest now ;) Ok if successful?
>>
>> No failures this time on x86_64-unknown-linux-gnu.
>>
> 
> OK, thanks for patch!

Committed revision 164619.

Thanks for the review and suggestions!  For the PR / full checks we now 
only miss (AFAIK) the checks related to LOCK/UNLOCK, which obviously can 
only be implemented when those features are implemented.

My next plans are looking at ASSOCIATE plus derived-types.

Yours,
Daniel

Patch

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,13 @@  resolve_transfer (gfc_code *code)
 		      && exp->expr_type != EXPR_FUNCTION))
     return;
 
+  /* If we are reading, the variable will be changed.  Note that
+     code->ext.dt may be NULL if the TRANSFER is related to
+     an INQUIRE statement -- but in this case, we are not reading, either.  */
+  if (code->ext.dt && 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" } }