Hi All, All these patches represent steps towards persuading fiats to build and test successfully. Jerry and I have had all of them on our trees for some weeks now and I think that the time has come for them to be pushed before bit rot sets in. Fiats makes heavy use of PDTs, ASSOCIATE and other modern features that have been a challenge for all the compiler brands, as well as gfortran.
It looks as if there is one big remaining blocker that Damian is working on finding a short reproducer for. In the meantime, I want to get shot of this lot and to tackle some of the more challenging, remaining PDT bugs. While I have submitted the patches in a batch, I promise that I will push them separately :-) Happily, each PR appears as a separate package in alphabetic order of the touched fortran directory members. The fix for PR122693 comprises the chunksarray.cc (gfc_match_array_constructor). In some circumstances processing PDT typespecs leads to a return in a different namespace. The fix is trivial and described in the ChangeLog. That for PR122670 appears in the chunks in decl.cc (gfc_get_pdt_instance) and module.cc (read_module). The latter fixed the original problem by using PDT instances, when the template appears in a USE ONLY statement. The former fixes the corresponding problem for IMPORT statements. Both fixes are straight forward. PR122578 is fixed by the chunks in primary.cc (gfc_match_varspec): Typebound generic procedure or procedure component selector expressions appear frequently in fiats nested ASSOCIATE statements and so it is important to obtain the specific procedure to feed as the selector for the nested ASSOCIATE. In both chunks, attempting resolution of the selector must be done with a copy of the selector expression to prevent the sometimes mutilated expressions that are returned on failure. Selecting candidate expressions for resolution is straightforward. Finally, PR122669 is fixed in resolve.cc (resolve_allocate_deallocate) and involved array allocation with MOLD expressions without an array spec, using an expression with constant bounds. This was fixed by resolving the MOLD expression for each allocate object, rather than as a loop invariant. The fixes all regtest on FC43/x86_64. OK for mainline? Best regards Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index 359d743a632..471f0cb9f3a 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -1344,6 +1344,7 @@ gfc_match_array_constructor (gfc_expr **result)
match m;
const char *end_delim;
bool seen_ts;
+ gfc_namespace *old_ns = gfc_current_ns;
head = NULL;
seen_ts = false;
@@ -1368,6 +1369,8 @@ gfc_match_array_constructor (gfc_expr **result)
/* Try to match an optional "type-spec ::" */
gfc_clear_ts (&ts);
m = gfc_match_type_spec (&ts);
+ gfc_current_ns = old_ns;
+
if (m == MATCH_YES)
{
seen_ts = (gfc_match (" ::") == MATCH_YES);
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 20260ec57ce..dfedb962bad 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3969,6 +3969,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
gfc_expr *kind_expr;
gfc_component *c1, *c2;
match m;
+ gfc_symtree *s = NULL;
type_param_spec_list = NULL;
@@ -4178,10 +4179,29 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
goto error_return;
}
+ /* If we are in an interface body, the instance will not have been imported.
+ Make sure that it is imported implicitly. */
+ s = gfc_find_symtree (gfc_current_ns->sym_root, pdt->name);
+ if (gfc_current_ns->proc_name
+ && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
+ && s && s->import_only && pdt->attr.imported)
+ {
+ s = gfc_find_symtree (gfc_current_ns->sym_root, instance->name);
+ if (!s)
+ {
+ gfc_get_sym_tree (instance->name, gfc_current_ns, &s, false,
+ &gfc_current_locus);
+ s->n.sym = instance;
+ }
+ s->n.sym->attr.imported = 1;
+ s->import_only = 1;
+ }
+
m = MATCH_YES;
if (instance->attr.flavor == FL_DERIVED
- && instance->attr.pdt_type)
+ && instance->attr.pdt_type
+ && instance->components)
{
instance->refs++;
if (ext_param_list)
diff --git a/gcc/fortran/module.cc b/gcc/fortran/module.cc
index 262f72b8e7c..9b845b5d57e 100644
--- a/gcc/fortran/module.cc
+++ b/gcc/fortran/module.cc
@@ -5842,6 +5842,20 @@ read_module (void)
|| startswith (name, "__vtype_")))
p = name;
+ /* Include pdt_types if their associated pdt_template is in a
+ USE, ONLY list. */
+ if (p == NULL && name[0] == 'P'
+ && startswith (name, "Pdt")
+ && module_list)
+ {
+ gfc_use_list *ml = module_list;
+ for (; ml; ml = ml->next)
+ if (ml->rename
+ && !strncmp (&name[3], ml->rename->use_name,
+ strlen (ml->rename->use_name)))
+ p = name;
+ }
+
/* Skip symtree nodes not in an ONLY clause, unless there
is an existing symtree loaded from another USE statement. */
if (p == NULL)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index 729e3b523fa..e5e84e897ff 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2261,6 +2261,32 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
&& !sym->attr.select_rank_temporary)
inferred_type = true;
+ /* Try to resolve a typebound generic procedure so that the associate name
+ has a chance to get a type before being used in a second, nested associate
+ statement. Note that a copy is used for resolution so that failure does
+ not result in a mutilated selector expression further down the line. */
+ if (tgt_expr && !sym->assoc->dangling
+ && tgt_expr->ts.type == BT_UNKNOWN
+ && tgt_expr->symtree
+ && tgt_expr->symtree->n.sym
+ && gfc_expr_attr (tgt_expr).generic
+ && ((sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.pdt_template)
+ || (sym->ts.type == BT_CLASS
+ && CLASS_DATA (sym)->ts.u.derived->attr.pdt_template)))
+ {
+ gfc_expr *cpy = gfc_copy_expr (tgt_expr);
+ if (gfc_resolve_expr (cpy)
+ && cpy->ts.type != BT_UNKNOWN)
+ {
+ gfc_replace_expr (tgt_expr, cpy);
+ sym->ts = tgt_expr->ts;
+ }
+ else
+ gfc_free_expr (cpy);
+ if (gfc_expr_attr (tgt_expr).generic)
+ inferred_type = true;
+ }
+
/* For associate names, we may not yet know whether they are arrays or not.
If the selector expression is unambiguously an array; eg. a full array
or an array section, then the associate name must be an array and we can
@@ -2493,6 +2519,20 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
&& !gfc_find_derived_types (sym, gfc_current_ns, name))
primary->ts.type = BT_UNKNOWN;
+ /* Otherwise try resolving a copy of a component call. If it succeeds,
+ use that for the selector expression. */
+ else if (tgt_expr && tgt_expr->expr_type == EXPR_COMPCALL)
+ {
+ gfc_expr *cpy = gfc_copy_expr (tgt_expr);
+ if (gfc_resolve_expr (cpy))
+ {
+ gfc_replace_expr (tgt_expr, cpy);
+ sym->ts = tgt_expr->ts;
+ }
+ else
+ gfc_free_expr (cpy);
+ }
+
/* An inquiry reference might determine the type, otherwise we have an
error. */
if (sym->ts.type == BT_UNKNOWN && !inquiry)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 9f3ce1d2ad6..c2f53fc9ecc 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -9799,8 +9799,10 @@ done_errmsg:
/* Resolving the expr3 in the loop over all objects to allocate would
execute loop invariant code for each loop item. Therefore do it just
once here. */
+ mpz_t nelem;
if (code->expr3 && code->expr3->mold
- && code->expr3->ts.type == BT_DERIVED)
+ && code->expr3->ts.type == BT_DERIVED
+ && !(code->expr3->ref && gfc_array_size (code->expr3, &nelem)))
{
/* Default initialization via MOLD (non-polymorphic). */
gfc_expr *rhs = gfc_default_initializer (&code->expr3->ts);
diff --git a/gcc/testsuite/gfortran.dg/pdt_72.f03 b/gcc/testsuite/gfortran.dg/pdt_72.f03
new file mode 100644
index 00000000000..57640bd0200
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_72.f03
@@ -0,0 +1,110 @@
+! { dg-do compile }
+!
+! Tests the fix for pr122578, which failed in compilation with the errors
+! shown below.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module tensor_map_m
+ use iso_c_binding, only : c_int
+ implicit none
+
+ type tensor_t(k)
+ integer, kind :: k = kind(1.)
+ real(k), allocatable :: values_(:) ! Error: Cannot convert REAL(0) to REAL(4) at (1)
+ contains
+ generic :: values => default_real_values
+ procedure default_real_values
+ end type
+
+ interface
+ pure module function default_real_values(self) result(tensor_values)
+ implicit none
+ class(tensor_t), intent(in) :: self
+ real, allocatable :: tensor_values(:)
+ end function
+ end interface
+
+ type tensor_map_t(k)
+ integer, kind :: k = kind(1.)
+ real(k), dimension(:), allocatable :: intercept_, slope_
+ contains
+ generic :: map_to_training_range => default_real_map_to_training_range
+ procedure :: default_real_map_to_training_range
+ generic :: map_from_training_range => default_real_map_from_training_range
+ procedure :: default_real_map_from_training_range
+ end type
+
+ interface
+ elemental module function default_real_map_to_training_range(self, tensor) result(normalized_tensor)
+ implicit none
+ class(tensor_map_t), intent(in) :: self
+ type(tensor_t), intent(in) :: tensor
+ type(tensor_t) normalized_tensor
+ end function
+
+ elemental module function default_real_map_from_training_range(self, tensor) result(unnormalized_tensor)
+ implicit none
+ class(tensor_map_t), intent(in) :: self
+ type(tensor_t), intent(in) :: tensor
+ type(tensor_t) unnormalized_tensor
+ end function
+ end interface
+
+ type activation_t
+ integer(c_int) :: selection_
+ contains
+ generic :: evaluate => default_real_evaluate
+ procedure default_real_evaluate
+ end type
+
+ interface
+ elemental module function default_real_evaluate(self, x) result(y)
+ implicit none
+ class(activation_t), intent(in) :: self
+ real, intent(in) :: x
+ real y
+ end function
+ end interface
+
+ type neural_network_t(k)
+ integer, kind :: k = kind(1.)
+ type(tensor_map_t(k)) input_map_, output_map_
+ real(k), allocatable :: weights_(:,:,:), biases_(:,:)
+ integer, allocatable :: nodes_(:)
+ type(activation_t) :: activation_
+ contains
+ generic :: infer => default_real_infer
+ procedure default_real_infer
+ end type
+
+ integer, parameter :: input_layer = 0
+contains
+ elemental function default_real_infer(self, inputs) result(outputs)
+ class(neural_network_t), intent(in) :: self
+ type(tensor_t), intent(in) :: inputs
+ type(tensor_t) outputs
+ real, allocatable :: a(:,:)
+ integer l
+ associate(w => self%weights_, b => self%biases_, n => self%nodes_, output_layer => ubound(self%nodes_,1))
+ allocate(a(maxval(n), input_layer:output_layer))
+ associate(normalized_inputs => self%input_map_%map_to_training_range(inputs))
+ a(1:n(input_layer),input_layer) = normalized_inputs%values() ! Error: Symbol ‘normalized_inputs’
+ ! at (1) has no IMPLICIT type
+
+ end associate
+ feed_forward: &
+ do l = input_layer+1, output_layer
+ associate(z => matmul(w(1:n(l),1:n(l-1),l), a(1:n(l-1),l-1)) + b(1:n(l),l))
+ a(1:n(l),l) = self%activation_%evaluate(z)
+ end associate
+ end do feed_forward
+ associate(normalized_outputs => tensor_t(a(1:n(output_layer), output_layer)))
+ outputs = self%output_map_%map_from_training_range(normalized_outputs) ! Error: Found no matching specific
+ ! binding for the call to the GENERIC
+ ! ‘map_from_training_range’ at (1)
+
+ end associate
+ end associate
+ end function
+end module
diff --git a/gcc/testsuite/gfortran.dg/pdt_73.f03 b/gcc/testsuite/gfortran.dg/pdt_73.f03
new file mode 100644
index 00000000000..63a92342a67
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_73.f03
@@ -0,0 +1,18 @@
+! { dg-do compile }
+!
+! Tests the fix for pr122669, which falied with the error below.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+ implicit none
+ type tensor_t
+ real, allocatable :: values_
+ end type
+ type(tensor_t) :: random_inputs(1)
+ type(tensor_t), allocatable :: outputs(:)
+
+ random_inputs = [tensor_t(1.0)]
+ allocate(outputs, mold=random_inputs) ! Error: Array specification or array-valued
+ ! SOURCE= expression required in ALLOCATE statement at (1)
+ print *, size(outputs)
+end
diff --git a/gcc/testsuite/gfortran.dg/pdt_74.f03 b/gcc/testsuite/gfortran.dg/pdt_74.f03
new file mode 100644
index 00000000000..c12db790bd1
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_74.f03
@@ -0,0 +1,48 @@
+! { dg-do compile }
+!
+! Tests the fix for pr122670, where use only did not compile for PDTs. Also, it
+! was found in the course of developing the fix that import only did not work
+! either.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module tensor_m
+ implicit none
+
+ type tensor_t(k)
+ integer, kind :: k = kind(0.)
+ real(k), allocatable :: value_
+ end type
+
+ interface
+ function myfunc (arg)
+ import tensor_t
+ implicit none
+ type (tensor_t) myfunc
+ type (tensor_t), intent(in) :: arg
+ end function
+ end interface
+
+contains
+ function y(x)
+ type(tensor_t) x, y
+ y = tensor_t(x%value_)
+ end function
+end module
+
+function myfunc (arg)
+ use tensor_m, only : tensor_t
+ implicit none
+ type (tensor_t) myfunc
+ type (tensor_t), intent(in) :: arg
+ myfunc = arg
+ myfunc%value_ = myfunc%value_ * 2.0
+end function
+
+ use tensor_m, only : tensor_t, y, myfunc
+ implicit none
+ type(tensor_t) desired_output
+ desired_output = y(tensor_t(42.))
+ desired_output = myfunc (desired_output)
+ print *, desired_output%value_
+end
diff --git a/gcc/testsuite/gfortran.dg/pdt_75.f03 b/gcc/testsuite/gfortran.dg/pdt_75.f03
new file mode 100644
index 00000000000..f70087136c3
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_75.f03
@@ -0,0 +1,35 @@
+! { dg-do compile }
+!
+! Tests the fix for pr122693, which failed in compilation with the errors
+! shown below.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module tensor_m
+ implicit none
+
+ type tensor_t(k)
+ integer, kind :: k = kind(0.)
+ end type
+
+ interface tensor_t
+ module function tensor(unused_stuff)
+ implicit none
+ real unused_stuff
+ type(tensor_t) tensor
+ end function
+ end interface
+
+end module
+
+ use tensor_m
+ implicit none
+contains
+ function test_passed()
+ logical test_passed
+ type(tensor_t), allocatable :: tensor_array(:)
+ real, parameter :: junk = 0.
+ tensor_array = [tensor_t(junk)] !Error: Symbol ‘junk’ at (1) has no IMPLICIT type
+ test_passed = .false. !Error: ‘test_passed’ at (1) is not a variable
+ end function
+end
