}
+ /* In parsing a PDT, it is possible that one of the type parameters has the
+ same name as a previously declared symbol that is not a type parameter.
+ Intercept this now by looking for the symtree in f2k_derived. */
+
+static bool
+correct_parm_expr (gfc_expr* e, gfc_symbol* pdt, int* f ATTRIBUTE_UNUSED)
+{
+ if (!e || (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION))
+ return false;
+
+ if (!(e->symtree->n.sym->attr.pdt_len
+ || e->symtree->n.sym->attr.pdt_kind))
+ {
+ gfc_symtree *st;
+ st = gfc_find_symtree (pdt->f2k_derived->sym_root,
+ e->symtree->n.sym->name);
+ if (st && st->n.sym
+ && (st->n.sym->attr.pdt_len || st->n.sym->attr.pdt_kind))
+ {
+ gfc_expr *new_expr;
+ gfc_set_sym_referenced (st->n.sym);
+ new_expr = gfc_get_expr ();
+ new_expr->ts = st->n.sym->ts;
+ new_expr->expr_type = EXPR_VARIABLE;
+ new_expr->symtree = st;
+ new_expr->where = e->where;
+ gfc_replace_expr (e, new_expr);
+ }
+ }
+
+ return false;
+}
+
+
+void
+gfc_correct_parm_expr (gfc_symbol *pdt, gfc_expr **bound)
+{
+ if (!*bound || (*bound)->expr_type == EXPR_CONSTANT)
+ return;
+ gfc_traverse_expr (*bound, pdt, &correct_parm_expr, 0);
+}
+
/* This function uses the gfc_actual_arglist 'type_param_spec_list' as a source
of expressions to substitute into the possibly parameterized expression
'e'. Using a list is inefficient but should not be too bad since the
gfc_actual_arglist *param;
gfc_expr *copy;
- if (e->expr_type != EXPR_VARIABLE)
+ if (e->expr_type != EXPR_VARIABLE && e->expr_type != EXPR_FUNCTION)
return false;
gcc_assert (e->symtree);
if (e->symtree->n.sym->attr.pdt_kind
- || (*f != 0 && e->symtree->n.sym->attr.pdt_len))
+ || (*f != 0 && e->symtree->n.sym->attr.pdt_len)
+ || (e->expr_type == EXPR_FUNCTION && e->symtree->n.sym))
{
for (param = type_param_spec_list; param; param = param->next)
if (strcmp (e->symtree->n.sym->name, param->name) == 0)
/* Now obtain the PDT instance for the extended type. */
c2->param_list = type_param_spec_list;
m = gfc_get_pdt_instance (type_param_spec_list, &c2->ts.u.derived,
- NULL);
+ &c2->param_list);
type_param_spec_list = old_param_spec_list;
c2->ts.u.derived->refs++;
}
}
- /* Similarly, set the string length if parameterized. */
- if (c1->ts.type == BT_CHARACTER
- && c1->ts.u.cl->length
- && gfc_derived_parameter_expr (c1->ts.u.cl->length))
- {
- gfc_expr *e;
- e = gfc_copy_expr (c1->ts.u.cl->length);
- gfc_insert_kind_parameter_exprs (e);
- gfc_simplify_expr (e, 1);
- c2->ts.u.cl = gfc_new_charlen (gfc_current_ns, NULL);
- c2->ts.u.cl->length = e;
- c2->attr.pdt_string = 1;
- }
-
/* Set up either the KIND/LEN initializer, if constant,
or the parameterized expression. Use the template
initializer if one is not already set in this instance. */
gfc_free_expr (c2->as->upper[i]);
c2->as->upper[i] = e;
}
- c2->attr.pdt_array = pdt_array ? 1 : c2->attr.pdt_string;
+
+ c2->attr.pdt_array = 1;
if (c1->initializer)
{
c2->initializer = gfc_copy_expr (c1->initializer);
}
}
+ /* Similarly, set the string length if parameterized. */
+ if (c1->ts.type == BT_CHARACTER
+ && c1->ts.u.cl->length
+ && gfc_derived_parameter_expr (c1->ts.u.cl->length))
+ {
+ gfc_expr *e;
+ e = gfc_copy_expr (c1->ts.u.cl->length);
+ gfc_insert_kind_parameter_exprs (e);
+ gfc_simplify_expr (e, 1);
+ gfc_free_expr (c2->ts.u.cl->length);
+ c2->ts.u.cl->length = e;
+ c2->attr.pdt_string = 1;
+ }
+
/* Recurse into this function for PDT components. */
if ((c1->ts.type == BT_DERIVED || c1->ts.type == BT_CLASS)
&& c1->ts.u.derived && c1->ts.u.derived->attr.pdt_template)
/* Substitute the template parameters with the expressions
from the specification list. */
for (;actual_param; actual_param = actual_param->next)
- gfc_insert_parameter_exprs (actual_param->expr,
- type_param_spec_list);
+ {
+ gfc_correct_parm_expr (pdt, &actual_param->expr);
+ gfc_insert_parameter_exprs (actual_param->expr,
+ type_param_spec_list);
+ }
/* Now obtain the PDT instance for the component. */
old_param_spec_list = type_param_spec_list;
- m = gfc_get_pdt_instance (params, &c2->ts.u.derived, NULL);
+ m = gfc_get_pdt_instance (params, &c2->ts.u.derived,
+ &c2->param_list);
type_param_spec_list = old_param_spec_list;
- c2->param_list = params;
if (!(c2->attr.pointer || c2->attr.allocatable))
c2->initializer = gfc_default_initializer (&c2->ts);
&& gfc_find_typebound_proc (super_type, NULL, c->name, true, NULL))
{
gfc_error ("Component %qs of %qs at %L has the same name as an"
- " inherited type-bound procedure",
- c->name, sym->name, &c->loc);
+ " inherited type-bound procedure",
+ c->name, sym->name, &c->loc);
return false;
}
if (c->ts.type == BT_CHARACTER && !c->attr.proc_pointer
&& !c->ts.deferred)
{
+ if (sym->attr.pdt_template || c->attr.pdt_string)
+ gfc_correct_parm_expr (sym, &c->ts.u.cl->length);
+
if (c->ts.u.cl->length == NULL
- || (!resolve_charlen(c->ts.u.cl))
+ || !resolve_charlen(c->ts.u.cl)
|| !gfc_is_constant_expr (c->ts.u.cl->length))
{
gfc_error ("Character length of component %qs needs to "
"be a constant specification expression at %L",
c->name,
c->ts.u.cl->length ? &c->ts.u.cl->length->where : &c->loc);
- return false;
- }
+ return false;
+ }
if (c->ts.u.cl->length && c->ts.u.cl->length->ts.type != BT_INTEGER)
- {
+ {
if (!c->ts.u.cl->length->error)
{
gfc_error ("Character length expression of component %qs at %L "
--- /dev/null
+! { dg-do run }
+!
+! Test fix for PRs 102240, 102686 and 93175.
+!
+! PR102240
+! Contributed by Roland Wirth <roland_wirth@web.de>
+!
+MODULE m1
+ IMPLICIT NONE
+ private
+ public r
+ INTEGER :: n0, n ! Symbols that confused the parameter substitution.
+ type t0(m0,n0)
+ INTEGER, kind :: m0
+ INTEGER, LEN :: n0
+ INTEGER(kind=m0) :: a0(n0*2)
+ end type t0
+
+ TYPE t(m,n)
+ INTEGER, kind :: m
+ INTEGER, LEN :: n
+ INTEGER(kind=m) :: a(n/8:(n/2 + 4))
+ type(t0(m,n)) :: p ! During testing, getting this to work fixed PR93175.
+ END TYPE t
+contains
+ subroutine r
+ type (t(kind(1_8), 8)) :: x
+ x%a = [1,2,3,4,5,6,7,8]
+ if (kind (x%a) /= kind(1_8)) stop 1
+ if (sum (x%a) /= 36_8) stop 2
+ if (size(x%p%a0) /= 16) stop 3
+ end
+END
+
+! PR102686
+! Contributed by Gerhard Steinmetz <gscfq@t-online.de>
+!
+module m2
+ implicit none
+ private
+ public s
+contains
+ pure integer function n() ! Confused the parameter substitution.
+ n = 1
+ end
+ subroutine s
+ type t(n)
+ integer, len :: n = 2
+ character(len=n) :: c ! ICE because function n() referenced rather than parameter.
+ end type
+ type (t(4)) :: c_type, c_type2
+ c_type = t(4)("abcd")
+ if (len (c_type%c) /= 4) stop 4
+ if (c_type%c /= "abcd") stop 5
+ c_type2%c = "efgh"
+ if (len (c_type2%c) /= 4) stop 6
+ if (c_type2%c /= "efgh") stop 7
+ end
+end
+
+! PR93175
+! Contributed by Rich Townsend <townsend@astro.wisc.edu>
+!
+module m3
+ private
+ public u
+ type :: matrix (k,n)
+ integer, kind :: k
+ integer, len :: n
+ real(k) :: a(n,n)
+ end type matrix
+
+ type :: problem(n)
+ integer, len :: n
+ type(matrix(kind(0.D0),n)) :: m
+ end type problem
+
+contains
+ subroutine u
+ implicit none
+ type(problem(2)) :: p
+
+ p%m%a = 1.
+ if (p%n /= 2) stop 8
+ if (p%m%n /= 2) stop 9
+ if (int (sum (p%m%a)) /= 4) stop 10
+ end subroutine
+end module m3
+
+ use m1
+ use m2
+ use m3
+ call r
+ call s
+ call u
+end
projects / thirdparty / gcc.git / commitdiff
