[Patch, fortran] PR121384 - Wrongly initialized associate array descriptor when the target is wrapped in parenthesis

From 691c7503f509423c3ffedbfa0bda5207281951bd Mon Sep 17 00:00:00 2001
From: Paul Thomas <[email protected]>
Date: Fri, 17 Apr 2026 06:00:03 +0100
Subject: [PATCH] Fortran: Fix wrongly initialized associate-name descriptor
 [PR121384]

2026-04-17  Paul Thomas  <[email protected]>

gcc/fortran
	PR fortran/121384
	* resolve.cc (add_comp_ref, build_assignment,
	add_code_to_chain, get_temp_from_expr,
	add_temp_assign_before_call) : Move to top of file and delete
	prototypes.
	(resolve_block_construct): Generate a temporary for subref
	array selectors enclosed in parantheses.

gcc/testsuite
	PR fortran/121384
	* gfortran.dg/associate_79.f90: New test.
---
 gcc/fortran/resolve.cc                     | 556 +++++++++++----------
 gcc/testsuite/gfortran.dg/associate_79.f90 |  43 ++
 2 files changed, 338 insertions(+), 261 deletions(-)
 create mode 100644 gcc/testsuite/gfortran.dg/associate_79.f90

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index a5d9add9d2f..bf078a40206 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -204,6 +204,264 @@ check_proc_interface (gfc_symbol *ifc, locus *where)
 static void resolve_symbol (gfc_symbol *sym);
 
 
+/*************Helper functions for modifying code*********************/
+
+/* Add a component reference onto an expression.  */
+
+static void
+add_comp_ref (gfc_expr *e, gfc_component *c)
+{
+  gfc_ref **ref;
+  ref = &(e->ref);
+  while (*ref)
+    ref = &((*ref)->next);
+  *ref = gfc_get_ref ();
+  (*ref)->type = REF_COMPONENT;
+  (*ref)->u.c.sym = e->ts.u.derived;
+  (*ref)->u.c.component = c;
+  e->ts = c->ts;
+
+  /* Add a full array ref, as necessary.  */
+  if (c->as)
+    {
+      gfc_add_full_array_ref (e, c->as);
+      e->rank = c->as->rank;
+      e->corank = c->as->corank;
+    }
+}
+
+
+/* Build an assignment.  Keep the argument 'op' for future use, so that
+   pointer assignments can be made.  */
+
+static gfc_code *
+build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
+		  gfc_component *comp1, gfc_component *comp2, locus loc)
+{
+  gfc_code *this_code;
+
+  this_code = gfc_get_code (op);
+  this_code->next = NULL;
+  this_code->expr1 = gfc_copy_expr (expr1);
+  this_code->expr2 = gfc_copy_expr (expr2);
+  this_code->loc = loc;
+  if (comp1 && comp2)
+    {
+      add_comp_ref (this_code->expr1, comp1);
+      add_comp_ref (this_code->expr2, comp2);
+    }
+
+  return this_code;
+}
+
+
+/* Makes a temporary variable expression based on the characteristics of
+   a given variable expression.  If allocatable is set, the temporary is
+   unconditionally allocatable*/
+
+static gfc_expr*
+get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,
+		    bool allocatable = false)
+{
+  static int serial = 0;
+  char name[GFC_MAX_SYMBOL_LEN];
+  gfc_symtree *tmp;
+  gfc_array_spec *as;
+  gfc_array_ref *aref;
+  gfc_ref *ref;
+
+  sprintf (name, GFC_PREFIX("DA%d"), serial++);
+  gfc_get_sym_tree (name, ns, &tmp, false);
+  gfc_add_type (tmp->n.sym, &e->ts, NULL);
+
+  if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
+    tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
+						    NULL,
+						    e->value.character.length);
+
+  as = NULL;
+  ref = NULL;
+  aref = NULL;
+
+  /* Obtain the arrayspec for the temporary.  */
+   if (e->rank && e->expr_type != EXPR_ARRAY
+       && e->expr_type != EXPR_FUNCTION
+       && e->expr_type != EXPR_OP)
+    {
+      aref = gfc_find_array_ref (e);
+      if (e->expr_type == EXPR_VARIABLE
+	  && e->symtree->n.sym->as == aref->as)
+	as = aref->as;
+      else
+	{
+	  for (ref = e->ref; ref; ref = ref->next)
+	    if (ref->type == REF_COMPONENT
+		&& ref->u.c.component->as == aref->as)
+	      {
+		as = aref->as;
+		break;
+	      }
+	}
+    }
+
+  /* Add the attributes and the arrayspec to the temporary.  */
+  tmp->n.sym->attr = gfc_expr_attr (e);
+  tmp->n.sym->attr.function = 0;
+  tmp->n.sym->attr.proc_pointer = 0;
+  tmp->n.sym->attr.result = 0;
+  tmp->n.sym->attr.flavor = FL_VARIABLE;
+  tmp->n.sym->attr.dummy = 0;
+  tmp->n.sym->attr.use_assoc = 0;
+  tmp->n.sym->attr.intent = INTENT_UNKNOWN;
+
+
+  if (as && !allocatable)
+    {
+      tmp->n.sym->as = gfc_copy_array_spec (as);
+      if (!ref)
+	ref = e->ref;
+      if (as->type == AS_DEFERRED)
+	tmp->n.sym->attr.allocatable = 1;
+    }
+  else if ((e->rank || e->corank)
+	   && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
+	       || e->expr_type == EXPR_OP || allocatable))
+    {
+      tmp->n.sym->as = gfc_get_array_spec ();
+      tmp->n.sym->as->type = AS_DEFERRED;
+      tmp->n.sym->as->rank = e->rank;
+      tmp->n.sym->as->corank = e->corank;
+      tmp->n.sym->attr.allocatable = 1;
+      tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
+      tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
+    }
+  else
+    tmp->n.sym->attr.dimension = 0;
+
+  gfc_set_sym_referenced (tmp->n.sym);
+  gfc_commit_symbol (tmp->n.sym);
+  e = gfc_lval_expr_from_sym (tmp->n.sym);
+
+  /* Should the lhs be a section, use its array ref for the
+     temporary expression.  */
+  if (aref && aref->type != AR_FULL && !allocatable)
+    {
+      gfc_free_ref_list (e->ref);
+      e->ref = gfc_copy_ref (ref);
+    }
+  return e;
+}
+
+
+/* Helper function to take an argument in a subroutine call with a dependency
+   on another argument, copy it to an allocatable temporary and use the
+   temporary in the call expression. The new code is embedded in a block to
+   ensure local, automatic deallocation.  */
+
+static void
+add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns,
+			     gfc_expr **rhsptr)
+{
+  gfc_namespace *block_ns;
+  gfc_expr *tmp_var;
+
+  /* Wrap the new code in a block so that the temporary is deallocated.  */
+  block_ns = gfc_build_block_ns (ns);
+
+  /* As it stands, the block_ns does not not stand up to resolution because the
+     the assignment would be converted to a call and, in any case, the modified
+     call fails in gfc_check_conformance.  */
+  block_ns->resolved = 1;
+
+  /* Assign the original expression to the temporary.  */
+  tmp_var = get_temp_from_expr (*rhsptr, block_ns, true);
+  block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr,
+				     NULL, NULL, (*rhsptr)->where);
+
+  /* Transfer the call to the block and terminate block code.  */
+  *rhsptr = gfc_copy_expr (tmp_var);
+  block_ns->code->next = gfc_get_code (EXEC_NOP);
+  *(block_ns->code->next) = *code;
+  block_ns->code->next->next = NULL;
+
+  /* Convert the original code to execute the block.  */
+  code->op = EXEC_BLOCK;
+  code->ext.block.ns = block_ns;
+  code->ext.block.assoc = NULL;
+  code->expr1 = code->expr2 = NULL;
+}
+
+
+/* Add one line of code to the code chain, making sure that 'head' and
+   'tail' are appropriately updated.  */
+
+static void
+add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
+{
+  gcc_assert (this_code);
+  if (*head == NULL)
+    *head = *tail = *this_code;
+  else
+    *tail = gfc_append_code (*tail, *this_code);
+  *this_code = NULL;
+}
+
+
+/* Generate a final call from a variable expression  */
+
+static void
+generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
+{
+  gfc_code *this_code;
+  gfc_expr *final_expr = NULL;
+  gfc_expr *size_expr;
+  gfc_expr *fini_coarray;
+
+  gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
+  if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
+    return;
+
+  /* Now generate the finalizer call.  */
+  this_code = gfc_get_code (EXEC_CALL);
+  this_code->symtree = final_expr->symtree;
+  this_code->resolved_sym = final_expr->symtree->n.sym;
+
+  //* Expression to be finalized  */
+  this_code->ext.actual = gfc_get_actual_arglist ();
+  this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
+
+  /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
+  this_code->ext.actual->next = gfc_get_actual_arglist ();
+  size_expr = gfc_get_expr ();
+  size_expr->where = gfc_current_locus;
+  size_expr->expr_type = EXPR_OP;
+  size_expr->value.op.op = INTRINSIC_DIVIDE;
+  size_expr->value.op.op1
+	= gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
+				    "storage_size", gfc_current_locus, 2,
+				    gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
+				    gfc_get_int_expr (gfc_index_integer_kind,
+						      NULL, 0));
+  size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
+					      gfc_character_storage_size);
+  size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
+  size_expr->ts = size_expr->value.op.op1->ts;
+  this_code->ext.actual->next->expr = size_expr;
+
+  /* fini_coarray  */
+  this_code->ext.actual->next->next = gfc_get_actual_arglist ();
+  fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
+					&tmp_expr->where);
+  fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
+  this_code->ext.actual->next->next->expr = fini_coarray;
+
+  add_code_to_chain (&this_code, head, tail);
+
+}
+
+/**********End of helper functions for modifying code*****************/
+
+
 /* Resolve the interface for a PROCEDURE declaration or procedure pointer.  */
 
 static bool
@@ -4133,9 +4391,6 @@ check_import_status (gfc_expr *e)
    argument which is not INTENT_IN and requires a temporary, build a temporary
    for the INTENT_IN actual argument as well.  */
 
-static void
-add_temp_assign_before_call (gfc_code *, gfc_namespace *, gfc_expr **);
-
 static void
 resolve_elemental_dependencies (gfc_code *c)
 {
@@ -12876,14 +13131,47 @@ static void
 resolve_block_construct (gfc_code* code)
 {
   gfc_namespace *ns = code->ext.block.ns;
+  gfc_association_list *assoc;
+  gfc_expr *tmp_var, *tgt;
+  gfc_code *tmp_code, *old_code;
+  gfc_exec_op op;
+
+  /* For an ASSOCIATE block, the associations (and their targets) will, for the
+     main part, be resolved by gfc_resolve_symbol, during resolution of the
+     BLOCK's namespace.  */
+
+  assoc = code->ext.block.assoc;
+
+  /* Subref arrays that are encloded in parentheses need a temporary.  */
+  for (; assoc; assoc = assoc->next)
+    {
+      if (assoc && assoc->st && assoc->st->n.sym->assoc
+	  && !assoc->st->n.sym->attr.select_type_temporary
+	  && (tgt = assoc->st->n.sym->assoc->target)
+	  && gfc_resolve_expr (tgt)
+	  && tgt->expr_type == EXPR_OP
+	  && tgt->value.op.op == INTRINSIC_PARENTHESES
+	  && is_subref_array (tgt->value.op.op1))
+	{
+	  if (gfc_expr_attr (tgt->value.op.op1).pointer)
+	    op = EXEC_POINTER_ASSIGN;
+	  else
+	    op = EXEC_ASSIGN;
+	  tmp_var = get_temp_from_expr (tgt->value.op.op1, ns->parent, true);
+	  tmp_code = build_assignment (op, tmp_var, tgt->value.op.op1,
+				       NULL, NULL, assoc->where);
+	  assoc->st->n.sym->assoc->target = gfc_copy_expr (tmp_var);
+	  old_code = gfc_get_code (EXEC_NOP);
+	  *old_code = *code;
+	  *code = *tmp_code;
+	  code->next = old_code;
+	  free (tmp_code);
+	}
+    }
 
-  /* For an ASSOCIATE block, the associations (and their targets) will be
-     resolved by gfc_resolve_symbol, during resolution of the BLOCK's
-     namespace.  */
   gfc_resolve (ns);
 }
 
-
 /* Resolve lists of blocks found in IF, SELECT CASE, WHERE, FORALL, GOTO and
    DO code nodes.  */
 
@@ -13312,263 +13600,9 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
 }
 
 
-/* Add a component reference onto an expression.  */
-
-static void
-add_comp_ref (gfc_expr *e, gfc_component *c)
-{
-  gfc_ref **ref;
-  ref = &(e->ref);
-  while (*ref)
-    ref = &((*ref)->next);
-  *ref = gfc_get_ref ();
-  (*ref)->type = REF_COMPONENT;
-  (*ref)->u.c.sym = e->ts.u.derived;
-  (*ref)->u.c.component = c;
-  e->ts = c->ts;
-
-  /* Add a full array ref, as necessary.  */
-  if (c->as)
-    {
-      gfc_add_full_array_ref (e, c->as);
-      e->rank = c->as->rank;
-      e->corank = c->as->corank;
-    }
-}
-
-
-/* Build an assignment.  Keep the argument 'op' for future use, so that
-   pointer assignments can be made.  */
-
-static gfc_code *
-build_assignment (gfc_exec_op op, gfc_expr *expr1, gfc_expr *expr2,
-		  gfc_component *comp1, gfc_component *comp2, locus loc)
-{
-  gfc_code *this_code;
-
-  this_code = gfc_get_code (op);
-  this_code->next = NULL;
-  this_code->expr1 = gfc_copy_expr (expr1);
-  this_code->expr2 = gfc_copy_expr (expr2);
-  this_code->loc = loc;
-  if (comp1 && comp2)
-    {
-      add_comp_ref (this_code->expr1, comp1);
-      add_comp_ref (this_code->expr2, comp2);
-    }
-
-  return this_code;
-}
-
-
-/* Makes a temporary variable expression based on the characteristics of
-   a given variable expression.  If allocatable is set, the temporary is
-   unconditionally allocatable*/
-
-static gfc_expr*
-get_temp_from_expr (gfc_expr *e, gfc_namespace *ns,
-		    bool allocatable = false)
-{
-  static int serial = 0;
-  char name[GFC_MAX_SYMBOL_LEN];
-  gfc_symtree *tmp;
-  gfc_array_spec *as;
-  gfc_array_ref *aref;
-  gfc_ref *ref;
-
-  sprintf (name, GFC_PREFIX("DA%d"), serial++);
-  gfc_get_sym_tree (name, ns, &tmp, false);
-  gfc_add_type (tmp->n.sym, &e->ts, NULL);
-
-  if (e->expr_type == EXPR_CONSTANT && e->ts.type == BT_CHARACTER)
-    tmp->n.sym->ts.u.cl->length = gfc_get_int_expr (gfc_charlen_int_kind,
-						    NULL,
-						    e->value.character.length);
-
-  as = NULL;
-  ref = NULL;
-  aref = NULL;
-
-  /* Obtain the arrayspec for the temporary.  */
-   if (e->rank && e->expr_type != EXPR_ARRAY
-       && e->expr_type != EXPR_FUNCTION
-       && e->expr_type != EXPR_OP)
-    {
-      aref = gfc_find_array_ref (e);
-      if (e->expr_type == EXPR_VARIABLE
-	  && e->symtree->n.sym->as == aref->as)
-	as = aref->as;
-      else
-	{
-	  for (ref = e->ref; ref; ref = ref->next)
-	    if (ref->type == REF_COMPONENT
-		&& ref->u.c.component->as == aref->as)
-	      {
-		as = aref->as;
-		break;
-	      }
-	}
-    }
-
-  /* Add the attributes and the arrayspec to the temporary.  */
-  tmp->n.sym->attr = gfc_expr_attr (e);
-  tmp->n.sym->attr.function = 0;
-  tmp->n.sym->attr.proc_pointer = 0;
-  tmp->n.sym->attr.result = 0;
-  tmp->n.sym->attr.flavor = FL_VARIABLE;
-  tmp->n.sym->attr.dummy = 0;
-  tmp->n.sym->attr.use_assoc = 0;
-  tmp->n.sym->attr.intent = INTENT_UNKNOWN;
-
-
-  if (as && !allocatable)
-    {
-      tmp->n.sym->as = gfc_copy_array_spec (as);
-      if (!ref)
-	ref = e->ref;
-      if (as->type == AS_DEFERRED)
-	tmp->n.sym->attr.allocatable = 1;
-    }
-  else if ((e->rank || e->corank)
-	   && (e->expr_type == EXPR_ARRAY || e->expr_type == EXPR_FUNCTION
-	       || e->expr_type == EXPR_OP || allocatable))
-    {
-      tmp->n.sym->as = gfc_get_array_spec ();
-      tmp->n.sym->as->type = AS_DEFERRED;
-      tmp->n.sym->as->rank = e->rank;
-      tmp->n.sym->as->corank = e->corank;
-      tmp->n.sym->attr.allocatable = 1;
-      tmp->n.sym->attr.dimension = e->rank ? 1 : 0;
-      tmp->n.sym->attr.codimension = e->corank ? 1 : 0;
-    }
-  else
-    tmp->n.sym->attr.dimension = 0;
-
-  gfc_set_sym_referenced (tmp->n.sym);
-  gfc_commit_symbol (tmp->n.sym);
-  e = gfc_lval_expr_from_sym (tmp->n.sym);
-
-  /* Should the lhs be a section, use its array ref for the
-     temporary expression.  */
-  if (aref && aref->type != AR_FULL && !allocatable)
-    {
-      gfc_free_ref_list (e->ref);
-      e->ref = gfc_copy_ref (ref);
-    }
-  return e;
-}
-
-
-/* Helper function to take an argument in a subroutine call with a dependency
-   on another argument, copy it to an allocatable temporary and use the
-   temporary in the call expression. The new code is embedded in a block to
-   ensure local, automatic deallocation.  */
-
-static void
-add_temp_assign_before_call (gfc_code *code, gfc_namespace *ns,
-			     gfc_expr **rhsptr)
-{
-  gfc_namespace *block_ns;
-  gfc_expr *tmp_var;
-
-  /* Wrap the new code in a block so that the temporary is deallocated.  */
-  block_ns = gfc_build_block_ns (ns);
-
-  /* As it stands, the block_ns does not not stand up to resolution because the
-     the assignment would be converted to a call and, in any case, the modified
-     call fails in gfc_check_conformance.  */
-  block_ns->resolved = 1;
-
-  /* Assign the original expression to the temporary.  */
-  tmp_var = get_temp_from_expr (*rhsptr, block_ns, true);
-  block_ns->code = build_assignment (EXEC_ASSIGN, tmp_var, *rhsptr,
-				     NULL, NULL, (*rhsptr)->where);
-
-  /* Transfer the call to the block and terminate block code.  */
-  *rhsptr = gfc_copy_expr (tmp_var);
-  block_ns->code->next = gfc_get_code (EXEC_NOP);
-  *(block_ns->code->next) = *code;
-  block_ns->code->next->next = NULL;
-
-  /* Convert the original code to execute the block.  */
-  code->op = EXEC_BLOCK;
-  code->ext.block.ns = block_ns;
-  code->ext.block.assoc = NULL;
-  code->expr1 = code->expr2 = NULL;
-}
-
-
-/* Add one line of code to the code chain, making sure that 'head' and
-   'tail' are appropriately updated.  */
-
-static void
-add_code_to_chain (gfc_code **this_code, gfc_code **head, gfc_code **tail)
-{
-  gcc_assert (this_code);
-  if (*head == NULL)
-    *head = *tail = *this_code;
-  else
-    *tail = gfc_append_code (*tail, *this_code);
-  *this_code = NULL;
-}
-
-
-/* Generate a final call from a variable expression  */
-
-static void
-generate_final_call (gfc_expr *tmp_expr, gfc_code **head, gfc_code **tail)
-{
-  gfc_code *this_code;
-  gfc_expr *final_expr = NULL;
-  gfc_expr *size_expr;
-  gfc_expr *fini_coarray;
-
-  gcc_assert (tmp_expr->expr_type == EXPR_VARIABLE);
-  if (!gfc_is_finalizable (tmp_expr->ts.u.derived, &final_expr) || !final_expr)
-    return;
-
-  /* Now generate the finalizer call.  */
-  this_code = gfc_get_code (EXEC_CALL);
-  this_code->symtree = final_expr->symtree;
-  this_code->resolved_sym = final_expr->symtree->n.sym;
-
-  //* Expression to be finalized  */
-  this_code->ext.actual = gfc_get_actual_arglist ();
-  this_code->ext.actual->expr = gfc_copy_expr (tmp_expr);
-
-  /* size_expr = STORAGE_SIZE (...) / NUMERIC_STORAGE_SIZE.  */
-  this_code->ext.actual->next = gfc_get_actual_arglist ();
-  size_expr = gfc_get_expr ();
-  size_expr->where = gfc_current_locus;
-  size_expr->expr_type = EXPR_OP;
-  size_expr->value.op.op = INTRINSIC_DIVIDE;
-  size_expr->value.op.op1
-	= gfc_build_intrinsic_call (gfc_current_ns, GFC_ISYM_STORAGE_SIZE,
-				    "storage_size", gfc_current_locus, 2,
-				    gfc_lval_expr_from_sym (tmp_expr->symtree->n.sym),
-				    gfc_get_int_expr (gfc_index_integer_kind,
-						      NULL, 0));
-  size_expr->value.op.op2 = gfc_get_int_expr (gfc_index_integer_kind, NULL,
-					      gfc_character_storage_size);
-  size_expr->value.op.op1->ts = size_expr->value.op.op2->ts;
-  size_expr->ts = size_expr->value.op.op1->ts;
-  this_code->ext.actual->next->expr = size_expr;
-
-  /* fini_coarray  */
-  this_code->ext.actual->next->next = gfc_get_actual_arglist ();
-  fini_coarray = gfc_get_constant_expr (BT_LOGICAL, gfc_default_logical_kind,
-					&tmp_expr->where);
-  fini_coarray->value.logical = (int)gfc_expr_attr (tmp_expr).codimension;
-  this_code->ext.actual->next->next->expr = fini_coarray;
-
-  add_code_to_chain (&this_code, head, tail);
-
-}
-
 /* Counts the potential number of part array references that would
    result from resolution of typebound defined assignments.  */
 
-
 static int
 nonscalar_typebound_assign (gfc_symbol *derived, int depth)
 {
diff --git a/gcc/testsuite/gfortran.dg/associate_79.f90 b/gcc/testsuite/gfortran.dg/associate_79.f90
new file mode 100644
index 00000000000..ff657e6499e
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/associate_79.f90
@@ -0,0 +1,43 @@
+! { dg-do run }
+! Test the fix for PR121384
+! Contributed by Mikael Morin  <[email protected]>
+program test
+  implicit none
+  type :: t
+    integer :: i,j
+  end type
+  type(t) :: a(5)
+  class(t), allocatable :: c(:)
+  a = [ t(2,3), t(5,7), t(11,13), t(17,19), t(23,29) ]
+  associate (x => (a%i))
+    if (rank(x) /= 1) error stop 11
+    if (any(shape(x) /= [5])) error stop 12
+    if (any(x /= [2,5,11,17,23])) error stop 13
+    x(1) = 3
+  end associate
+  if  (a(1)%i /= 2) stop 14
+  associate (x => (a%j))
+    if (rank(x) /= 1) error stop 21
+    if (any(shape(x) /= [5])) error stop 22
+    if (any(x /= [3,7,13,19,29])) error stop 23
+    x(1) = 4
+  end associate
+  if  (a(1)%j /= 3) stop 24
+
+! Check the class variants
+  c = a
+  associate (x => (c%i))
+    if (rank(x) /= 1) error stop 31
+    if (any(shape(x) /= [5])) error stop 32
+    if (any(x /= [2,5,11,17,23])) error stop 33
+    x(1) = 3
+  end associate
+  if  (c(1)%i /= 2) stop 34
+  associate (x => (c%j))
+    if (rank(x) /= 1) error stop 41
+    if (any(shape(x) /= [5])) error stop 42
+    if (any(x /= [3,7,13,19,29])) error stop 43
+    x(1) = 4
+  end associate
+  if  (c(1)%j /= 3) stop 44
+end program
-- 
2.53.0