From c52c745c98f846308ad18a6d49da541cebb0a8b3 Mon Sep 17 00:00:00 2001 From: Paul Thomas Date: Thu, 18 Sep 2025 19:00:08 +0100 Subject: [PATCH] Fortran: Implement PDT constructors with syntax variants [PR114815] 2025-09-18 Paul Thomas gcc/fortran PR fortran/114815 * decl.cc (gfc_get_pdt_instance): Copy the contents of 'tb' and not the pointer. * primary.cc (gfc_match_rvalue): If there is only one actual argument list, use if for the type spec parameter values. If this fails try the default type specification values and use the actual arguments for the component values. * resolve.cc (build_init_assign): Don't initialize implicit PDT function results. gcc/testsuite/ PR fortran/114815 * gfortran.dg/pdt_3.f03: Add missing deallocation of 'matrix'. * gfortran.dg/pdt_17.f03: Change dg-error text. * gfortran.dg/pdt_47.f03: New test. --- gcc/fortran/decl.cc | 2 +- gcc/fortran/primary.cc | 53 ++++++++++++++++++++-------- gcc/fortran/resolve.cc | 7 ++++ gcc/testsuite/gfortran.dg/pdt_17.f03 | 2 +- gcc/testsuite/gfortran.dg/pdt_3.f03 | 1 + gcc/testsuite/gfortran.dg/pdt_47.f03 | 50 ++++++++++++++++++++++++++ 6 files changed, 99 insertions(+), 16 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/pdt_47.f03 diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 9fe697cd5498..996449390563 100644 --- a/gcc/fortran/decl.cc +++ b/gcc/fortran/decl.cc @@ -4092,7 +4092,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym, if (c1->tb) { c2->tb = gfc_get_tbp (); - c2->tb = c1->tb; + *c2->tb = *c1->tb; } /* The order of declaration of the type_specs might not be the diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc index 2cb930d83b8c..638018bcce37 100644 --- a/gcc/fortran/primary.cc +++ b/gcc/fortran/primary.cc @@ -4059,7 +4059,7 @@ gfc_match_rvalue (gfc_expr **result) /* Check to see if this is a PDT constructor. The format of these constructors is rather unusual: - name (type_params)(component_values) + name [(type_params)](component_values) where, component_values excludes the type_params. With the present gfortran representation this is rather awkward because the two are not distinguished, other than by their attributes. */ @@ -4074,7 +4074,15 @@ gfc_match_rvalue (gfc_expr **result) gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st); if (pdt_st && pdt_st->n.sym && pdt_st->n.sym->attr.pdt_template) { + bool type_spec_list = false; pdt_sym = pdt_st->n.sym; + gfc_gobble_whitespace (); + /* Look for a second actual arglist. If present, try the first + for the type parameters. Otherwise, or if there is no match, + depend on default values by setting the type parameters to + NULL. */ + if (gfc_peek_ascii_char() == '(') + type_spec_list = true; /* Generate this instance using the type parameters from the first argument list and return the parameter list in @@ -4082,15 +4090,27 @@ gfc_match_rvalue (gfc_expr **result) m = gfc_get_pdt_instance (actual_arglist, &pdt_sym, &ctr_arglist); if (m != MATCH_YES) { - m = MATCH_ERROR; - break; + if (ctr_arglist) + gfc_free_actual_arglist (ctr_arglist); + /* See if all the type parameters have default values. */ + m = gfc_get_pdt_instance (NULL, &pdt_sym, &ctr_arglist); + if (m != MATCH_YES) + { + m = MATCH_NO; + break; + } } - /* Now match the component_values. */ - m = gfc_match_actual_arglist (0, &actual_arglist); - if (m != MATCH_YES) + + /* Now match the component_values if the type parameters were + present. */ + if (type_spec_list) { - m = MATCH_ERROR; - break; + m = gfc_match_actual_arglist (0, &actual_arglist); + if (m != MATCH_YES) + { + m = MATCH_ERROR; + break; + } } /* Make sure that the component names are in place so that this @@ -4104,13 +4124,18 @@ gfc_match_rvalue (gfc_expr **result) tmp = tmp->next; } - gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) , - &symtree); - symtree->n.sym = pdt_sym; - symtree->n.sym->ts.u.derived = pdt_sym; - symtree->n.sym->ts.type = BT_DERIVED; + gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name), + NULL, 1, &symtree); + if (!symtree) + { + gfc_get_ha_sym_tree (gfc_dt_lower_string (pdt_sym->name) , + &symtree); + symtree->n.sym = pdt_sym; + symtree->n.sym->ts.u.derived = pdt_sym; + symtree->n.sym->ts.type = BT_DERIVED; + } - /* Do the appending. */ + /* Append the type_params and the component_values. */ for (tmp = ctr_arglist; tmp && tmp->next;) tmp = tmp->next; tmp->next = actual_arglist; diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc index b83961fe6f10..daff3b3e33ba 100644 --- a/gcc/fortran/resolve.cc +++ b/gcc/fortran/resolve.cc @@ -14613,6 +14613,13 @@ build_init_assign (gfc_symbol *sym, gfc_expr *init) gfc_code *init_st; gfc_namespace *ns = sym->ns; + if (sym->attr.function && sym->result == sym + && sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_type) + { + gfc_free_expr (init); + return; + } + /* Search for the function namespace if this is a contained function without an explicit result. */ if (sym->attr.function && sym == sym->result diff --git a/gcc/testsuite/gfortran.dg/pdt_17.f03 b/gcc/testsuite/gfortran.dg/pdt_17.f03 index 1b0a30dca4cb..d03e2d139a02 100644 --- a/gcc/testsuite/gfortran.dg/pdt_17.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_17.f03 @@ -6,6 +6,6 @@ ! program p type t(a) ! { dg-error "does not have a component" } - integer(kind=t()) :: x ! { dg-error "used before it is defined" } + integer(kind=t()) :: x ! { dg-error "Expected initialization expression" } end type end diff --git a/gcc/testsuite/gfortran.dg/pdt_3.f03 b/gcc/testsuite/gfortran.dg/pdt_3.f03 index cd48364b1534..68007689aec3 100644 --- a/gcc/testsuite/gfortran.dg/pdt_3.f03 +++ b/gcc/testsuite/gfortran.dg/pdt_3.f03 @@ -76,4 +76,5 @@ end module end select deallocate (cz) + deallocate (matrix) end diff --git a/gcc/testsuite/gfortran.dg/pdt_47.f03 b/gcc/testsuite/gfortran.dg/pdt_47.f03 new file mode 100644 index 000000000000..f3b77d9555fc --- /dev/null +++ b/gcc/testsuite/gfortran.dg/pdt_47.f03 @@ -0,0 +1,50 @@ +! { dg-do run } +! +! Test the fix for PR121948, in which the PDT constructor expressions without +! the type specification list, ie. relying on default values, failed. The fix +! also required that the incorrect initialization of functions with implicit +! function result be eliminated. +! +! Contributed by Damian Rouson +! + implicit none + + integer, parameter :: dp = kind(1d0) + real, parameter :: ap = 42.0 + real(dp), parameter :: ap_d = 42.0d0 + + type operands_t(k) + integer, kind :: k = kind(1.) + real(k) :: actual, expected + end type + + type(operands_t) :: x + type(operands_t(dp)) :: y + + x = operands (ap, 10 * ap) + if (abs (x%actual - ap) >1e-5) stop 1 + if (abs (x%expected - 10 * ap) > 1e-5) stop 2 + + + y = operands_dp (ap_d, 10d0 * ap_d) + if (abs (y%actual - ap_d) > 1d-10) stop 3 + if (abs (y%expected - 10d0 * ap_d) > 1d-10) stop 4 + if (kind (y%actual) /= dp) stop 5 + if (kind (y%expected) /= dp) stop 6 + +contains + + function operands(actual, expected) ! Use the default 'k' + real actual, expected + type(operands_t) :: operands + operands = operands_t(actual, expected) + end function + + + function operands_dp(actual, expected) ! Override the default + real(dp) actual, expected + type(operands_t(dp)) :: operands_dp + operands_dp = operands_t(dp)(actual, expected) + end function + +end -- 2.47.3