From: Paul Thomas Date: Sun, 15 Feb 2026 08:11:31 +0000 (+0000) Subject: Fortran: Prevent direct references to PDT instances [PR108663] X-Git-Url: http://git.ipfire.org/cgi-bin/gitweb.cgi?a=commitdiff_plain;h=26f81567c112dc580f114905a37564f92ae81143;p=thirdparty%2Fgcc.git Fortran: Prevent direct references to PDT instances [PR108663] 2026-02-15 Paul Thomas gcc/fortran PR fortran/108663 * decl.cc (gfc_get_pdt_instance): Use PDT_PREFIX and PDT_PREFIX_LEN. * gfortran.h : Define PDT_PREFIX and PDT_PREFIX_LEN. Note that PDT_PREFIX must have at least two upper case letters. * module.cc (read_module): Use PDT_PREFIX and PDT_PREFIX_LEN. * resolve.cc (resolve_typebound_procedure): Both pdt_template and pdt_type resolve_bindings_derived dummies should be tested for LEN type parameters being assumed. * symbol.cc (gfc_pdt_is_instance_of): Update preceding comment and use PDT_PREFIX_LEN. gcc/testsuite PR fortran/108663 * gfortran.dg/pdt_15.f03: Modify tree dump test for new prefix. * gfortran.dg/pdt_71.f03: Ditto. * gfortran.dg/pdt_79.f03: Ditto. * gfortran.dg/pdt_84.f03: New test. --- diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 2908007d75c..cb6bd6f8cc0 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -3960,10 +3960,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, /* Pointers to the parameter specification being used. */ gfc_actual_arglist *actual_param; gfc_actual_arglist *tail = NULL; - /* Used to build up the name of the PDT instance. The prefix uses 4 + /* Used to build up the name of the PDT instance. The prefix uses 3 characters and each KIND parameter 2 more. Allow 8 of the latter. */ - char name[GFC_MAX_SYMBOL_LEN + 21]; - + char name[GFC_MAX_SYMBOL_LEN + PDT_PREFIX_LEN + 16]; bool name_seen = (param_list == NULL); bool assumed_seen = false; bool deferred_seen = false; @@ -3980,7 +3979,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, type_param_name_list = pdt->formal; actual_param = param_list; - sprintf (name, "Pdt%s", pdt->name); + sprintf (name, "%s%s", PDT_PREFIX, pdt->name); /* Prevent a PDT component of the same type as the template from being converted into an instance. Doing this results in the component being diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 109bf6a5c29..c9242a3adcc 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -4310,6 +4310,8 @@ bool gfc_may_be_finalized (gfc_typespec); (expr && expr->expr_type == EXPR_VARIABLE \ && expr->symtree->n.sym->assoc \ && expr->symtree->n.sym->assoc->inferred_type) +#define PDT_PREFIX "PDT" +#define PDT_PREFIX_LEN 3 #define IS_PDT(sym) \ (sym != NULL && sym->ts.type == BT_DERIVED \ && sym->ts.u.derived \ diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc index 47b1c943132..04ddf6b4476 100644 --- a/gcc/fortran/module.cc +++ b/gcc/fortran/module.cc @@ -5843,13 +5843,14 @@ read_module (void) /* Include pdt_types if their associated pdt_template is in a USE, ONLY list. */ if (p == NULL && name[0] == 'P' - && startswith (name, "Pdt") + && startswith (name, PDT_PREFIX) && module_list) { gfc_use_list *ml = module_list; for (; ml; ml = ml->next) if (ml->rename - && !strncmp (&name[3], ml->rename->use_name, + && !strncmp (&name[PDT_PREFIX_LEN], + ml->rename->use_name, strlen (ml->rename->use_name))) p = name; } diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index d98c2d65476..655db8a1c9c 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -16701,9 +16701,10 @@ resolve_typebound_procedure (gfc_symtree* stree) goto error; } - if (resolve_bindings_derived->attr.pdt_template - && gfc_pdt_is_instance_of (resolve_bindings_derived, - CLASS_DATA (me_arg)->ts.u.derived) + if (((resolve_bindings_derived->attr.pdt_template + && gfc_pdt_is_instance_of (resolve_bindings_derived, + CLASS_DATA (me_arg)->ts.u.derived)) + || resolve_bindings_derived->attr.pdt_type) && (me_arg->param_list != NULL) && (gfc_spec_list_type (me_arg->param_list, CLASS_DATA(me_arg)->ts.u.derived) diff --git a/gcc/fortran/symbol.cc b/gcc/fortran/symbol.cc index d521bf1012b..5a68f44ca63 100644 --- a/gcc/fortran/symbol.cc +++ b/gcc/fortran/symbol.cc @@ -5467,14 +5467,14 @@ gfc_type_is_extension_of (gfc_symbol *t1, gfc_symbol *t2) gfc_symbol *t2 -> pdt instance to be verified. In decl.cc, gfc_get_pdt_instance, a pdt instance is given a 3 character - prefix "Pdt", followed by an underscore list of the kind parameters, + prefix PDT_PREFIX, followed by an underscore list of the kind parameters, up to a maximum of 8 kind parameters. To verify if a PDT Type corresponds to the template, this functions extracts t2's derive_type name, and compares it to the derive_type name of t1 for compatibility. For example: - t2->name = Pdtf_2_2; extract out the 'f' and compare with t1->name. */ + t2->name = PDT_PREFIXf_2_2; extract the 'f' and compare with t1->name. */ bool gfc_pdt_is_instance_of (gfc_symbol *t1, gfc_symbol *t2) @@ -5483,7 +5483,8 @@ gfc_pdt_is_instance_of (gfc_symbol *t1, gfc_symbol *t2) return false; /* Limit comparison to length of t1->name to ignore new kind params. */ - if ( !(strncmp (&(t2->name[3]), t1->name, strlen (t1->name)) == 0) ) + if ( !(strncmp (&(t2->name[PDT_PREFIX_LEN]), t1->name, + strlen (t1->name)) == 0) ) return false; return true; diff --git a/gcc/testsuite/gfortran.dg/pdt_15.f03 b/gcc/testsuite/gfortran.dg/pdt_15.f03 index 17d4d37d3fa..f7ee691cfce 100644 --- a/gcc/testsuite/gfortran.dg/pdt_15.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_15.f03 @@ -101,6 +101,6 @@ contains if (int (pop_8 (root)) .ne. 0) STOP 4 end subroutine end program ch2701 -! { dg-final { scan-tree-dump-times "Pdtlink_8._deallocate " 5 "original" } } +! { dg-final { scan-tree-dump-times "PDTlink_8._deallocate " 5 "original" } } ! { dg-final { scan-tree-dump-times ".n.data = 0B" 9 "original" } } ! { dg-final { scan-tree-dump-times "__builtin_free" 15 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_71.f03 b/gcc/testsuite/gfortran.dg/pdt_71.f03 index ec9cde06731..06deed6ae15 100644 --- a/gcc/testsuite/gfortran.dg/pdt_71.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_71.f03 @@ -40,5 +40,5 @@ contains print *, kind (z%x%n), z%x%n end subroutine end -! { dg-final { scan-tree-dump-times "Pdtt2_4.1.x.n = 8" 1 "original" } } -! { dg-final { scan-tree-dump-times "z = Pdtt2_4.1" 1 "original" } } +! { dg-final { scan-tree-dump-times "PDTt2_4.1.x.n = 8" 1 "original" } } +! { dg-final { scan-tree-dump-times "z = PDTt2_4.1" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_79.f03 b/gcc/testsuite/gfortran.dg/pdt_79.f03 index 16b40fe6576..68c1810918b 100644 --- a/gcc/testsuite/gfortran.dg/pdt_79.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_79.f03 @@ -57,5 +57,5 @@ contains end subroutine ! { dg-warning ".mapped_tensor. is used uninitialized" } end -! { dg-final { scan-tree-dump-times "Pdttensor_t_4.2.j = 42" 1 "original" } } -! { dg-final { scan-tree-dump-times "struct Pdttensor_t_4 mt" 1 "original" } } +! { dg-final { scan-tree-dump-times "PDTtensor_t_4.2.j = 42" 1 "original" } } +! { dg-final { scan-tree-dump-times "struct PDTtensor_t_4 mt" 1 "original" } } diff --git a/gcc/testsuite/gfortran.dg/pdt_84.f03 b/gcc/testsuite/gfortran.dg/pdt_84.f03 new file mode 100644 index 00000000000..a473cb8137d --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_84.f03 @@ -0,0 +1,28 @@ +! { dg-do compile } +! +! Test the fix for PR108663 +! +! Contributed by +! +module m + type t(n) + integer, len :: n + integer :: a(n) + end type +contains + subroutine s(x, arr) + type(t(2)) :: x + integer :: arr(2) + if (any (x%a /= arr)) stop 1 + end +end +program p + use m, only: t, pdtt, s ! { dg-error "not found in module" } + + type(t(2)) :: y = t(2)([1,2]) + type (pdtt) :: z ! { dg-error "being used before it is defined" } + + call s(y, [1,2]) + y = t(2)([3,4]) + call s(y, [3,4]) +end