Re: [Patch, Fortran, 4.6] Coarray 6/n: Add expression support

[Tobias Burnus <burnus at net-b dot de>]

Daniel Kraft wrote:
>> here comes the next coarray patch, which finally brings support for
>> coarrays in expression.
>> OK for the 4.6 trunk?
>
> Yes, but as usual see some minor comments below:
>
> +              gcc_assert (ref->u.ar.as->corank > 0);
> +          if (init == NULL)
>
> It seems the indentation is messed up (or inconsistent tab vs spaces)
> as both lines should be at the same level.
Fixed.

> +      m = gfc_match_array_spec (&as, true, false);
> +          current_as->rank = as->rank;
> +          current_as->type = as->type;
> +          current_as->cray_pointee = as->cray_pointee;
> +          current_as->cp_was_assumed = as->cp_was_assumed;
> [...]

> Is there a way to merge this with the similar block just before it in
> the patch (i.e., share between variable_decl and match_attr_spec)?  If
> so I'd appreciate not duplicating the code (but of course there may
> not be an easy way).
Done - though it is not as beautify as hoped for.

> +  if (last && last->u.c.component->ts.type == BT_CLASS)
> +    return
> last->u.c.component->ts.u.derived->components->attr.alloc_comp;
> +  else if (last && last->u.c.component->ts.type == BT_DERIVED)
> +    return last->u.c.component->ts.u.derived->attr.alloc_comp;
>
> Seeing this -- although not related to your patch directly --, I think
> it may be a good idea to abstract attribute checks like there, no?  So
> that not everywhere it must be known how the CLASS dummy struct is
> organized and that there is a check on CLASS / not CLASS needed.
I agree - and defer it someone else ;-)

> Just below is another such block.
>
> +/* Check whether the expression has an pointer component.
> +   Being itself a pointer does not count.  */
> +bool
> +gfc_has_ultimate_pointer (gfc_expr *e)
>
> I'm not sure how practicable that is, but once again this with the
> ultimate-allocatable check seems like code duplication to me.
> Unfortunatly I see no easy way to "flexibly" pass to a common routine
> which struct field (pointer_comp or alloc_comp) to read.  Having
> lambda-expressions or closures would be handy here :)

I left it as is - despite the code duplication; at least the code is
rather small and readable.

> The line seems to be longer than 80 characters
Fixed.

> +  if (expr->value.function.isym && expr->value.function.isym->inquiry)
> +    inquiry_argument = true;
>    no_formal_args = sym && is_external_proc (sym) && sym->formal == NULL;
> +
>    if (resolve_actual_arglist (expr->value.function.actual,
>                    p, no_formal_args) == FAILURE)
>        return FAILURE;
>
> +  inquiry_argument = false;
>
> Why don't you have to save & restore the old value of inquiry_argument
> here?  And is it intended that the value may stay true if the return
> FAILURE; is done?

Second question: It was an oversight and thus I have corrected it.

To the first question: C617 only applies to data-refs (i.e. variables)
and thus it is not applicable for functions (such as nested functions).
I have now added a comment that inquiry_argument is only for variables.

> +    case DIMEN_STAR:
> +    /* Check only the lower bound as the upper one is '*'.  */
>
> Makes sense, but to me the following code looks as if *both* upper and
> lower bound are checked.
I have removed the comment. The bounds check deals with * (which is
simply expr == NULL) and indeed both bounds are checked.

> +          c = ref2 ? ref2->u.c.component :
> e->symtree->n.sym->components;
> +      for ( ; c; c = c->next)
> As above, seems to be some indentation or tabs inconsistency.
Fixed.

> +  int i, pointer, allocatable, dimension, check_intent_in, is_abstract,
> +      coindexed = false;
>
> Probably nit-picky, but if coindexed is int here (instead of bool), I
> think you should better use 0 instead of false (or maybe FALSE).
Better nitpick by the current trunk: Set but not used variable:
coindexed. Thus I have removed it.

> +        coindexed = coindexed ? true : ref->u.ar.codimen > 0;
> What about
> if (ref->u.ar.codimen > 0)
>   coindexed = true;
Better - but no longer used (see above).

> Line longer than 80 characters.
Fixed.

> BTW, I suppose you're going to add the -fcoarrays=none checks here
> afterwards or something like that?
I have now added a check.

Attached you find the interdiff.

Thanks a lot for the review!

Tobias

Sending        gcc/fortran/ChangeLog
Sending        gcc/fortran/array.c
Sending        gcc/fortran/data.c
Sending        gcc/fortran/decl.c
Sending        gcc/fortran/expr.c
Sending        gcc/fortran/gfortran.h
Sending        gcc/fortran/interface.c
Sending        gcc/fortran/match.c
Sending        gcc/fortran/match.h
Sending        gcc/fortran/primary.c
Sending        gcc/fortran/resolve.c
Sending        gcc/fortran/trans-array.c
Sending        gcc/fortran/trans-expr.c
Sending        gcc/testsuite/ChangeLog
Adding         gcc/testsuite/gfortran.dg/coarray_7.f90
Adding         gcc/testsuite/gfortran.dg/coarray_8.f90
Transmitting file data ................
Committed revision 158149.

diff --git a/gcc/fortran/array.c b/gcc/fortran/array.c
index d9ca043..5ceca4b 100644
--- a/gcc/fortran/array.c
+++ b/gcc/fortran/array.c
@@ -179,7 +179,7 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
     {
       m = match_subscript (ar, init, false);
       if (m == MATCH_ERROR)
-	goto error;
+	return MATCH_ERROR;
 
       if (gfc_match_char (')') == MATCH_YES)
 	{
@@ -190,57 +190,58 @@ gfc_match_array_ref (gfc_array_ref *ar, gfc_array_spec *as, int init,
       if (gfc_match_char (',') != MATCH_YES)
 	{
 	  gfc_error ("Invalid form of array reference at %C");
-	  goto error;
+	  return MATCH_ERROR;
 	}
     }
 
   gfc_error ("Array reference at %C cannot have more than %d dimensions",
 	     GFC_MAX_DIMENSIONS);
-  goto error;
+  return MATCH_ERROR;
 
 coarray:
   if (!matched_bracket && gfc_match_char ('[') != MATCH_YES)
     {
       if (ar->dimen > 0)
-        goto matched;
+	return MATCH_YES;
       else
-        goto error;
+	return MATCH_ERROR;
+    }
+
+  if (gfc_option.coarray == GFC_FCOARRAY_NONE)
+    {
+      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      return MATCH_ERROR;
     }
 
   if (corank == 0)
     {
 	gfc_error ("Unexpected coarray designator at %C");
-	goto error;
+	return MATCH_ERROR;
     }
 
   for (ar->codimen = 0; ar->codimen + ar->dimen < GFC_MAX_DIMENSIONS; ar->codimen++)
     {
       m = match_subscript (ar, init, ar->codimen == (corank - 1));
       if (m == MATCH_ERROR)
-	goto error;
+	return MATCH_ERROR;
 
       if (gfc_match_char (']') == MATCH_YES)
 	{
 	  ar->codimen++;
-	  goto matched;
+	  return MATCH_YES;
 	}
 
       if (gfc_match_char (',') != MATCH_YES)
 	{
 	  gfc_error ("Invalid form of coarray reference at %C");
-	  goto error;
+	  return MATCH_ERROR;
 	}
     }
 
   gfc_error ("Array reference at %C cannot have more than %d dimensions",
 	     GFC_MAX_DIMENSIONS);
-
-error:
   return MATCH_ERROR;
 
-matched:
-
-  return MATCH_YES;
 }
 
 
@@ -529,8 +530,8 @@ coarray:
 
   if (gfc_option.coarray == GFC_FCOARRAY_NONE)
     {
-       gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
-       goto cleanup;
+      gfc_error ("Coarrays disabled at %C, use -fcoarray= to enable");
+      goto cleanup;
     }
 
   for (;;)
diff --git a/gcc/fortran/data.c b/gcc/fortran/data.c
index 8c79bad..16cd899 100644
--- a/gcc/fortran/data.c
+++ b/gcc/fortran/data.c
@@ -291,7 +291,7 @@ gfc_assign_data_value (gfc_expr *lvalue, gfc_expr *rvalue, mpz_t index)
 	case REF_ARRAY:
 	  if (ref->u.ar.as->rank == 0)
 	    {
-              gcc_assert (ref->u.ar.as->corank > 0);
+	      gcc_assert (ref->u.ar.as->corank > 0);
 	      if (init == NULL)
 		gfc_free (expr);
 	      continue;
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index eda77ad..a9cd984 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -570,6 +570,62 @@ cleanup:
 
 /************************ Declaration statements *********************/
 
+
+/* Auxilliary function to merge DIMENSION and CODIMENSION array specs.  */
+
+static void
+merge_array_spec (gfc_array_spec *from, gfc_array_spec *to, bool copy)
+{
+  int i;
+
+  if (to->rank == 0 && from->rank > 0)
+    {
+      to->rank = from->rank;
+      to->type = from->type;
+      to->cray_pointee = from->cray_pointee;
+      to->cp_was_assumed = from->cp_was_assumed;
+
+      for (i = 0; i < to->corank; i++)
+	{
+	  to->lower[from->rank + i] = to->lower[i];
+	  to->upper[from->rank + i] = to->upper[i];
+	}
+      for (i = 0; i < from->rank; i++)
+	{
+	  if (copy)
+	    {
+	      to->lower[i] = gfc_copy_expr (from->lower[i]);
+	      to->upper[i] = gfc_copy_expr (from->upper[i]);
+	    }
+	  else
+	    {
+	      to->lower[i] = from->lower[i];
+	      to->upper[i] = from->upper[i];
+	    }
+	}
+    }
+  else if (to->corank == 0 && from->corank > 0)
+    {
+      to->corank = from->corank;
+      to->cotype = from->cotype;
+
+      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]);
+	    }
+	  else
+	    {
+	      to->lower[to->rank + i] = from->lower[i];
+	      to->upper[to->rank + i] = from->upper[i];
+	    }
+	}
+    }
+}
+
+
 /* Match an intent specification.  Since this can only happen after an
    INTENT word, a legal intent-spec must follow.  */
 
@@ -1603,36 +1659,8 @@ variable_decl (int elem)
 
   if (m == MATCH_NO)
     as = gfc_copy_array_spec (current_as);
-  else if (current_as && as->corank == 0 && current_as->corank > 0)
-    {
-      int i;
-      as->cotype = current_as->cotype;
-      as->corank = current_as->corank;
-      for (i = 0; i < current_as->corank; i++)
-	{
-	  as->lower[as->rank + i] = gfc_copy_expr (current_as->lower[i]);
-	  as->upper[as->rank + i] = gfc_copy_expr (current_as->upper[i]);
-	}
-    }
-  else if (current_as && as->rank == 0 && current_as->rank > 0)
-    {
-      int i;
-      as->rank = current_as->rank;
-      as->type = current_as->type;
-      as->cray_pointee = current_as->cray_pointee;
-      as->cp_was_assumed = current_as->cp_was_assumed;
-
-      for (i = 0; i < as->corank; i++)
-	{
-          as->lower[current_as->rank + i] = as->lower[i];
-          as->upper[current_as->rank + i] = as->upper[i];
-	}
-      for (i = 0; i < current_as->rank; i++)
-	{
-          as->lower[i] = gfc_copy_expr (current_as->lower[i]);
-          as->upper[i] = gfc_copy_expr (current_as->upper[i]);
-	}
-    }
+  else if (current_as)
+    merge_array_spec (current_as, as, true);
 
   char_len = NULL;
   cl = NULL;
@@ -3080,74 +3108,27 @@ match_attr_spec (void)
       seen[d]++;
       seen_at[d] = gfc_current_locus;
 
-      if (d == DECL_DIMENSION)
+      if (d == DECL_DIMENSION || d == DECL_CODIMENSION)
 	{
 	  gfc_array_spec *as = NULL;
 
-	  m = gfc_match_array_spec (&as, true, false);
-	  if (current_as == NULL)
-	    current_as = as;
-	  else if (m == MATCH_YES)
-	    {
-	      int i;
-	      gcc_assert (current_as->rank == 0 && current_as->corank > 0
-			  && as->rank > 0 && as->corank == 0);
-	      current_as->rank = as->rank;
-	      current_as->type = as->type;
-	      current_as->cray_pointee = as->cray_pointee;
-	      current_as->cp_was_assumed = as->cp_was_assumed;
-
-	      for (i = 0; i < current_as->corank; i++)
-		{
-		  current_as->lower[as->rank + i] = current_as->lower[i];
-		  current_as->upper[as->rank + i] = current_as->upper[i];
-		}
-	      for (i = 0; i < as->rank; i++)
-		{
-		  current_as->lower[i] = as->lower[i];
-		  current_as->upper[i] = as->upper[i];
-		}
-
-	      gfc_free (as);
-	    }
+	  m = gfc_match_array_spec (&as, d == DECL_DIMENSION,
+				    d == DECL_CODIMENSION);
 
-	  if (m == MATCH_NO)
-	    {
-	      gfc_error ("Missing dimension specification at %C");
-	      m = MATCH_ERROR;
-	    }
-
-	  if (m == MATCH_ERROR)
-	    goto cleanup;
-	}
-
-      if (d == DECL_CODIMENSION)
-	{
-	  gfc_array_spec *as = NULL;
-
-	  m = gfc_match_array_spec (&as, false, true);
 	  if (current_as == NULL)
 	    current_as = as;
 	  else if (m == MATCH_YES)
 	    {
-	      int i;
-	      gcc_assert (current_as->corank == 0 && current_as->rank > 0
-			  && as->corank > 0 && as->rank == 0);
-	      current_as->corank = as->corank;
-	      current_as->cotype = as->cotype;
-
-	      for (i = 0; i < as->corank; i++)
-		{
-		  current_as->lower[current_as->rank + i] = as->lower[i];
-		  current_as->upper[current_as->rank + i] = as->upper[i];
-		}
-
+	      merge_array_spec (as, current_as, false);
 	      gfc_free (as);
 	    }
 
 	  if (m == MATCH_NO)
 	    {
-	      gfc_error ("Missing codimension specification at %C");
+	      if (d == DECL_CODIMENSION)
+		gfc_error ("Missing codimension specification at %C");
+	      else
+		gfc_error ("Missing dimension specification at %C");
 	      m = MATCH_ERROR;
 	    }
 
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 902c7be..5e9b25c 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -77,6 +77,7 @@ static int current_entry_id;
 /* We use bitmaps to determine if a branch target is valid.  */
 static bitmap_obstack labels_obstack;
 
+/* True when simplifying a EXPR_VARIABLE argument to an inquiry function.  */
 static bool inquiry_argument = false;
 
 int
@@ -934,23 +935,13 @@ resolve_structure_cons (gfc_expr *expr)
 
       /* F2003, C1272 (3).  */
       if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
-	  && gfc_impure_variable (cons->expr->symtree->n.sym))
-	{
-	  t = FAILURE;
-	  gfc_error ("Invalid expression in the derived type constructor for pointer "
-		     "component '%s' at %L in PURE procedure", comp->name,
-		     &cons->expr->where);
-	}
-
-      /* F2003, C1272 (3).  */
-      if (gfc_pure (NULL) && cons->expr->expr_type == EXPR_VARIABLE
 	  && (gfc_impure_variable (cons->expr->symtree->n.sym)
 	      || gfc_is_coindexed (cons->expr)))
 	{
 	  t = FAILURE;
-	  gfc_error ("Invalid expression in the derived type constructor for pointer "
-		     "component '%s' at %L in PURE procedure", comp->name,
-		     &cons->expr->where);
+	  gfc_error ("Invalid expression in the derived type constructor for "
+		     "pointer component '%s' at %L in PURE procedure",
+		     comp->name, &cons->expr->where);
 	}
     }
 
@@ -2618,7 +2609,10 @@ resolve_function (gfc_expr *expr)
 
   if (resolve_actual_arglist (expr->value.function.actual,
 			      p, no_formal_args) == FAILURE)
+    {
+      inquiry_argument = false;
       return FAILURE;
+    }
 
   inquiry_argument = false;
  
@@ -3802,7 +3796,6 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
       break;
 
     case DIMEN_STAR:
-	/* Check only the lower bound as the upper one is '*'.  */
     case DIMEN_ELEMENT:
       if (compare_bound (ar->start[i], as->lower[i]) == CMP_LT)
 	{
@@ -4691,7 +4684,7 @@ resolve_procedure:
       if (ref == NULL)
 	{
 	  gfc_component *c;
-          c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
+	  c = ref2 ? ref2->u.c.component : e->symtree->n.sym->components;
 	  for ( ; c; c = c->next)
 	    if (c->attr.allocatable && c->ts.type == BT_CLASS)
 	      {
@@ -5726,6 +5719,7 @@ gfc_resolve_expr (gfc_expr *e)
   if (e == NULL)
     return SUCCESS;
 
+  /* inquiry_argument only applies to variables.  */
   inquiry_save = inquiry_argument;
   if (e->expr_type != EXPR_VARIABLE)
     inquiry_argument = false;
@@ -6265,8 +6259,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
 static gfc_try
 resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 {
-  int i, pointer, allocatable, dimension, check_intent_in, is_abstract,
-      coindexed = false;
+  int i, pointer, allocatable, dimension, check_intent_in, is_abstract;
   int codimension;
   symbol_attribute attr;
   gfc_ref *ref, *ref2;
@@ -6335,7 +6328,6 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code)
 	  switch (ref->type)
 	    {
  	      case REF_ARRAY:
-		coindexed = coindexed ? true : ref->u.ar.codimen > 0;
 		if (ref->next != NULL)
 		  pointer = 0;
 		break;
@@ -6551,8 +6543,8 @@ check_symbols:
 
   if (codimension)
     {
-      gfc_error ("Sorry, allocatable coarrays are no yet supported coarray at %L",
-		 &e->where);
+      gfc_error ("Sorry, allocatable coarrays are no yet supported coarray "
+		 "at %L", &e->where);
       goto failure;
     }