openacc: Fix lowering for derived-type mappings through array elements

This patch fixes lowering of derived-type mappings which select elements
of arrays of derived types, and similar. These would previously lead
to ICEs.

With this change, OpenACC directives can pass through constructs that
are no longer recognized by the gimplifier, hence alterations are needed
there also.

gcc/fortran/
	* trans-openmp.c (gfc_trans_omp_clauses): Handle element selection
	for arrays of derived types.

gcc/
	* gimplify.c (gimplify_scan_omp_clauses): Handle ATTACH_DETACH
	for non-decls.

gcc/testsuite/
	* gfortran.dg/goacc/array-with-dt-1.f90: New test.
	* gfortran.dg/goacc/array-with-dt-3.f90: Likewise.
	* gfortran.dg/goacc/array-with-dt-4.f90: Likewise.
	* gfortran.dg/goacc/array-with-dt-5.f90: Likewise.
	* gfortran.dg/goacc/derived-chartypes-1.f90: Re-enable test.
	* gfortran.dg/goacc/derived-chartypes-2.f90: Likewise.
	* gfortran.dg/goacc/derived-classtypes-1.f95: Uncomment
	previously-broken directives.

libgomp/
	* testsuite/libgomp.oacc-fortran/derivedtypes-arrays-1.f90: New test.
	* testsuite/libgomp.oacc-fortran/update-dt-array.f90: Likewise.

1 files changed, 111 insertions, 81 deletions

diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c
index 249b3de..67e370f 100644
--- a/gcc/fortran/trans-openmp.c
+++ b/gcc/fortran/trans-openmp.c
@@ -2675,6 +2675,32 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 	      tree decl = gfc_trans_omp_variable (n->sym, false);
 	      if (DECL_P (decl))
 		TREE_ADDRESSABLE (decl) = 1;
+
+	      gfc_ref *lastref = NULL;
+
+	      if (n->expr)
+		for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
+		  if (ref->type == REF_COMPONENT || ref->type == REF_ARRAY)
+		    lastref = ref;
+
+	      bool allocatable = false, pointer = false;
+
+	      if (lastref && lastref->type == REF_COMPONENT)
+		{
+		  gfc_component *c = lastref->u.c.component;
+
+		  if (c->ts.type == BT_CLASS)
+		    {
+		      pointer = CLASS_DATA (c)->attr.class_pointer;
+		      allocatable = CLASS_DATA (c)->attr.allocatable;
+		    }
+		  else
+		    {
+		      pointer = c->attr.pointer;
+		      allocatable = c->attr.allocatable;
+		    }
+		}
+
 	      if (n->expr == NULL
 		  || (n->expr->ref->type == REF_ARRAY
 		      && n->expr->ref->u.ar.type == AR_FULL))
@@ -2911,74 +2937,79 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		}
 	      else if (n->expr
 		       && n->expr->expr_type == EXPR_VARIABLE
-		       && n->expr->ref->type == REF_COMPONENT)
+		       && n->expr->ref->type == REF_ARRAY
+		       && !n->expr->ref->next)
 		{
-		  gfc_ref *lastcomp;
-
-		  for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
-		    if (ref->type == REF_COMPONENT)
-		      lastcomp = ref;
-
-		  symbol_attribute sym_attr;
-
-		  if (lastcomp->u.c.component->ts.type == BT_CLASS)
-		    sym_attr = CLASS_DATA (lastcomp->u.c.component)->attr;
-		  else
-		    sym_attr = lastcomp->u.c.component->attr;
-
+		  /* An array element or array section which is not part of a
+		     derived type, etc.  */
+		  bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
+		  gfc_trans_omp_array_section (block, n, decl, element,
+					       GOMP_MAP_POINTER, node, node2,
+					       node3, node4);
+		}
+	      else if (n->expr
+		       && n->expr->expr_type == EXPR_VARIABLE
+		       && (n->expr->ref->type == REF_COMPONENT
+			   || n->expr->ref->type == REF_ARRAY)
+		       && lastref
+		       && lastref->type == REF_COMPONENT
+		       && lastref->u.c.component->ts.type != BT_CLASS
+		       && lastref->u.c.component->ts.type != BT_DERIVED
+		       && !lastref->u.c.component->attr.dimension)
+		{
+		  /* Derived type access with last component being a scalar.  */
 		  gfc_init_se (&se, NULL);
 
-		  if (!sym_attr.dimension
-		      && lastcomp->u.c.component->ts.type != BT_CLASS
-		      && lastcomp->u.c.component->ts.type != BT_DERIVED)
+		  gfc_conv_expr (&se, n->expr);
+		  gfc_add_block_to_block (block, &se.pre);
+		  /* For BT_CHARACTER a pointer is returned.  */
+		  OMP_CLAUSE_DECL (node)
+		    = POINTER_TYPE_P (TREE_TYPE (se.expr))
+		      ? build_fold_indirect_ref (se.expr) : se.expr;
+		  gfc_add_block_to_block (block, &se.post);
+		  if (pointer || allocatable)
 		    {
-		      /* Last component is a scalar.  */
-		      gfc_conv_expr (&se, n->expr);
-		      gfc_add_block_to_block (block, &se.pre);
-		      /* For BT_CHARACTER a pointer is returned.  */
-		      OMP_CLAUSE_DECL (node)
+		      node2 = build_omp_clause (input_location,
+						OMP_CLAUSE_MAP);
+		      gomp_map_kind kind
+			= (openacc ? GOMP_MAP_ATTACH_DETACH
+				   : GOMP_MAP_ALWAYS_POINTER);
+		      OMP_CLAUSE_SET_MAP_KIND (node2, kind);
+		      OMP_CLAUSE_DECL (node2)
 			= POINTER_TYPE_P (TREE_TYPE (se.expr))
-			  ? build_fold_indirect_ref (se.expr) : se.expr;
-		      gfc_add_block_to_block (block, &se.post);
-		      if (sym_attr.pointer || sym_attr.allocatable)
+			  ? se.expr
+			  : gfc_build_addr_expr (NULL, se.expr);
+		      OMP_CLAUSE_SIZE (node2) = size_int (0);
+		      if (!openacc
+			  && n->expr->ts.type == BT_CHARACTER
+			  && n->expr->ts.deferred)
 			{
-			  node2 = build_omp_clause (input_location,
+			  gcc_assert (se.string_length);
+			  tree tmp
+			    = gfc_get_char_type (n->expr->ts.kind);
+			  OMP_CLAUSE_SIZE (node)
+			    = fold_build2 (MULT_EXPR, size_type_node,
+					   fold_convert (size_type_node,
+					       se.string_length),
+					   TYPE_SIZE_UNIT (tmp));
+			  node3 = build_omp_clause (input_location,
 						    OMP_CLAUSE_MAP);
-			  OMP_CLAUSE_SET_MAP_KIND (node2,
-						   openacc
-						   ? GOMP_MAP_ATTACH_DETACH
-						   : GOMP_MAP_ALWAYS_POINTER);
-			  OMP_CLAUSE_DECL (node2)
-			    = POINTER_TYPE_P (TREE_TYPE (se.expr))
-			      ? se.expr :  gfc_build_addr_expr (NULL, se.expr);
-			  OMP_CLAUSE_SIZE (node2) = size_int (0);
-			  if (!openacc
-			      && n->expr->ts.type == BT_CHARACTER
-			      && n->expr->ts.deferred)
-			    {
-			      gcc_assert (se.string_length);
-			      tree tmp = gfc_get_char_type (n->expr->ts.kind);
-			      OMP_CLAUSE_SIZE (node)
-				= fold_build2 (MULT_EXPR, size_type_node,
-					       fold_convert (size_type_node,
-							     se.string_length),
-					       TYPE_SIZE_UNIT (tmp));
-			      node3 = build_omp_clause (input_location,
-							OMP_CLAUSE_MAP);
-			      OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO);
-			      OMP_CLAUSE_DECL (node3) = se.string_length;
-			      OMP_CLAUSE_SIZE (node3)
-				= TYPE_SIZE_UNIT (gfc_charlen_type_node);
-			    }
+			  OMP_CLAUSE_SET_MAP_KIND (node3, GOMP_MAP_TO);
+			  OMP_CLAUSE_DECL (node3) = se.string_length;
+			  OMP_CLAUSE_SIZE (node3)
+			    = TYPE_SIZE_UNIT (gfc_charlen_type_node);
 			}
-		      goto finalize_map_clause;
 		    }
-
+		}
+	      else if (n->expr
+		       && n->expr->expr_type == EXPR_VARIABLE
+		       && (n->expr->ref->type == REF_COMPONENT
+			   || n->expr->ref->type == REF_ARRAY))
+		{
+		  gfc_init_se (&se, NULL);
 		  se.expr = gfc_maybe_dereference_var (n->sym, decl);
 
-		  for (gfc_ref *ref = n->expr->ref;
-		       ref && ref != lastcomp->next;
-		       ref = ref->next)
+		  for (gfc_ref *ref = n->expr->ref; ref; ref = ref->next)
 		    {
 		      if (ref->type == REF_COMPONENT)
 			{
@@ -2987,24 +3018,30 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 
 			  gfc_conv_component_ref (&se, ref);
 			}
+		      else if (ref->type == REF_ARRAY)
+			{
+			  if (ref->u.ar.type == AR_ELEMENT && ref->next)
+			    gfc_conv_array_ref (&se, &ref->u.ar, n->expr,
+						&n->expr->where);
+			  else
+			    gcc_assert (!ref->next);
+			}
 		      else
-			sorry ("unhandled derived-type component");
+			sorry ("unhandled expression type");
 		    }
 
 		  tree inner = se.expr;
 
 		  /* Last component is a derived type or class pointer.  */
-		  if (lastcomp->u.c.component->ts.type == BT_DERIVED
-		      || lastcomp->u.c.component->ts.type == BT_CLASS)
+		  if (lastref->type == REF_COMPONENT
+		      && (lastref->u.c.component->ts.type == BT_DERIVED
+			  || lastref->u.c.component->ts.type == BT_CLASS))
 		    {
-		      bool pointer
-			= (lastcomp->u.c.component->ts.type == BT_CLASS
-			   ? sym_attr.class_pointer : sym_attr.pointer);
-		      if (pointer || (openacc && sym_attr.allocatable))
+		      if (pointer || (openacc && allocatable))
 			{
 			  tree data, size;
 
-			  if (lastcomp->u.c.component->ts.type == BT_CLASS)
+			  if (lastref->u.c.component->ts.type == BT_CLASS)
 			    {
 			      data = gfc_class_data_get (inner);
 			      gcc_assert (POINTER_TYPE_P (TREE_TYPE (data)));
@@ -3035,9 +3072,8 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 			    = TYPE_SIZE_UNIT (TREE_TYPE (inner));
 			}
 		    }
-		  else if (lastcomp->next
-			   && lastcomp->next->type == REF_ARRAY
-			   && lastcomp->next->u.ar.type == AR_FULL)
+		  else if (lastref->type == REF_ARRAY
+			   && lastref->u.ar.type == AR_FULL)
 		    {
 		      /* Just pass the (auto-dereferenced) decl through for
 			 bare attach and detach clauses.  */
@@ -3131,27 +3167,21 @@ gfc_trans_omp_clauses (stmtblock_t *block, gfc_omp_clauses *clauses,
 		      else
 			OMP_CLAUSE_DECL (node) = inner;
 		    }
-		  else  /* An array element or section.  */
+		  else if (lastref->type == REF_ARRAY)
 		    {
-		      bool element
-			= (lastcomp->next
-			   && lastcomp->next->type == REF_ARRAY
-			   && lastcomp->next->u.ar.type == AR_ELEMENT);
-
+		      /* An array element or section.  */
+		      bool element = lastref->u.ar.type == AR_ELEMENT;
 		      gomp_map_kind kind = (openacc ? GOMP_MAP_ATTACH_DETACH
 						    : GOMP_MAP_ALWAYS_POINTER);
 		      gfc_trans_omp_array_section (block, n, inner, element,
 						   kind, node, node2, node3,
 						   node4);
 		    }
+		  else
+		    gcc_unreachable ();
 		}
-	      else  /* An array element or array section.  */
-		{
-		  bool element = n->expr->ref->u.ar.type == AR_ELEMENT;
-		  gfc_trans_omp_array_section (block, n, decl, element,
-					       GOMP_MAP_POINTER, node, node2,
-					       node3, node4);
-		}
+	      else
+		sorry ("unhandled expression");
 
 	      finalize_map_clause: