From: Paul Thomas Date: Thu, 18 Sep 2025 18:00:08 +0000 (+0100) Subject: Fortran: Implement PDT constructors with syntax variants [PR114815] X-Git-Url: http://git.ipfire.org/?a=commitdiff_plain;h=c52c745c98f846308ad18a6d49da541cebb0a8b3;p=thirdparty%2Fgcc.git 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. --- diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc index 9fe697cd549..99644939056 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 2cb930d83b8..638018bcce3 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 b83961fe6f1..daff3b3e33b 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 1b0a30dca4c..d03e2d139a0 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 cd48364b153..68007689aec 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 00000000000..f3b77d9555f --- /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