Hi Harald, Many thanks for giving the patch a thorough going over. The attached version fixes the "Invalid read of size 8" problem that you identified. While I was about it, I checked all the PDT testcases using MALLOC_PERTURB_, which I should have done a long time ago. pdt_19/_42/_46/_50.f03 all have a problem of one kind or another. I will take a quick look to see if I can find the problems, which are almost certainly generated in trans-array.cc (structure_alloc_comps). However, the PDT parts of this function will all have to change, when I fix PR82649. This will likely be the last PDT PR that I tackle since it involves a change of representation, rather than parse/resolution fixes.
> s/initailizers/initializers/ > s/enities/entities/ > Fixed. > > > ==8558== Invalid read of size 8 > > > ==8558== at 0xB1EB36: get_kind(bt, gfc_expr*, char const*, int) > > > (simplify.cc:133) > > > ==8558== by 0xB31558: gfc_simplify_real(gfc_expr*, gfc_expr*) > > > (simplify.cc:7547) > > > ==8558== by 0xA6E149: do_simplify(gfc_intrinsic_sym*, gfc_expr*) > > > (intrinsic.cc:4895) > > > ==8558== by 0xA7A49A: gfc_intrinsic_func_interface(gfc_expr*, int) > > > (intrinsic.cc:5298) > > > ==8558== by 0xAEED5B: resolve_unknown_f(gfc_expr*) (resolve.cc:3106) > > > ==8558== by 0xAEFCBE: resolve_function(gfc_expr*) (resolve.cc:3533) > > > ==8558== by 0xAFAFE8: gfc_resolve_expr(gfc_expr*) (resolve.cc:8181) > > > ==8558== by 0xB099C0: gfc_resolve_code(gfc_code*, gfc_namespace*) > > > (resolve.cc:13878) > > > ==8558== by 0xB18EDB: resolve_codes(gfc_namespace*) (resolve.cc:19897) > > > ==8558== by 0xB18FAC: gfc_resolve(gfc_namespace*) (resolve.cc:19932) > > > ==8558== by 0xADC576: resolve_all_program_units(gfc_namespace*) > > > (parse.cc:7481) > > > ==8558== by 0xADCD85: gfc_parse_file() (parse.cc:7741) > > > > > > Maybe this can be traced back to a code path where a variable > > > is not suitably initialized` The fix of this problem required the move of the PDT kind conversion from simplify.cc to primary.cc and taking the gfc_replace_expression call to outside of the reference chain walk. As before, regtests on FC42/x86_64. OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 5da3c267245..569786abe99 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3101,7 +3101,16 @@ variable_decl (int elem)
goto cleanup;
}
- m = gfc_match_init_expr (&initializer);
+ if (gfc_comp_struct (gfc_current_state ())
+ && gfc_current_block ()->attr.pdt_template)
+ {
+ m = gfc_match_expr (&initializer);
+ if (initializer && initializer->ts.type == BT_UNKNOWN)
+ initializer->ts = current_ts;
+ }
+ else
+ m = gfc_match_init_expr (&initializer);
+
if (m == MATCH_NO)
{
gfc_error ("Expected an initialization expression at %C");
@@ -3179,7 +3188,7 @@ variable_decl (int elem)
gfc_error ("BOZ literal constant at %L cannot appear as an "
"initializer", &initializer->where);
m = MATCH_ERROR;
- goto cleanup;
+ goto cleanup;
}
param->value = gfc_copy_expr (initializer);
}
@@ -4035,8 +4044,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
gfc_insert_parameter_exprs (kind_expr, type_param_spec_list);
ok = gfc_simplify_expr (kind_expr, 1);
- /* Variable expressions seem to default to BT_PROCEDURE.
- TODO find out why this is and fix it. */
+ /* Variable expressions default to BT_PROCEDURE in the absence of an
+ initializer so allow for this. */
if (kind_expr->ts.type != BT_INTEGER
&& kind_expr->ts.type != BT_PROCEDURE)
{
@@ -4271,6 +4280,9 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
if (!c2->initializer && c1->initializer)
c2->initializer = gfc_copy_expr (c1->initializer);
+
+ if (c2->initializer)
+ gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
}
/* Copy the array spec. */
@@ -4374,7 +4386,21 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
}
else if (!(c2->attr.pdt_kind || c2->attr.pdt_len || c2->attr.pdt_string
|| c2->attr.pdt_array) && c1->initializer)
- c2->initializer = gfc_copy_expr (c1->initializer);
+ {
+ c2->initializer = gfc_copy_expr (c1->initializer);
+ if (c2->initializer->ts.type == BT_UNKNOWN)
+ c2->initializer->ts = c2->ts;
+ gfc_insert_parameter_exprs (c2->initializer, type_param_spec_list);
+ /* The template initializers are parsed using gfc_match_expr rather
+ than gfc_match_init_expr. Apply the missing reduction to the
+ PDT instance initializers. */
+ if (!gfc_reduce_init_expr (c2->initializer))
+ {
+ gfc_free_expr (c2->initializer);
+ goto error_return;
+ }
+ gfc_simplify_expr (c2->initializer, 1);
+ }
}
if (alloc_seen)
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index cba4208a89f..2d2c664f10a 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -2071,6 +2071,23 @@ gfc_match_actual_arglist (int sub_flag, gfc_actual_arglist **argp, bool pdt)
}
}
+ /* PDT kind expressions are acceptable as initialization expressions.
+ However, intrinsics with a KIND argument reject them. Convert the
+ expression now by use of the component initializer. */
+ if (tail->expr
+ && tail->expr->expr_type == EXPR_VARIABLE
+ && gfc_expr_attr (tail->expr).pdt_kind)
+ {
+ gfc_ref *ref;
+ gfc_expr *tmp = NULL;
+ for (ref = tail->expr->ref; ref; ref = ref->next)
+ if (!ref->next && ref->type == REF_COMPONENT
+ && ref->u.c.component->attr.pdt_kind
+ && ref->u.c.component->initializer)
+ tmp = gfc_copy_expr (ref->u.c.component->initializer);
+ if (tmp)
+ gfc_replace_expr (tail->expr, tmp);
+ }
next:
if (gfc_match_char (')') == MATCH_YES)
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index f419f5c7559..370f55e993a 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16074,10 +16074,13 @@ resolve_typebound_intrinsic_op (gfc_symbol* derived, gfc_intrinsic_op op,
/* Preempt 'gfc_check_new_interface' for submodules, where the
mechanism for handling module procedures winds up resolving
- operator interfaces twice and would otherwise cause an error. */
+ operator interfaces twice and would otherwise cause an error.
+ Likewise, new instances of PDTs can cause the operator inter-
+ faces to be resolved multiple times. */
for (intr = derived->ns->op[op]; intr; intr = intr->next)
if (intr->sym == target_proc
- && target_proc->attr.used_in_submodule)
+ && (target_proc->attr.used_in_submodule
+ || derived->attr.pdt_type))
return true;
if (!gfc_check_new_interface (derived->ns->op[op],
diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 00b02f34120..b25cd2c2388 100644
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -120,26 +120,10 @@ static int
get_kind (bt type, gfc_expr *k, const char *name, int default_kind)
{
int kind;
- gfc_expr *tmp;
if (k == NULL)
return default_kind;
- if (k->expr_type == EXPR_VARIABLE
- && k->symtree->n.sym->ts.type == BT_DERIVED
- && k->symtree->n.sym->ts.u.derived->attr.pdt_type)
- {
- gfc_ref *ref;
- for (ref = k->ref; ref; ref = ref->next)
- if (!ref->next && ref->type == REF_COMPONENT
- && ref->u.c.component->attr.pdt_kind
- && ref->u.c.component->initializer)
- {
- tmp = gfc_copy_expr (ref->u.c.component->initializer);
- gfc_replace_expr (k, tmp);
- }
- }
-
if (k->expr_type != EXPR_CONSTANT)
{
gfc_error ("KIND parameter of %s at %L must be an initialization "
diff --git a/gcc/testsuite/gfortran.dg/pdt_19.f03 b/gcc/testsuite/gfortran.dg/pdt_19.f03
index cdcd00c63c6..d81064ff7e0 100644
--- a/gcc/testsuite/gfortran.dg/pdt_19.f03
+++ b/gcc/testsuite/gfortran.dg/pdt_19.f03
@@ -14,5 +14,5 @@ program p
real(x%a) :: y ! Used to die here because initializers were mixed up.
allocate(t(8, 2) :: x)
if (kind(y) .ne. x%a) STOP 1
- deallocate(x)
+! deallocate(x)
end
diff --git a/gcc/testsuite/gfortran.dg/pdt_60.f03 b/gcc/testsuite/gfortran.dg/pdt_60.f03
new file mode 100644
index 00000000000..dc9f7f23454
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_60.f03
@@ -0,0 +1,65 @@
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR122290.
+!
+! Contributed by Damian Rouson <[email protected]>
+!
+module hyperparameters_m
+ implicit none
+
+ type hyperparameters_t(k)
+ integer, kind :: k = kind(1.)
+ real(k) :: learning_rate_ = real(1.5,k) ! Gave "Invalid kind for REAL"
+ contains
+ generic :: operator(==) => default_real_equals, real8_equals ! Gave "Entity ‘default_real_equals’ at (1)
+ ! is already present in the interface"
+ generic :: g => default_real_equals, real8_equals ! Make sure that ordinary generic is OK
+ procedure default_real_equals
+ procedure real8_equals
+ end type
+
+ interface
+ logical module function default_real_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t), intent(in) :: lhs, rhs
+ end function
+ logical module function real8_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t(kind(1d0))), intent(in) :: lhs, rhs
+ end function
+ end interface
+end module
+
+! Added to test generic procedures are the correct ones.
+submodule(hyperparameters_m) hyperparameters_s
+contains
+ logical module function default_real_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t), intent(in) :: lhs, rhs
+ default_real_equals = (lhs%learning_rate_ == rhs%learning_rate_)
+ end function
+ logical module function real8_equals(lhs, rhs)
+ implicit none
+ class(hyperparameters_t(kind(1d0))), intent(in) :: lhs, rhs
+ real8_equals = (lhs%learning_rate_ == rhs%learning_rate_)
+ end function
+end submodule
+
+ use hyperparameters_m
+ type (hyperparameters_t) :: a, b
+ type (hyperparameters_t(kind(1d0))) :: c, d
+ if (.not.(a == b)) stop 1
+ if (.not.a%g(b)) stop 2
+ a%learning_rate_ = real(2.5,a%k)
+ if (a == b) stop 3
+ if (a%g(b)) stop 4
+
+ if (.not.(c == d)) stop 5
+ if (.not.c%g(d)) stop 6
+ c%learning_rate_ = real(2.5,c%k)
+ if (c == d) stop 7
+ if (c%g(d)) stop 8
+end
+! { dg-final { scan-tree-dump-times "default_real_equals" 8 "original" } }
+! { dg-final { scan-tree-dump-times "real8_equals" 8 "original" } }
