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 2525041041d9396ab9097b5cf522854355dbfd60 Mon Sep 17 00:00:00 2001
From: Paul Thomas <[email protected]>
Date: Wed, 7 Oct 2026 08:37:44 +0100
Subject: [PATCH] Fortran: [meta-bug] [PDT] Parameterized derived type errors
[PR82173]
2026-10-07 Paul Thomas <[email protected]>
gcc/fortran
PR fortran/82173
* gfortran.h : Add prototype for gfc_get_temp_from_expr.
* resolve.cc (resolve_allocate_deallocate): The default init.
expression should not be used for MOLD expression3 in the cases
of PDTs and PDT classes.
(resolve_select_type): Use both the hash values and names to
distiguish CLASS IS selectors.
(get_temp_from_expr): Call the static version from gfc_get_temp
_from_expr.
* trans-stmt.cc : Inclode constructor.h.
(convert_structure_to_type_list): New function to do what the
name says.
(allocate_get_initializer): WHen the allocate statement has a
typespec and the init statement is a PDT structure, convert it
using the new function and attach the parm list to the init
expression.
(gfc_trans_allocate): As well as the init expression returned
allocate_get_initializer, branch on a mold expr3 being an PDT
structure expression. If the init_expr is NULL, copy expr3 and,
if necessary, use the new function to add a param_list. Then,
if the init_expr is a PDT with a param_list, allocate the
paramaterized components.
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/resolve.cc | 17 ++++++-
gcc/fortran/trans-stmt.cc | 65 +++++++++++++++++++++++--
gcc/testsuite/gfortran.dg/pdt_bug10.f90 | 21 ++++++++
gcc/testsuite/gfortran.dg/pdt_bug9.f90 | 42 ++++++++++++++++
5 files changed, 141 insertions(+), 5 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 a1badd0bde8..19f2b259164 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4228,6 +4228,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/resolve.cc b/gcc/fortran/resolve.cc
index 67eaea64c9b..e7caf9dd747 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -10065,6 +10065,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). */
@@ -11607,16 +11608,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
+ && !strcmp (C2_DERIVED->name, C1_DERIVED->name))
{
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)
{
@@ -13658,6 +13663,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 2a87176ffa9..9ad8342605a 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
{
@@ -6599,6 +6600,35 @@ 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);
+ }
+}
+
+
/* Get the initializer expression for the code and expr of an allocate.
When no initializer is needed return NULL. */
@@ -6612,7 +6642,13 @@ 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)
+ 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
@@ -7708,15 +7744,38 @@ 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;
+
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);
+ gfc_add_expr_to_block (&block, tmp);
+ gfc_replace_expr (init_expr, var);
+ }
+ ini->expr2 = init_expr;
tmp= gfc_trans_init_assign (ini);
flag_realloc_lhs = realloc_lhs;
gfc_free_statements (ini);
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..73ebf12d3f8
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_bug9.f90
@@ -0,0 +1,42 @@
+! { dg-do run }
+! See attachment to PR82173 comment 10 - reproducers/bug9-class-is-kind-ice.f90
+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
+! type(base(16,4)) :: mld
+ class(*), allocatable :: u
+ allocate (base(4, 3) :: u) ! This failed
+ call selector (u)
+ deallocate (u)
+ allocate (base(8, 5) :: u) ! This failed
+ call selector (u)
+ deallocate (u)
+ allocate (u, source = base(4, 3)([1,2,3]))
+ call selector (u)
+ deallocate (u)
+ allocate (u, mold = base(16, 4)([1.,2.,3.,4.])) ! This failed
+ call selector (u)
+ u = base(4, 3)([1,2,3])
+ call selector (u)
+contains
+ subroutine selector (u)
+ class(*), allocatable :: u
+ if (.not.allocated (u)) return
+ select type (u)
+ class is (base(4, *)) ! distinct kind parameter values are
+ if (size (u%v, 1) /= 3) stop 1
+ if (kind (u%v) /= 4) stop 2
+ class is (base(8, *)) ! distinct guards - C1168 permits this
+ if (size(u%v, 1) /= 5) stop 3
+ if (kind (u%v) /= 8) stop 4
+ class is (base(16, *)) ! ditto
+ if (size(u%v, 1) /= 4) stop 5
+ end select
+ end
+end program
--
2.55.0
