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");
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);
}
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)
{
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. */
}
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)
}
}
+ /* 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)
/* 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],
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 "
--- /dev/null
+! { dg-do compile }
+! { dg-options "-fdump-tree-original" }
+!
+! Test the fix for PR122290.
+!
+! Contributed by Damian Rouson <damian@archaeologic.codes>
+!
+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" } }
projects / thirdparty / gcc.git / commitdiff
