Hello All,
Jerry used Claude to review all of the submissions in this series that
have been posted to date. This was the report on this one:
Patch: 6 (bug9/10)
Verdict: Blocker: typed ALLOCATE into class(*) takes its LEN
from the shared per-KIND instance, so base(4,5) after
base(4,3) gets n=3, and a runtime LEN gets the default of 1.
That is silent wrong code where master segfaulted. Blocker:
the temporary leaks 12 bytes per ALLOCATE
The memory leak is still not fixed, being a generic PDT problem that I
will return to once this series is completed.
The rest of the report was straightforward to address and I was about
to resubmit a week ago. However, just to veer on the side of caution,
I tried variants of the testcase and found, to my horror, that
reducing the number of allocate/call selectors in the main program to
2 resulted in:
bug9-class-is-kind-ice.f90:30:21:
30 | class is (base(16, *)) ! ditto
| 1
Error: Keyword argument âkâ at (1) is not in the procedure
Reducing them to 1 such pair resulted in an ICE.
For either of these failing cases, either putting the subroutine
select in the module or adding a 'type is (integer(4)) before the
CLASS IS statements or including in selector declarations of
allocatable variable of each of the CLASS IS types, then allocating
them, fixed these problems. The latter kludge led me and then Claude
down many rabbit holes before the line "type_param_spec_list = NULL;"
in match.cc was added. I had tried this early on but it didn't work.
Clearly some other part or parts of the patch was necessary as well. I
started investigating, without joy, but I am frankly so sick and tired
of this bug that I gave up on it.
The attached patch passes regression testing. OK for mainline, on
condition that I come back to the memory leaks on a later date?
Regards
Paul
On Thu, 8 Oct 2026 at 13:35, Paul Richard Thomas
<[email protected]> wrote:
>
> bug9-class-is-kind-ice.f90:35:16:
>
> 35 | class is (base(8, *)) ! distinct guards - C1168 permits this
> | 1
> Error: Double CLASS IS block in SELECT TYPE statement at (1)
>
> bug10-unlimited-poly-alloc-len.f90 failed in runtime:
> Program received signal SIGSEGV: Segmentation fault - invalid memory
> reference.
> ....etc.,etc.....
>
> The fixes are inter-dependent and so come in a single patch.
>
> The chunks in gfortran.h and resolve.cc are sufficiently explained in
> the ChangeLog entries.
>
> The first three chunks in trans-stmt.cc convert the PDT structure
> constructor, emanating from the ALLOCATE typespec, convert it to a
> type parameter list and append it to the initialization expression.
>
> Chunk 4, then exploits the so appended initialization expression or if
> it is not available and the MOLD expr3 is a PDT structure constructor,
> does a likewise conversion of expr3. The parameterized components are
> then allocated and the result used as the rhs in the assignment to the
> allocated expression.
>
> Passes regtesting on FC44/x86_64. OK for mainline.
>
> Cheers
>
> Paul
From 301103ff946fea7cafd9e111790bf23cc397468c Mon Sep 17 00:00:00 2001
From: Paul Thomas <[email protected]>
Date: Mon, 19 Oct 2026 11:54:40 +0100
Subject: [PATCH] Fortran: [PDT] (6/16) Parameterized derived type errors
[PR82173]
2026-10-19 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.
---
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(-)
create mode 100644 gcc/testsuite/gfortran.dg/pdt_bug10.f90
create mode 100644 gcc/testsuite/gfortran.dg/pdt_bug9.f90
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 130f17af39c..9d4455ec7e3 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 8e83cf39590..264ac84eadd 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 71e94e5a60b..1167fc2a1a9 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 1fc996d7739..d27333aa466 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 00000000000..d5c277f895c
--- /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 00000000000..afa400b062f
--- /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
--
2.56.0
