https://gcc.gnu.org/g:40c4b9dcd9be3e63f8e4f6e4e49cdcd341764082
commit r17-5389-g40c4b9dcd9be3e63f8e4f6e4e49cdcd341764082 Author: Paul Thomas <[email protected]> Date: Tue Oct 20 11:54:40 2026 +0100 Fortran: [PDT] (6/16) Parameterized derived type errors [PR82173] 2026-10-20 Paul Thomas <[email protected]> assisted by Claude Haiku <[email protected]> gcc/fortran PR fortran/82173 * gfortran.h: Add param_list field to gfc_code allocate structure. Add extern declaration for gfc_get_temp_from_expr wrapper. * match.cc (gfc_match_class_is): Clear global type_param_spec_list before matching derived type spec to prevent residual state corruption in assumed parameter CLASS IS matching. Compute hash_value for CLASS IS cases to prevent collisions. * resolve.cc (resolve_allocate_expr): Add PDT instantiation from allocate-typespec parameters. Skip vtab lookup for PDT templates which don't have vtabs. Add macros for CLASS IS case comparison to prevent double-definition errors. * trans-stmt.cc: Add convert_structure_to_type_list and build_param_list_from_expr functions for PDT parameter handling. Update allocate_get_initializer to handle PDT types. Improve gfc_trans_allocate to properly handle PDT initialization with temporary deallocation. Add include for constructor.h. gcc/testsuite/ PR fortran/82173 * gfortran.dg/pdt_bug9.f90: New test. * gfortran.dg/pdt_bug10.f90: New test. Diff: --- gcc/fortran/gfortran.h | 1 + gcc/fortran/match.cc | 4 + gcc/fortran/resolve.cc | 27 ++++++- gcc/fortran/trans-stmt.cc | 125 +++++++++++++++++++++++++++++++- gcc/testsuite/gfortran.dg/pdt_bug10.f90 | 21 ++++++ gcc/testsuite/gfortran.dg/pdt_bug9.f90 | 51 +++++++++++++ 6 files changed, 223 insertions(+), 6 deletions(-) diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 130f17af39c7..9d4455ec7e3d 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -4237,6 +4237,7 @@ extern int gfc_do_concurrent_flag; const char* gfc_lookup_function_fuzzy (const char *, gfc_symtree *); bool gfc_pure_function (gfc_expr *e, const char **name); bool gfc_implicit_pure_function (gfc_expr *e); +gfc_expr* gfc_get_temp_from_expr (gfc_expr *, gfc_namespace *, bool); /* coarray.cc */ void gfc_coarray_rewrite (gfc_namespace *); diff --git a/gcc/fortran/match.cc b/gcc/fortran/match.cc index 8e83cf39590d..264ac84eadd8 100644 --- a/gcc/fortran/match.cc +++ b/gcc/fortran/match.cc @@ -8306,6 +8306,7 @@ gfc_match_class_is (void) c = gfc_get_case (); c->where = gfc_current_locus; + type_param_spec_list = NULL; m = match_derived_type_spec (&c->ts); if (m == MATCH_NO) goto syntax; @@ -8315,6 +8316,9 @@ gfc_match_class_is (void) if (c->ts.type == BT_DERIVED) c->ts.type = BT_CLASS; + /* Distinguish CLASS IS cases to prevent collisions. */ + c->ts.u.derived->hash_value = gfc_hash_value (c->ts.u.derived); + if (gfc_match_char (')') != MATCH_YES) goto syntax; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index 71e94e5a60b0..1167fc2a1a94 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -9674,7 +9674,15 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec) if (code->expr3) ts = &code->expr3->ts; else - ts = &code->ext.alloc.ts; + { + ts = &code->ext.alloc.ts; + if (ts->type == BT_DERIVED && ts->u.derived->attr.pdt_type) + { + code->expr3 = gfc_default_initializer (ts); + code->expr3->mold = 1; + code->ext.alloc.expr3_not_explicit = 1; + } + } gcc_assert (ts); @@ -10063,6 +10071,7 @@ done_errmsg: once here. */ if (code->expr3 && code->expr3->mold && code->expr3->ts.type == BT_DERIVED + && !IS_PDT (code->expr3) && !IS_CLASS_PDT (code->expr3) && !(code->expr3->ref && code->expr3->ref->type == REF_ARRAY)) { /* Default initialization via MOLD (non-polymorphic). */ @@ -11605,16 +11614,20 @@ resolve_select_type (gfc_code *code, gfc_namespace *old_ns) swapped = false; for (c1 = &class_is; (*c1) && (*c1)->block; c1 = &((*c1)->block)) { +#define C1_DERIVED (*c1)->ext.block.case_list->ts.u.derived +#define C2_DERIVED c2->ext.block.case_list->ts.u.derived c2 = (*c1)->block; + /* F03:C817 (check for doubles). */ - if ((*c1)->ext.block.case_list->ts.u.derived->hash_value - == c2->ext.block.case_list->ts.u.derived->hash_value) + if (C1_DERIVED->hash_value == C2_DERIVED->hash_value) { gfc_error ("Double CLASS IS block in SELECT TYPE " "statement at %L", &c2->ext.block.case_list->where); return; } +#undef C1_DERIVED +#undef C2_DERIVED if ((*c1)->ext.block.case_list->ts.u.derived->attr.extension < c2->ext.block.case_list->ts.u.derived->attr.extension) { @@ -13647,6 +13660,14 @@ get_temp_from_expr (gfc_expr *e, gfc_namespace *ns, } +gfc_expr* +gfc_get_temp_from_expr (gfc_expr *e, gfc_namespace *ns, + bool allocatable = false) +{ + return get_temp_from_expr (e, ns, allocatable); +} + + /* 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 diff --git a/gcc/fortran/trans-stmt.cc b/gcc/fortran/trans-stmt.cc index 224d359c0e71..65bf2ec9d930 100644 --- a/gcc/fortran/trans-stmt.cc +++ b/gcc/fortran/trans-stmt.cc @@ -35,6 +35,7 @@ along with GCC; see the file COPYING3. If not see #include "trans-const.h" #include "trans-descriptor.h" #include "dependency.h" +#include "constructor.h" typedef struct iter_info { @@ -6603,6 +6604,72 @@ gfc_trans_exit (gfc_code * code) } +/* Add the type parameter list to a PDT structure expression. */ + +static void +convert_structure_to_type_list (gfc_symbol *derived, gfc_expr *init) +{ + gfc_constructor *ctr; + gfc_component *cmp; + gfc_actual_arglist *parms = NULL; + ctr = gfc_constructor_first (init->value.constructor); + cmp = derived->components; + init->param_list = NULL; + for (; ctr && cmp; ctr = gfc_constructor_next (ctr), cmp = cmp->next) + { + if (!cmp->attr.pdt_kind && !cmp->attr.pdt_len) + break; + if (!init->param_list) + init->param_list = parms = gfc_get_actual_arglist (); + else + { + parms->next = gfc_get_actual_arglist (); + parms = parms->next; + } + parms->name = cmp->name; + parms->spec_type = ctr->expr ? SPEC_EXPLICIT : SPEC_ASSUMED; + parms->expr = gfc_copy_expr (ctr->expr); + } +} + + +/* Build param_list from explicit allocation parameters. */ + +static void +build_param_list_from_expr (gfc_expr *init, gfc_actual_arglist *expr_param_list, + gfc_symbol *derived) +{ + gfc_component *cmp; + gfc_actual_arglist *param, *parms = NULL; + + if (!expr_param_list) + return; + + init->param_list = NULL; + cmp = derived->components; + param = expr_param_list; + + /* Build param_list using explicit parameters, matching components. */ + for (; cmp && param; cmp = cmp->next) + { + if (!cmp->attr.pdt_kind && !cmp->attr.pdt_len) + break; + + if (!init->param_list) + init->param_list = parms = gfc_get_actual_arglist (); + else + { + parms->next = gfc_get_actual_arglist (); + parms = parms->next; + } + parms->name = cmp->name; + parms->spec_type = param->spec_type; + parms->expr = gfc_copy_expr (param->expr); + param = param->next; + } +} + + /* Get the initializer expression for the code and expr of an allocate. When no initializer is needed return NULL. */ @@ -6616,7 +6683,21 @@ allocate_get_initializer (gfc_code * code, gfc_expr * expr) if (code->ext.alloc.ts.type == BT_DERIVED && (code->ext.alloc.ts.u.derived->attr.alloc_comp || gfc_has_default_initializer (code->ext.alloc.ts.u.derived))) - return gfc_default_initializer (&code->ext.alloc.ts); + { + gfc_expr *init = gfc_default_initializer (&code->ext.alloc.ts); + if (code->ext.alloc.ts.u.derived->attr.pdt_type + && init && init->expr_type == EXPR_STRUCTURE) + { + /* Use explicit parameters from the allocate statement if available, + otherwise extract from the structure constructor. */ + if (expr && expr->param_list) + build_param_list_from_expr (init, expr->param_list, + code->ext.alloc.ts.u.derived); + else + convert_structure_to_type_list (code->ext.alloc.ts.u.derived, init); + } + return init; + } if (gfc_bt_struct (expr->ts.type) && (expr->ts.u.derived->attr.alloc_comp @@ -7712,15 +7793,51 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) if (tmp != NULL_TREE) gfc_add_expr_to_block (&block, tmp); } - else if ((init_expr = allocate_get_initializer (code, expr))) + else if ((init_expr = allocate_get_initializer (code, expr)) + || (code->expr3 && code->expr3->expr_type == EXPR_STRUCTURE + && code->expr3->mold && IS_PDT (code->expr3))) { /* Use class_init_assign to initialize expr. */ gfc_code *ini; int realloc_lhs = flag_realloc_lhs; + tree dealloc_pdt = NULL_TREE; + ini = gfc_get_code (EXEC_INIT_ASSIGN); ini->expr1 = gfc_expr_to_initialize (expr); - ini->expr2 = init_expr; flag_realloc_lhs = 0; + + if (init_expr == NULL) + { + init_expr = gfc_copy_expr (code->expr3); + if (!init_expr->param_list) + convert_structure_to_type_list (code->expr3->ts.u.derived, + init_expr); + } + + if (IS_PDT (init_expr) && init_expr->param_list) + { + gfc_expr *var; + tree decl; + var = gfc_get_temp_from_expr (init_expr, gfc_current_ns, false); + decl = gfc_get_symbol_decl (var->symtree->n.sym); + tmp = gfc_allocate_pdt_comp (init_expr->ts.u.derived, decl, + 0, init_expr->param_list); + dealloc_pdt = gfc_deallocate_pdt_comp (init_expr->ts.u.derived, + decl, 0); + gfc_add_expr_to_block (&block, tmp); + gfc_free_actual_arglist (init_expr->param_list); + init_expr->param_list = NULL; + gfc_replace_expr (init_expr, var); + /* Deallocate temporary PDT's allocatable components. */ + if (var->symtree->n.sym->ts.u.derived->attr.alloc_comp) + { + tree var_decl = gfc_get_symbol_decl (var->symtree->n.sym); + tmp = gfc_deallocate_pdt_comp (var->symtree->n.sym->ts.u.derived, + var_decl, 0); + gfc_add_expr_to_block (&block, tmp); + } + } + ini->expr2 = init_expr; tmp= gfc_trans_init_assign (ini); flag_realloc_lhs = realloc_lhs; gfc_free_statements (ini); @@ -7728,6 +7845,8 @@ gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) it here. */ init_expr = NULL; gfc_add_expr_to_block (&block, tmp); + if (dealloc_pdt != NULL_TREE) + gfc_add_expr_to_block (&block, dealloc_pdt); } /* Nullify all pointers in derived type coarrays. This registers a diff --git a/gcc/testsuite/gfortran.dg/pdt_bug10.f90 b/gcc/testsuite/gfortran.dg/pdt_bug10.f90 new file mode 100644 index 000000000000..d5c277f895c4 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_bug10.f90 @@ -0,0 +1,21 @@ +! { dg-do run } +module m2 + type :: base(k, n) + integer, kind :: k = 4 + integer, len :: n = 1 + real(k) :: v(n) + end type +end module +program i2 + use m2 + class(*), allocatable :: u + allocate (base(4, 3) :: u) +! allocate (u, source = base(4, 3)([1,2,3])) ! Was OK + select type (u) + type is (base(4, *)) + if (u%n /= 3) stop 1 + if (size (u%v) /= 3) stop 2 + class default + stop 3 + end select +end program diff --git a/gcc/testsuite/gfortran.dg/pdt_bug9.f90 b/gcc/testsuite/gfortran.dg/pdt_bug9.f90 new file mode 100644 index 000000000000..afa400b062f1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_bug9.f90 @@ -0,0 +1,51 @@ +! { dg-do run } +! Based on attachment to PR82173 comment 10 - reproducers/bug9-class-is-kind-ice.f90 +! +! This was straightforward to fix; apart from line 36, which required considerable +! assistance from Claude Haiku <[email protected]>. +! +! Contributed by Jerry Delisle <[email protected]> +! +module mj + type :: base(k, n) + integer, kind :: k = 4 + integer, len :: n = 1 + real(k) :: v(n) + end type +end module +program j1 + use mj + class(*), allocatable :: u + allocate (base(4, 3) :: u) ! This failed "Double CLASS IS block" + call selector (u, 3) + allocate (base(4, 5) :: u) ! n = 3 was returned + call selector (u, 5) + call the_rest () +contains + subroutine selector (u, sz) + class(*), allocatable :: u + integer :: sz + if (.not.allocated (u)) return + select type (u) + class is (base(4, *)) ! distinct kind parameter values are + if (size (u%v, 1) /= sz) stop 1 + if (kind (u%v) /= 4) stop 2 + class is (base(8, *)) ! distinct guards - C1168 permits this + if (size(u%v, 1) /= sz) stop 3 + if (kind (u%v) /= 8) stop 4 + class is (base(16, *)) ! Keyword argument âkâ at (1) is not in the procedure + if (size(u%v, 1) /= sz) stop 5 + end select + if (allocated (u)) deallocate (u) + end + subroutine the_rest () + allocate (base(8, 5) :: u) ! This failed + call selector (u, 5) + allocate (u, source = base(4, 3)([1,2,3])) + call selector (u, 3) + allocate (u, mold = base(16, 4)([1.,2.,3.,4.])) ! This failed + call selector (u, 4) + u = base(4, 3)([1,2,3]) + call selector (u, 3) + end +end program
