Hi All, It turned out that attempting to pick out specific interfaces for PDT constructors in primary.cc was way too early. This caused a problem in ASSOCIATE blocks simply because the associate name and its selector are not usable until resolution.
This patch detects the presence of more than one symbol in the generic interface and the absence of a second arglist to defer the selection of the appropriate specific constructor until resolution. The changes are straightforward as are the tests. Regtested on FC43/x86_64. OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 1dcb1c3b561..496ee45294e 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -3543,7 +3543,7 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
}
/* Find the current component in the structure definition and check
- its access is not private. */
+ its access is not private. */
if (comp)
this_comp = gfc_find_component (sym, comp->name, false, false, NULL);
else
@@ -3836,8 +3836,6 @@ gfc_match_rvalue (gfc_expr **result)
bool implicit_char;
gfc_ref *ref;
gfc_symtree *pdt_st;
- gfc_symbol *found_specific = NULL;
-
m = gfc_match ("%%loc");
if (m == MATCH_YES)
@@ -4085,29 +4083,21 @@ gfc_match_rvalue (gfc_expr **result)
break;
}
- gfc_gobble_whitespace ();
- found_specific = NULL;
-
- /* Even if 'name' is that of a PDT template, priority has to be given to
- possible specific procedures in the generic interface. */
- gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
- if (sym->generic && sym->generic->next
- && gfc_peek_ascii_char() != '(')
- {
- gfc_actual_arglist *arg = actual_arglist;
- for (; arg && pdt_st; arg = arg->next)
- gfc_resolve_expr (arg->expr);
- found_specific = gfc_search_interface (sym->generic, 0,
- &actual_arglist);
- }
-
/* Check to see if this is a PDT constructor. The format of these
constructors is rather unusual:
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. */
- if (sym->attr.generic && pdt_st != NULL && found_specific == NULL)
+ distinguished, other than by their attributes.
+
+ Even if 'name' is that of a PDT template, priority has to be given to
+ specific procedures, other than the constructor, in the generic
+ interface. */
+
+ gfc_gobble_whitespace ();
+ gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &pdt_st);
+ if (sym->attr.generic && pdt_st != NULL
+ && !(sym->generic->next && gfc_peek_ascii_char() != '('))
{
gfc_symbol *pdt_sym;
gfc_actual_arglist *ctr_arglist = NULL, *tmp;
@@ -4172,12 +4162,8 @@ gfc_match_rvalue (gfc_expr **result)
tmp = tmp->next;
}
- if (found_specific)
- gfc_find_sym_tree (found_specific->name,
- NULL, 1, &symtree);
- else
- gfc_find_sym_tree (gfc_dt_lower_string (pdt_sym->name),
- NULL, 1, &symtree);
+ 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) ,
diff --git a/gcc/testsuite/gfortran.dg/pdt_66.f03 b/gcc/testsuite/gfortran.dg/pdt_66.f03
new file mode 100644
index 00000000000..269f6b451a1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_66.f03
@@ -0,0 +1,54 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Check the fix for PR122501.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module tensor_m
+ implicit none
+
+ type tensor_t(k)
+ integer, kind :: k = kind(1.)
+ real(k), allocatable, private :: values_(:)
+ contains
+ procedure default_real_values
+ end type
+
+ interface tensor_t
+ type(tensor_t) module function construct_default_real(values)
+ implicit none
+ real values(:)
+ end function
+ end interface
+
+ interface
+ module function default_real_values(self) result(tensor_values)
+ implicit none
+ class(tensor_t) self
+ real, allocatable :: tensor_values(:)
+ end function
+ end interface
+end module
+
+ use tensor_m
+ implicit none
+contains
+ function copy(tensor)
+ type(tensor_t) tensor, copy, norm_copy
+ associate(tensor_values => tensor%default_real_values())
+
+! This gave: "Component ‘values_’ at (1) is a PRIVATE component of ‘tensor_t’"
+ copy = tensor_t(tensor_values)
+
+ end associate
+
+! Make sure that the fix really works :-)
+ associate(f => tensor%default_real_values())
+ associate(tensor_values => tensor%default_real_values())
+ norm_copy = tensor_t(tensor_values/maxval(f))
+ end associate
+ end associate
+ end function
+end
+! { dg-final { scan-tree-dump-times "default_real_values" 3 "original" } }
diff --git a/gcc/testsuite/gfortran.dg/pdt_67.f03 b/gcc/testsuite/gfortran.dg/pdt_67.f03
new file mode 100644
index 00000000000..b59d20140ce
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_67.f03
@@ -0,0 +1,36 @@
+! { dg-do compile }
+!
+! Check the fix for PR122524.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module tensor_map_m
+ implicit none
+
+ type tensor_t(k)
+ integer, kind :: k = kind(1.)
+ real(k), allocatable :: values_(:)
+ end type
+
+ interface tensor_t
+ module function tensor(values)
+ implicit none
+ double precision values(:)
+ type(tensor_t(kind(0D0))) tensor
+ end function
+ end interface
+
+ type tensor_map_t(k)
+ integer, kind :: k = kind(1.)
+ real(k) slope_
+ end type
+
+contains
+ function unnormalized_tensor(self, tensor)
+ type(tensor_map_t(kind(0D0))) self
+ type(tensor_t(kind(0D0))) tensor, unnormalized_tensor
+ associate(unnormalized_values => tensor%values_*self%slope_)
+ unnormalized_tensor = tensor_t(unnormalized_values) ! Caused an ICE.
+ end associate
+ end function
+end module
