From 2d93be8907fa33f8791409490ed06e45de5c8420 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Tue, 2 Sep 2025 21:48:55 +0100 Subject: Fortran: Handle PDTs correctly with unlimited selector [PR87669] 2025-09-02 Paul Thomas gcc/fortran PR fortran/87669 * expr.cc (gfc_spec_list_type): If no LEN components are seen, unconditionally return 'SPEC_ASSUMED'. This suppresses an invalid error in match.cc(gfc_match_type_is). gcc/testsuite/ PR fortran/87669 * gfortran.dg/pdt_42.f03: New test. libgfortran/ PR fortran/87669 * intrinsics/extends_type_of.c (is_extension_of): Use the vptr rather than the hash value to identify the types. --- gcc/fortran/expr.cc | 5 +++- gcc/testsuite/gfortran.dg/pdt_42.f03 | 46 ++++++++++++++++++++++++++++++++++++ 2 files changed, 50 insertions(+), 1 deletion(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_42.f03 (limited to 'gcc') diff --git a/gcc/fortran/expr.cc b/gcc/fortran/expr.cc index b8d04ff..97f931a 100644 --- a/gcc/fortran/expr.cc +++ b/gcc/fortran/expr.cc @@ -5911,6 +5911,7 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) gfc_component *c; bool seen_assumed = false; bool seen_deferred = false; + bool seen_len = false; if (derived == NULL) { @@ -5932,10 +5933,12 @@ gfc_spec_list_type (gfc_actual_arglist *param_list, gfc_symbol *derived) return SPEC_EXPLICIT; seen_assumed = param_list->spec_type == SPEC_ASSUMED; seen_deferred = param_list->spec_type == SPEC_DEFERRED; + if (c->attr.pdt_len) + seen_len = true; if (seen_assumed && seen_deferred) return SPEC_EXPLICIT; } - res = seen_assumed ? SPEC_ASSUMED : SPEC_DEFERRED; + res = (seen_assumed || !seen_len) ? SPEC_ASSUMED : SPEC_DEFERRED; } return res; } diff --git a/gcc/testsuite/gfortran.dg/pdt_42.f03 b/gcc/testsuite/gfortran.dg/pdt_42.f03 new file mode 100644 index 0000000..47743d1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_42.f03 @@ -0,0 +1,46 @@ +! { dg-do run ) +! +! Test the fix for PR87669 in which SELECT TYPE was not identifying the difference +! between derived types with different type kind parameters, when the selector +! is unlimited polymorphic. +! +! Contributed by Etienne Descamps +! +Program Devtest + Type dvtype(k) + Integer, Kind :: k + Real(k) :: a, b, c + End Type dvtype + type(dvtype(8)) :: dv + type(dvtype(4)) :: fv + integer :: ctr = 0 + + dv%a = 1; dv%b = 2; dv%c = 3 + call dvtype_print(dv) + if (ctr /= 2) stop 1 + + fv%a = 1; fv%b = 2; fv%c = 3 + call dvtype_print(fv) + if (ctr /= 0) stop 2 + +Contains + Subroutine dvtype_print(p) + class(*), intent(in) :: p + Select Type(p) + class is (dvtype(4)) + ctr = ctr - 1 + End Select + Select Type(p) + class is (dvtype(8)) + ctr = ctr + 1 + End Select + Select Type(p) + type is (dvtype(4)) + ctr = ctr - 1 + End Select + Select Type(p) + type is (dvtype(8)) + ctr = ctr + 1 + End Select + End Subroutine dvtype_print +End -- cgit v1.1