diff mbox

[Fortran] ASSOCIATE to array-expressions

Message ID 4C59BF66.6070200@domob.eu
State New
Headers show

Commit Message

Daniel Kraft Aug. 4, 2010, 7:28 p.m. UTC 
Hi,

the attached patch fixes some problems that turned up during ASSOCIATE 
work (like the expr.c and trans-decl.c change).

But most notably, it implements association to array expressions; still 
in a somewhat limited fashin, unfortunately.  However, for instance 
Tobias' original PR example works now.

In general I see two "problems" with associate that are partially 
touched and handled by this patch, which may need further work to 
implement them better:

   * It may not be known until resolution if a variable is an array or 
of what type it is.  This is handled for arrays in the current patch; I 
believe however, that for association to derived-types this may be a 
huge problem and need some substantial rework and thinking about.  I may 
be wrong, though.

   * The variables backing an associate-name are currently built as 
AS_EXPLICIT arrays, and the bounds set as LBOUND/UBOUND of the target 
expression.  Since my last patch, the simplifier is able to reduce a lot 
of these to constants or simple expressions, but not all.  If it is not 
able to do so, the target expression is actually evaluated a lot of 
times (instead just once -- this might still be strictly standard 
conforming, but surely not the way to go); additionally in this case, an 
error is issued if the expression is not a valid 
initialization-expression.  See the XFAIL'ed test-case for instance -- 
it works, but with two calls to func instead of one; if func is declared 
non-PURE there, it does not even compile.

I think we will have to rework this and introduce some way to mark array 
variables as "temporaries" for some expression, and let trans-* do the 
bounds stuff.  This will be also useful for FINAL, I think.  (And maybe 
other front-end lowering.)

But for now I think that this patch is worthwhile introducing, even if 
we still have to find a "final" solution to some issues in the future.

Regtesting on GNU/Linux-x86-32 at the moment.  Ok if successful?

Yours,
Daniel

Comments

Daniel Kraft Aug. 4, 2010, 8:20 p.m. UTC | #1 
Daniel Kraft wrote:
> Hi,
> 
> the attached patch fixes some problems that turned up during ASSOCIATE 
> work (like the expr.c and trans-decl.c change).
> 
> But most notably, it implements association to array expressions; still 
> in a somewhat limited fashin, unfortunately.  However, for instance 
> Tobias' original PR example works now.
> 
> In general I see two "problems" with associate that are partially 
> touched and handled by this patch, which may need further work to 
> implement them better:
> 
>   * It may not be known until resolution if a variable is an array or of 
> what type it is.  This is handled for arrays in the current patch; I 
> believe however, that for association to derived-types this may be a 
> huge problem and need some substantial rework and thinking about.  I may 
> be wrong, though.
> 
>   * The variables backing an associate-name are currently built as 
> AS_EXPLICIT arrays, and the bounds set as LBOUND/UBOUND of the target 
> expression.  Since my last patch, the simplifier is able to reduce a lot 
> of these to constants or simple expressions, but not all.  If it is not 
> able to do so, the target expression is actually evaluated a lot of 
> times (instead just once -- this might still be strictly standard 
> conforming, but surely not the way to go); additionally in this case, an 
> error is issued if the expression is not a valid 
> initialization-expression.  See the XFAIL'ed test-case for instance -- 
> it works, but with two calls to func instead of one; if func is declared 
> non-PURE there, it does not even compile.
> 
> I think we will have to rework this and introduce some way to mark array 
> variables as "temporaries" for some expression, and let trans-* do the 
> bounds stuff.  This will be also useful for FINAL, I think.  (And maybe 
> other front-end lowering.)
> 
> But for now I think that this patch is worthwhile introducing, even if 
> we still have to find a "final" solution to some issues in the future.
> 
> Regtesting on GNU/Linux-x86-32 at the moment.  Ok if successful?

No failures.
Tobias Burnus Aug. 14, 2010, 9:44 p.m. UTC | #2 
Daniel Kraft wrote:
> But for now I think that this patch is worthwhile introducing, even if 
> we still have to find a "final" solution to some issues in the future.

I concur.

> Regtesting on GNU/Linux-x86-32 at the moment.  Ok if successful?

OK - though, I have some questions and nits:

a) Shouldn't the following be the following a once ("1") instead of a 
twice ("2")?

+! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } }


b) I miss a run-time test.

c) I get an ICE for:
   integer :: a
   associate (b => a)
   end associate
   end
Error: Association to variables is not yet supported at (1)
f951: internal compiler error: in gfc_enforce_clean_symbol_state, at 
fortran/symbol.c:3451

How about using gfc_fatal_error instead of gfc_error - or something else 
which avoids the ICE?

Tobias
Daniel Kraft Aug. 15, 2010, 7:52 p.m. UTC | #3 
Tobias Burnus wrote:
>  Daniel Kraft wrote:
>> But for now I think that this patch is worthwhile introducing, even if 
>> we still have to find a "final" solution to some issues in the future.
> 
> I concur.
> 
>> Regtesting on GNU/Linux-x86-32 at the moment.  Ok if successful?
> 
> OK - though, I have some questions and nits:

Committed as rev. 163268, your points as discussed on IRC.

Thanks, Daniel
diff mbox

Patch

Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c	(revision 162841)
+++ gcc/fortran/symbol.c	(working copy)
@@ -4744,3 +4744,19 @@  gfc_type_compatible (gfc_typespec *ts1, 
   else
     return 0;
 }
+
+
+/* Find the parent-namespace of the current function.  If we're inside
+   BLOCK constructs, it may not be the current one.  */
+
+gfc_namespace*
+gfc_find_proc_namespace (gfc_namespace* ns)
+{
+  while (ns->construct_entities)
+    {
+      ns = ns->parent;
+      gcc_assert (ns);
+    }
+
+  return ns;
+}
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h	(revision 162841)
+++ gcc/fortran/gfortran.h	(working copy)
@@ -2577,6 +2577,7 @@  void gfc_copy_formal_args_ppc (gfc_compo
 void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too  */
 
 gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
+gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
 
 /* intrinsic.c -- true if working in an init-expr, false otherwise.  */
 extern bool gfc_init_expr_flag;
Index: gcc/fortran/expr.c
===================================================================
--- gcc/fortran/expr.c	(revision 162841)
+++ gcc/fortran/expr.c	(working copy)
@@ -4221,7 +4221,6 @@  gfc_build_intrinsic_call (const char* na
   result->expr_type = EXPR_FUNCTION;
   result->ts = isym->ts;
   result->where = where;
-  gfc_get_ha_sym_tree (isym->name, &result->symtree);
   result->value.function.name = name;
   result->value.function.isym = isym;
 
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c	(revision 162841)
+++ gcc/fortran/resolve.c	(working copy)
@@ -4705,11 +4705,26 @@  resolve_variable (gfc_expr *e)
 
   if (e->symtree == NULL)
     return FAILURE;
+  sym = e->symtree->n.sym;
+
+  /* If this is an associate-name, it may be parsed with references in error
+     even though the target is scalar.  Fail directly in this case.  */
+  if (sym->assoc && !sym->attr.dimension && e->ref)
+    return FAILURE;
+
+  /* On the other hand, the parser may not have known this is an array;
+     in this case, we have to add a FULL reference.  */
+  if (sym->assoc && sym->attr.dimension && !e->ref)
+    {
+      e->ref = gfc_get_ref ();
+      e->ref->type = REF_ARRAY;
+      e->ref->u.ar.type = AR_FULL;
+      e->ref->u.ar.dimen = 0;
+    }
 
   if (e->ref && resolve_ref (e) == FAILURE)
     return FAILURE;
 
-  sym = e->symtree->n.sym;
   if (sym->attr.flavor == FL_PROCEDURE
       && (!sym->attr.function
 	  || (sym->attr.function && sym->result
@@ -8155,11 +8170,43 @@  gfc_resolve_forall (gfc_code *code, gfc_
 static void
 resolve_block_construct (gfc_code* code)
 {
-  /* For an ASSOCIATE block, the associations (and their targets) are already
-     resolved during gfc_resolve_symbol.  */
-
   /* Resolve the BLOCK's namespace.  */
   gfc_resolve (code->ext.block.ns);
+
+  /* For an ASSOCIATE block, the associations (and their targets) are already
+     resolved during gfc_resolve_symbol.  Here, we have to add code
+     to assign expression values to the variables associated to expressions.  */
+  if (code->ext.block.assoc)
+    {
+      gfc_association_list* a;     
+      gfc_code* assignTail;
+      gfc_code* assignHead;
+
+      assignHead = assignTail = NULL;
+      for (a = code->ext.block.assoc; a; a = a->next)
+	if (!a->variable)
+	  {
+	    gfc_code* newAssign;
+
+	    newAssign = gfc_get_code ();
+	    newAssign->op = EXEC_ASSIGN;
+	    newAssign->loc = gfc_current_locus;
+	    newAssign->expr1 = gfc_lval_expr_from_sym (a->st->n.sym);
+	    newAssign->expr2 = a->target;
+
+	    if (!assignHead)
+	      assignHead = newAssign;
+	    else
+	      {
+		gcc_assert (assignTail);
+		assignTail->next = newAssign;
+	      }
+	    assignTail = newAssign;
+	  }
+
+      assignTail->next = code->ext.block.ns->code;
+      code->ext.block.ns->code = assignHead;
+    }
 }
 
 
@@ -8644,7 +8691,7 @@  resolve_code (gfc_code *code, gfc_namesp
 	  break;
 
 	case EXEC_BLOCK:
-	  gfc_resolve (code->ext.block.ns);
+	  resolve_block_construct (code);
 	  break;
 
 	case EXEC_DO:
@@ -11530,6 +11577,54 @@  resolve_symbol (gfc_symbol *sym)
 
       sym->ts = sym->assoc->target->ts;
       gcc_assert (sym->ts.type != BT_UNKNOWN);
+
+      if (sym->attr.dimension && sym->assoc->target->rank == 0)
+	{
+	  gfc_error ("Associate-name '%s' at %L is used as array",
+		     sym->name, &sym->declared_at);
+	  sym->attr.dimension = 0;
+	  return;
+	}
+      if (sym->assoc->target->rank > 0)
+	sym->attr.dimension = 1;
+
+      if (sym->attr.dimension)
+	{
+	  int dim;
+
+	  sym->as = gfc_get_array_spec ();
+	  sym->as->rank = sym->assoc->target->rank;
+	  sym->as->type = AS_EXPLICIT;
+
+	  /* Target must not be coindexed, thus the associate-variable
+	     has no corank.  */
+	  sym->as->corank = 0;
+
+	  for (dim = 0; dim < sym->assoc->target->rank; ++dim)
+	    {
+	      gfc_expr* dim_expr;
+	      gfc_expr* e;
+
+	      dim_expr = gfc_get_constant_expr (BT_INTEGER,
+						gfc_default_integer_kind,
+						&sym->declared_at);
+	      mpz_set_si (dim_expr->value.integer, dim + 1);
+
+	      e = gfc_build_intrinsic_call ("lbound", sym->declared_at, 3,
+					    gfc_copy_expr (sym->assoc->target),
+					    gfc_copy_expr (dim_expr), NULL);
+	      gfc_resolve_expr (e);
+	      sym->as->lower[dim] = e;
+
+	      e = gfc_build_intrinsic_call ("ubound", sym->declared_at, 3,
+					    gfc_copy_expr (sym->assoc->target),
+					    gfc_copy_expr (dim_expr), NULL);
+	      gfc_resolve_expr (e);
+	      sym->as->upper[dim] = e;
+
+	      gfc_free_expr (dim_expr);
+	    }
+	}
     }
 
   /* Assign default type to symbols that need one and don't have one.  */
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c	(revision 162841)
+++ gcc/fortran/trans-decl.c	(working copy)
@@ -658,6 +658,7 @@  gfc_build_qualified_array (tree decl, gf
   tree type;
   int dim;
   int nest;
+  gfc_namespace* procns;
 
   type = TREE_TYPE (decl);
 
@@ -666,7 +667,8 @@  gfc_build_qualified_array (tree decl, gf
     return;
 
   gcc_assert (GFC_ARRAY_TYPE_P (type));
-  nest = (sym->ns->proc_name->backend_decl != current_function_decl)
+  procns = gfc_find_proc_namespace (sym->ns);
+  nest = (procns->proc_name->backend_decl != current_function_decl)
 	 && !sym->attr.contained;
 
   for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c	(revision 162841)
+++ gcc/fortran/parse.c	(working copy)
@@ -3214,7 +3214,6 @@  parse_associate (void)
   gfc_state_data s;
   gfc_statement st;
   gfc_association_list* a;
-  gfc_code* assignTail;
 
   gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
 
@@ -3224,46 +3223,24 @@  parse_associate (void)
   new_st.ext.block.ns = my_ns;
   gcc_assert (new_st.ext.block.assoc);
 
-  /* Add all associations to expressions as BLOCK variables, and create
-     assignments to them giving their values.  */
+  /* Add all associate-names as BLOCK variables.  There values will be assigned
+     to them during resolution of the ASSOCIATE construct.  */
   gfc_current_ns = my_ns;
-  assignTail = NULL;
   for (a = new_st.ext.block.assoc; a; a = a->next)
-    if (!a->variable)
-      {
-	gfc_code* newAssign;
-
-	if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
-	  gcc_unreachable ();
-
-	/* Note that in certain cases, the target-expression's type is not yet
-	   known and so we have to adapt the symbol's ts also during resolution
-	   for these cases.  */
-	a->st->n.sym->ts = a->target->ts;
-	a->st->n.sym->attr.flavor = FL_VARIABLE;
-	a->st->n.sym->assoc = a;
-	gfc_set_sym_referenced (a->st->n.sym);
-
-	/* Create the assignment to calculate the expression and set it.  */
-	newAssign = gfc_get_code ();
-	newAssign->op = EXEC_ASSIGN;
-	newAssign->loc = gfc_current_locus;
-	newAssign->expr1 = gfc_get_variable_expr (a->st);
-	newAssign->expr2 = a->target;
-
-	/* Hang it in.  */
-	if (assignTail)
-	  assignTail->next = newAssign;
-	else
-	  gfc_current_ns->code = newAssign;
-	assignTail = newAssign;
-      }
-    else
-      {
-	gfc_error ("Association to variables is not yet supported at %C");
-	return;
-      }
-  gcc_assert (assignTail);
+    {
+      if (a->variable)
+	{
+	  gfc_error ("Association to variables is not yet supported at %C");
+	  return;
+	}
+
+      if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
+	gcc_unreachable ();
+
+      a->st->n.sym->attr.flavor = FL_VARIABLE;
+      a->st->n.sym->assoc = a;
+      gfc_set_sym_referenced (a->st->n.sym);
+    }
 
   accept_statement (ST_ASSOCIATE);
   push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
@@ -3277,7 +3254,7 @@  loop:
 
     case_end:
       accept_statement (st);
-      assignTail->next = gfc_state_stack->head;
+      my_ns->code = gfc_state_stack->head;
       break;
 
     default:
Index: gcc/fortran/primary.c
===================================================================
--- gcc/fortran/primary.c	(revision 162841)
+++ gcc/fortran/primary.c	(working copy)
@@ -1748,6 +1748,13 @@  gfc_match_varspec (gfc_expr *primary, in
 	}
     }
 
+  /* For associate names, we may not yet know whether they are arrays or not.
+     Thus if we have one and parentheses follow, we have to assume that it
+     actually is one for now.  The final decision will be made at
+     resolution time, of course.  */
+  if (sym->assoc && gfc_peek_ascii_char () == '(')
+    sym->attr.dimension = 1;
+
   if ((equiv_flag && gfc_peek_ascii_char () == '(')
       || gfc_peek_ascii_char () == '[' || sym->attr.codimension
       || (sym->attr.dimension && !sym->attr.proc_pointer
Index: gcc/testsuite/gfortran.dg/associate_3.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_3.f03	(revision 162841)
+++ gcc/testsuite/gfortran.dg/associate_3.f03	(working copy)
@@ -2,7 +2,7 @@ 
 ! { dg-options "-std=f2003" }
 
 ! PR fortran/38936
-! Check for errors with ASSOCIATE.
+! Check for errors with ASSOCIATE during parsing.
 
 PROGRAM main
   IMPLICIT NONE
Index: gcc/testsuite/gfortran.dg/associate_5.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_5.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/associate_5.f03	(revision 0)
@@ -0,0 +1,13 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2003" }
+
+! PR fortran/38936
+! Check for errors with ASSOCIATE during resolution.
+
+PROGRAM main
+  IMPLICIT NONE
+
+  ASSOCIATE (a => 5) ! { dg-error "is used as array" }
+    PRINT *, a(3)
+  END ASSOCIATE
+END PROGRAM main
Index: gcc/testsuite/gfortran.dg/associate_6.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_6.f03	(revision 0)
+++ gcc/testsuite/gfortran.dg/associate_6.f03	(revision 0)
@@ -0,0 +1,38 @@ 
+! { dg-do compile }
+! { dg-options "-std=f2003 -fdump-tree-original" }
+
+! PR fortran/38936
+! Check that array expression association (with correct bounds) works for
+! complicated expressions.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+! FIXME: XFAIL'ed because this is not yet implemented 'correctly'.
+
+MODULE m
+  IMPLICIT NONE
+
+CONTAINS
+
+  PURE FUNCTION func (n)
+    INTEGER, INTENT(IN) :: n
+    INTEGER :: func(2 : n+1)
+
+    INTEGER :: i
+
+    func = (/ (i, i = 1, n) /)
+  END FUNCTION func
+
+END MODULE m
+
+PROGRAM main
+  USE :: m
+  IMPLICIT NONE
+
+  ASSOCIATE (arr => func (4))
+    ! func should only be called once here, not again for the bounds!
+  END ASSOCIATE
+END PROGRAM main
+! { dg-final { cleanup-modules "m" } }
+! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } }
+! { dg-final { cleanup-tree-dump "original" } }
Index: gcc/testsuite/gfortran.dg/associate_1.f03
===================================================================
--- gcc/testsuite/gfortran.dg/associate_1.f03	(revision 162841)
+++ gcc/testsuite/gfortran.dg/associate_1.f03	(working copy)
@@ -24,13 +24,15 @@  PROGRAM main
   ! TODO: Test association to derived types.
 
   ! Test association to arrays.
-  ! TODO: Enable when working.
-  !ALLOCATE (arr(3))
-  !arr = (/ 1, 2, 3 /)
-  !ASSOCIATE (doubled => 2 * arr)
-  !  IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
-  !    CALL abort ()
-  !END ASSOCIATE
+  ALLOCATE (arr(3))
+  arr = (/ 1, 2, 3 /)
+  ASSOCIATE (doubled => 2 * arr, xyz => func ())
+    IF (SIZE (doubled) /= SIZE (arr)) CALL abort ()
+    IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
+      CALL abort ()
+
+    IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
+  END ASSOCIATE
 
   ! Named and nested associate.
   myname: ASSOCIATE (x => a - b * c)
@@ -46,4 +48,12 @@  PROGRAM main
       IF (x /= 2 .OR. y /= 1) CALL abort ()
     END ASSOCIATE
   END ASSOCIATE
+
+CONTAINS
+
+  FUNCTION func ()
+    INTEGER :: func(3)
+    func = (/ 1, 3, 5 /)
+  END FUNCTION func
+
 END PROGRAM main