This one is actually very straightforward. Most of the patch consists of moves of helper functions to allow a temporary to be constructed for the selector.
Regtests on FC43/x86_64 - OK for mainline? Once 17-branch is open, I will see if an extension to this patch can be used to eliminate a lot of code in trans-stmt.cc. Paul
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
