Patchwork [Fortran] Add parsing support for assumed-rank array

login
register
mail settings
Submitter Mikael Morin
Date July 19, 2012, 3:55 p.m.
Message ID <50082DF9.1020202@sfr.fr>
Download mbox | patch
Permalink /patch/171968/
State New
Headers show

Comments

Mikael Morin - July 19, 2012, 3:55 p.m.
On 15/07/2012 21:13, Tobias Burnus wrote:
> Hello,
> 
> attached is an updated version of the patch. Changes:
> 
Updated version of comments:



> diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
> index c3644b6..959a57b 100644
> --- a/gcc/fortran/decl.c
> +++ b/gcc/fortran/decl.c
> @@ -594,7 +594,7 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
>  {
>    int i;
>  
> -  if (to->rank == 0 && from->rank > 0)
> +  if (to->rank == 0 && from->rank != 0)
>      {
>        to->rank = from->rank;
>        to->type = from->type;
I'm not sure it is relevant to support assumed rank here, as it is
mutually exclusive with codimensions.
If it is, I think there may be a problem as we are using from->rank to
index lower and upper bounds, which is bogus if from->rank == -1.
Maybe add:
gcc_assert (from->rank != -1 || to->corank == 0);

> @@ -622,20 +622,24 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
>      }
>    else if (to->corank == 0 && from->corank > 0)
>      {
> +      int rank;
> +
>        to->corank = from->corank;
>        to->cotype = from->cotype;
>  
> +      rank = to->rank == -1 ? 0 : to->rank;
> +
>        for (i = 0; i < from->corank; i++)
>  	{
>  	  if (copy)
>  	    {
> -	      to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
> -	      to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
> +	      to->lower[rank + i] = gfc_copy_expr (from->lower[i]);
> +	      to->upper[rank + i] = gfc_copy_expr (from->upper[i]);
>  	    }
>  	  else
>  	    {
> -	      to->lower[to->rank + i] = from->lower[i];
> -	      to->upper[to->rank + i] = from->upper[i];
> +	      to->lower[rank + i] = from->lower[i];
> +	      to->upper[rank + i] = from->upper[i];
>  	    }
>  	}
>      }

Access to lower and upper bounds is OK, but again maybe we could
just assert here.



> diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
> index 6f40ba7..64efbcb 100644
> --- a/gcc/fortran/interface.c
> +++ b/gcc/fortran/interface.c
> @@ -1743,7 +1752,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
>      }
>  
>    /* F2008, 12.5.2.5; IR F08/0073.  */
> -  if (formal->ts.type == BT_CLASS
> +  if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
>        && ((CLASS_DATA (formal)->attr.class_pointer
>  	   && !formal->attr.intent == INTENT_IN)
>            || CLASS_DATA (formal)->attr.allocatable))
About this hunk, ...

> @@ -2289,11 +2299,21 @@ compare_actual_formal (gfc_actual_arglist **ap, gfc_formal_arglist *formal,
>  	  return 0;
>  	}
>  
> -      if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
> -	  && (f->sym->attr.allocatable || !f->sym->attr.optional
> -	      || (gfc_option.allow_std & GFC_STD_F2008) == 0))
> -	{
> -	  if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
> +      if (a->expr->expr_type == EXPR_NULL
> +	  && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
> +	       && (f->sym->attr.allocatable || !f->sym->attr.optional
> +		   || (gfc_option.allow_std & GFC_STD_F2008) == 0))
> +	      || (f->sym->ts.type == BT_CLASS
> +		  && !CLASS_DATA (f->sym)->attr.class_pointer
> +		  && (CLASS_DATA (f->sym)->attr.allocatable
> +		      || !f->sym->attr.optional
> +		      || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
> +	{
> +	  if (where
> +	      && (!f->sym->attr.optional
> +		  || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
> +		  || (f->sym->ts.type == BT_CLASS
> +			 && CLASS_DATA (f->sym)->attr.allocatable)))
>  	    gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
>  		       where, f->sym->name);
>  	  else if (where)
... this hunk, ...

> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> index 5be1857..3534e63 100644
> --- a/gcc/fortran/resolve.c
> +++ b/gcc/fortran/resolve.c

> @@ -284,23 +286,34 @@ resolve_formal_arglist (gfc_symbol *proc)
>  	    gfc_set_default_type (sym, 1, sym->ns);
>  	}
>  
> -      gfc_resolve_array_spec (sym->as, 0);
> +      as = sym->ts.type == BT_CLASS && sym->attr.class_ok
> +	   ? CLASS_DATA (sym)->as : sym->as;
> +
> +      gfc_resolve_array_spec (as, 0);
>  
>        /* We can't tell if an array with dimension (:) is assumed or deferred
>  	 shape until we know if it has the pointer or allocatable attributes.
>        */
> -      if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
> -	  && !(sym->attr.pointer || sym->attr.allocatable)
> +      if (as && as->rank > 0 && as->type == AS_DEFERRED
> +	  && ((sym->ts.type != BT_CLASS
> +	       && !(sym->attr.pointer || sym->attr.allocatable))
> +              || (sym->ts.type == BT_CLASS
> +		  && !(CLASS_DATA (sym)->attr.class_pointer
> +		       || CLASS_DATA (sym)->attr.allocatable)))
>  	  && sym->attr.flavor != FL_PROCEDURE)
>  	{
> -	  sym->as->type = AS_ASSUMED_SHAPE;
> -	  for (i = 0; i < sym->as->rank; i++)
> -	    sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
> -						  NULL, 1);
> +	  as->type = AS_ASSUMED_SHAPE;
> +	  for (i = 0; i < as->rank; i++)
> +	    as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
>  	}
>  
> -      if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
> +      if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
> +	  || (as && as->type == AS_ASSUMED_RANK)
>  	  || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
> +	  || (sym->ts.type == BT_CLASS && sym->attr.class_ok
> +	      && (CLASS_DATA (sym)->attr.class_pointer
> +		  || CLASS_DATA (sym)->attr.allocatable
> +		  || CLASS_DATA (sym)->attr.target))
>  	  || sym->attr.optional)
>  	{
>  	  proc->attr.always_explicit = 1;
... this hunk with the AS_ASSUMED_RANK line removed, ...

> diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> index 34e0f69..7ec40b1 100644
> --- a/gcc/fortran/trans-expr.c
> +++ b/gcc/fortran/trans-expr.c
> @@ -3620,10 +3741,15 @@ gfc_conv_procedure_call (gfc_se * se,
gfc_symbol * sym,
>  		parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
>  	    }
>  	}
> -      else if (arg->expr->expr_type == EXPR_NULL && fsym && !fsym->attr.pointer)
> +      else if (arg->expr->expr_type == EXPR_NULL
> +	       && fsym && !fsym->attr.pointer
> +	       && (fsym->ts.type != BT_CLASS
> +		   || !CLASS_DATA (fsym)->attr.class_pointer))
>  	{
>  	  /* Pass a NULL pointer to denote an absent arg.  */
> -	  gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
> +	  gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
> +		      && (fsym->ts.type != BT_CLASS
> +			  || !CLASS_DATA (fsym)->attr.allocatable));
>  	  gfc_init_se (&parmse, NULL);
>  	  parmse.expr = null_pointer_node;
>  	  if (arg->missing_arg_type == BT_CHARACTER)
... and this hunk:

The four of them are not directly related to the assumed rank stuff, and
thus deserve a separate commit.
As you said:
> * Unrelated bug fixes, found when writing the test cases and thus
included:
I assume they don't need testcases of their own, so that they are
approved as is.



> @@ -10332,10 +10408,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int mp_flag)
>  	    return FAILURE;
>  	}
>  
> -      if (pointer && dimension)
> +      if (pointer && dimension && as->type != AS_ASSUMED_RANK)
>  	{
> -	  gfc_error ("Array pointer '%s' at %L must have a deferred shape",
> -		     sym->name, &sym->declared_at);
> +	  gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
> +		     "deferred rank", sym->name, &sym->declared_at);
>  	  return FAILURE;
>  	}
>      }
s/deferred rank/assumed rank/ ?




> diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> index 34e0f69..7ec40b1 100644
> --- a/gcc/fortran/trans-expr.c
> +++ b/gcc/fortran/trans-expr.c
> @@ -3808,7 +3936,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
>  		      gfc_add_expr_to_block (&se->pre, tmp);
>  		    }
>  
> -		  if (fsym && e->expr_type != EXPR_NULL
> +		  /* Wrap scalar variable in a descriptor. We need to convert
> +		     the address of a pointer back to the pointer itself before,
> +		     we can assign it to the data field.  */
> +		     
> +		  if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
> +		      && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
> +		    {
> +		      tmp = parmse.expr;
> +		      if (TREE_CODE (tmp) == ADDR_EXPR
> +			  && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
This looks fragile. If you have {tmp = &ptr; value = tmp;} instead of
{value = &ptr;} it doesn't work anymore.
You can rely on fsym->attr.{pointer,allocatable,...) instead, or can't you?

> +			tmp = TREE_OPERAND (tmp, 0);
> +		      parmse.expr = conv_scalar_to_descriptor (se, tmp,
> +							       fsym->attr);
> +		      parmse.expr = gfc_build_addr_expr (NULL_TREE,
> +							 parmse.expr);
> +		    }
> +		  else if (fsym && e->expr_type != EXPR_NULL
>  		      && ((fsym->attr.pointer
>  			   && fsym->attr.flavor != FL_PROCEDURE)
>  			  || (fsym->attr.proc_pointer


Now about:

> Mikael Morin wrote:
>> What about naming the flag in_actual_arg and moving the
>> inquiry_argument condition to the error condition?
>
> That doesn't work as it is not only valid as inquiry argument but also
> for other actual arguments – those which have an assumed-type or
> assumed-rank dummy argument.
>
I didn't mean changing the semantics.
This assumed_type_rank_allowed flag is cleared in a function, set in
another, and used in a third, which makes it difficult to understand
what it does (the name, initially OK, doesn't help when assumed rank
gets in the mix). I was proposing using some flags (as I don't see how
to do without) with more trivial meaning, and get to the same result by
assembling them.
I attach a patch showing what I had in mind. I think it is equivalent;
it passes your assumed rank testcases at least. As a cherry on the cake,
it brings a small diagnostic improvement regarding assumed type/rank and
inquiry functions. Let's hope you like the wording.
As second attachment, there is a patch restoring the flags in case of
failure, as that was making me uncomfortable.

I'm regression testing them, and if they work and are fine to you, let's
go with these patches.


Regarding the assumed rank patch, it is in pretty good shape. I think
modulo the few nits outlined above, it is ready to go in.

Mikael
Tobias Burnus - July 19, 2012, 9:36 p.m.
Am 19.07.2012 17:55, schrieb Mikael Morin:
> Maybe add: gcc_assert (from->rank != -1 || to->corank == 0); 
> Access to lower and upper bounds is OK, but again maybe we could just 
> assert here. 

I will add the asserts – and undo the patch.

> s/deferred rank/assumed rank/ ? 

Of course. Well spotted!

>> -		  if (fsym && e->expr_type != EXPR_NULL
>> +		  /* Wrap scalar variable in a descriptor. We need to convert
>> +		     the address of a pointer back to the pointer itself before,
>> +		     we can assign it to the data field.  */
>> +		
>> +		  if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
>> +		      && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
>> +		    {
>> +		      tmp = parmse.expr;
>> +		      if (TREE_CODE (tmp) == ADDR_EXPR
>> +			  && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
> This looks fragile. If you have {tmp = &ptr; value = tmp;} instead of
> {value = &ptr;} it doesn't work anymore.
> You can rely on fsym->attr.{pointer,allocatable,...) instead, or can't you?

No, I cannot if I use "if (attr.pointer)" I exactly run into the problem 
I want to avoid: Taking the address of the temporary variable, which I 
don't want. (Well, actually via TREE_OPERAND, I won't: I get an ICE.)

However, with the current code, I get:

     D.1874 = f ();
     desc.0.dtype = 600;
     desc.0.data = (void *) D.1874;
     sub (&desc.0);
     D.1874 = (integer(kind=4) *) desc.0.data;

which looks fine.

Thus, I intent to keep my version.

>> Mikael Morin wrote:
>>> What about naming the flag in_actual_arg and moving the
>>> inquiry_argument condition to the error condition?
> I didn't mean changing the semantics.
>
> I attach a patch showing what I had in mind. I think it is equivalent;
> it passes your assumed rank testcases at least. As a cherry on the cake,
> it brings a small diagnostic improvement regarding assumed type/rank and
> inquiry functions. Let's hope you like the wording.
> As second attachment, there is a patch restoring the flags in case of
> failure, as that was making me uncomfortable.
>
> I'm regression testing them, and if they work and are fine to you, let's
> go with these patches.

I will now regtest everything, read through the whole patch – your part 
and mine, update the ChangeLog and commit it tomorrow.

Thanks for the review!

Tobias

Patch

diff --git a/resolve.c b/resolve.c
index ccaa098..76a1e2c 100644
--- a/resolve.c
+++ b/resolve.c
@@ -1618,6 +1618,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
   gfc_symtree *parent_st;
   gfc_expr *e;
   int save_need_full_assumed_size;
+  gfc_try return_value = FAILURE;
   bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
 
   actual_arg = true;
@@ -1635,7 +1636,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("Label %d referenced at %L is never defined",
 			     arg->label->value, &arg->label->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	    }
 	  first_actual_arg = false;
@@ -1646,7 +1647,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	    && e->symtree->n.sym->attr.generic
 	    && no_formal_args
 	    && count_specific_procs (e) != 1)
-	return FAILURE;
+	goto cleanup;
 
       if (e->ts.type != BT_PROCEDURE)
 	{
@@ -1654,7 +1655,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  if (e->expr_type != EXPR_VARIABLE)
 	    need_full_assumed_size = 0;
 	  if (gfc_resolve_expr (e) != SUCCESS)
-	    return FAILURE;
+	    goto cleanup;
 	  need_full_assumed_size = save_need_full_assumed_size;
 	  goto argument_list;
 	}
@@ -1698,7 +1699,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 				  "Fortran 2008: Internal procedure '%s' is"
 				  " used as actual argument at %L",
 				  sym->name, &e->where) == FAILURE)
-		return FAILURE;
+		goto cleanup;
 	    }
 
 	  if (sym->attr.elemental && !sym->attr.intrinsic)
@@ -1711,8 +1712,8 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  /* Check if a generic interface has a specific procedure
 	    with the same name before emitting an error.  */
 	  if (sym->attr.generic && count_specific_procs (e) != 1)
-	    return FAILURE;
-	  
+	    goto cleanup;
+
 	  /* Just in case a specific was found for the expression.  */
 	  sym = e->symtree->n.sym;
 
@@ -1733,7 +1734,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		  gfc_error ("Unable to find a specific INTRINSIC procedure "
 			     "for the reference '%s' at %L", sym->name,
 			     &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	      sym->ts = isym->ts;
 	      sym->attr.intrinsic = 1;
@@ -1741,7 +1742,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	    }
 
 	  if (gfc_resolve_expr (e) == FAILURE)
-	    return FAILURE;
+	    goto cleanup;
 	  goto argument_list;
 	}
 
@@ -1753,7 +1754,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
       if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
 	{
 	  gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
-	  return FAILURE;
+	  goto cleanup;
 	}
 
       if (parent_st == NULL)
@@ -1767,7 +1768,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 	  || sym->attr.external)
 	{
 	  if (gfc_resolve_expr (e) == FAILURE)
-	    return FAILURE;
+	    goto cleanup;
 	  goto argument_list;
 	}
 
@@ -1795,7 +1796,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
       if (e->expr_type != EXPR_VARIABLE)
 	need_full_assumed_size = 0;
       if (gfc_resolve_expr (e) != SUCCESS)
-	return FAILURE;
+	goto cleanup;
       need_full_assumed_size = save_need_full_assumed_size;
 
     argument_list:
@@ -1809,14 +1810,14 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("By-value argument at %L is not of numeric "
 			     "type", &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 
 	      if (e->rank)
 		{
 		  gfc_error ("By-value argument at %L cannot be an array or "
 			     "an array section", &e->where);
-		return FAILURE;
+		  goto cleanup;
 		}
 
 	      /* Intrinsics are still PROC_UNKNOWN here.  However,
@@ -1830,7 +1831,7 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("By-value argument at %L is not allowed "
 			     "in this context", &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	    }
 
@@ -1842,26 +1843,30 @@  resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
 		{
 		  gfc_error ("Passing internal procedure at %L by location "
 			     "not allowed", &e->where);
-		  return FAILURE;
+		  goto cleanup;
 		}
 	    }
 	}
 
       /* Fortran 2008, C1237.  */
       if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
-          && gfc_has_ultimate_pointer (e))
-        {
-          gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+	  && gfc_has_ultimate_pointer (e))
+	{
+	  gfc_error ("Coindexed actual argument at %L with ultimate pointer "
 		     "component", &e->where);
-          return FAILURE;
-        }
+	  goto cleanup;
+	}
 
       first_actual_arg = false;
     }
+
+  return_value = SUCCESS;
+
+cleanup:
   actual_arg = actual_arg_sav;
   first_actual_arg = first_actual_arg_sav;
 
-  return SUCCESS;
+  return return_value;
 }