Hi All, The real content of this patch is far simpler that the size would seem to imply. I started replacing 8 spaces with tabs in primary.cc and resolve.cc. Once started, I couldn't stop :-) This job will be completed at another time.
The changes listed in the ChangeLog entries for array.cc, decl.cc and gfortran.h are clear of whitespace pollution. primary.cc has only whitespace changes, while the only real content in resolve.cc changes occurs in the chunk at line 1132 in the patch. The chunk in trans-array.cc is at line 1406. The ChangeLogs and comments say everything that needs to be said about the patch. The core content of PRs 102240 and 102686 removes variable and function symbols from the parameter expressions and replaces them with parameter symbols. Likewise, the fix for PR93175 requires that components of PDT type have complete parameter lists, including all parameter names, and that they be applied consistently in structure_alloc_comps. Regtests on FC42/x86_64. OK for mainline? Paul
Change.Logs
Description: Binary data
diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index fa177fa91f7..8f0004992e8 100644
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -566,6 +566,7 @@ match_array_element_spec (gfc_array_spec *as)
gfc_expr **upper, **lower;
match m;
int rank;
+ bool is_pdt_template;
rank = as->rank == -1 ? 0 : as->rank;
lower = &as->lower[rank + as->corank - 1];
@@ -613,6 +614,13 @@ match_array_element_spec (gfc_array_spec *as)
return AS_UNKNOWN;
}
+ is_pdt_template = gfc_current_block ()
+ && gfc_current_block ()->attr.pdt_template
+ && gfc_current_block ()->f2k_derived;
+
+ if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template)
+ gfc_correct_parm_expr (gfc_current_block (), upper);
+
if (gfc_match_char (':') == MATCH_NO)
{
*lower = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
@@ -645,6 +653,9 @@ match_array_element_spec (gfc_array_spec *as)
return AS_UNKNOWN;
}
+ if ((*upper)->expr_type != EXPR_CONSTANT && is_pdt_template)
+ gfc_correct_parm_expr (gfc_current_block (), upper);
+
return AS_EXPLICIT;
}
diff --git a/gcc/fortran/decl.cc b/gcc/fortran/decl.cc
index 3761b6589e8..a64bc0d7941 100644
--- a/gcc/fortran/decl.cc
+++ b/gcc/fortran/decl.cc
@@ -3790,6 +3790,48 @@ match_record_decl (char *name)
}
+ /* 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
@@ -3801,12 +3843,13 @@ insert_parameter_exprs (gfc_expr* e, gfc_symbol* sym ATTRIBUTE_UNUSED,
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)
@@ -4141,7 +4184,7 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
/* 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++;
@@ -4205,20 +4248,6 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
}
}
- /* 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. */
@@ -4283,7 +4312,8 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
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);
@@ -4292,6 +4322,20 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
}
}
+ /* 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)
@@ -4304,15 +4348,18 @@ gfc_get_pdt_instance (gfc_actual_arglist *param_list, gfc_symbol **sym,
/* 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_insert_parameter_exprs (actual_param->expr,
+ type_param_spec_list);
+ gfc_correct_parm_expr (pdt, &actual_param->expr);
+ }
/* 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);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 219c4b67ed8..a14202fda8f 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -3462,6 +3462,7 @@ extern hash_map<nofree_string_hash, int> *gfc_vectorized_builtins;
/* Handling Parameterized Derived Types */
bool gfc_insert_parameter_exprs (gfc_expr *, gfc_actual_arglist *);
+void gfc_correct_parm_expr (gfc_symbol *, gfc_expr **);
match gfc_get_pdt_instance (gfc_actual_arglist *, gfc_symbol **,
gfc_actual_arglist **);
diff --git a/gcc/fortran/primary.cc b/gcc/fortran/primary.cc
index fd03ceace51..aafccb209ab 100644
--- a/gcc/fortran/primary.cc
+++ b/gcc/fortran/primary.cc
@@ -815,7 +815,7 @@ done:
if (gfc_validate_kind (BT_REAL, kind, true) < 0)
{
kind = 10;
- if (gfc_validate_kind (BT_REAL, kind, true) < 0)
+ if (gfc_validate_kind (BT_REAL, kind, true) < 0)
{
gfc_error ("Invalid exponent-letter %<q%> in "
"real-literal-constant at %C");
@@ -2485,7 +2485,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
}
}
else if ((sym->ts.type != BT_DERIVED && sym->ts.type != BT_CLASS)
- && m == MATCH_YES && !inquiry)
+ && m == MATCH_YES && !inquiry)
{
gfc_error ("Unexpected %<%c%> for nonderived-type variable %qs at %C",
peeked_char, sym->name);
@@ -2793,7 +2793,7 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
if (m == MATCH_YES)
primary->expr_type = EXPR_PPC;
- break;
+ break;
}
if (component->as != NULL && !component->attr.proc_pointer)
@@ -3596,41 +3596,40 @@ gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **c
/* F2008, R457/C725, for PURE C1283. */
if (this_comp->attr.pointer && comp_tail->val
&& gfc_is_coindexed (comp_tail->val))
- {
+ {
gfc_error ("Coindexed expression to pointer component %qs in "
"structure constructor at %L", comp_tail->name,
&comp_tail->where);
goto cleanup;
}
- /* If not explicitly a parent constructor, gather up the components
- and build one. */
- if (comp && comp == sym->components
- && sym->attr.extension
- && comp_tail->val
- && (!gfc_bt_struct (comp_tail->val->ts.type)
- ||
- comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
- {
- bool m;
- gfc_actual_arglist *arg_null = NULL;
-
- actual->expr = comp_tail->val;
- comp_tail->val = NULL;
-
- m = gfc_convert_to_structure_constructor (NULL,
+ /* If not explicitly a parent constructor, gather up the components
+ and build one. */
+ if (comp && comp == sym->components
+ && sym->attr.extension
+ && comp_tail->val
+ && (!gfc_bt_struct (comp_tail->val->ts.type)
+ || comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
+ {
+ bool m;
+ gfc_actual_arglist *arg_null = NULL;
+
+ actual->expr = comp_tail->val;
+ comp_tail->val = NULL;
+
+ m = gfc_convert_to_structure_constructor (NULL,
comp->ts.u.derived, &comp_tail->val,
comp->ts.u.derived->attr.zero_comp
? &arg_null : &actual, true);
- if (!m)
- goto cleanup;
+ if (!m)
+ goto cleanup;
- if (comp->ts.u.derived->attr.zero_comp)
- {
- comp = comp->next;
- continue;
- }
- }
+ if (comp->ts.u.derived->attr.zero_comp)
+ {
+ comp = comp->next;
+ continue;
+ }
+ }
if (comp)
comp = comp->next;
@@ -3815,7 +3814,7 @@ gfc_match_rvalue (gfc_expr **result)
if (m == MATCH_YES)
{
if (!gfc_notify_std (GFC_STD_LEGACY, "%%LOC() as an rvalue at %C"))
- return MATCH_ERROR;
+ return MATCH_ERROR;
strncpy (name, "loc", 4);
}
@@ -3823,7 +3822,7 @@ gfc_match_rvalue (gfc_expr **result)
{
m = gfc_match_name (name);
if (m != MATCH_YES)
- return m;
+ return m;
}
/* Check if the symbol exists. */
@@ -3840,15 +3839,14 @@ gfc_match_rvalue (gfc_expr **result)
if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
{
if (gfc_find_state (COMP_INTERFACE)
- && !gfc_current_ns->has_import_set)
- i = gfc_get_sym_tree (name, NULL, &symtree, false);
+ && !gfc_current_ns->has_import_set)
+ i = gfc_get_sym_tree (name, NULL, &symtree, false);
else
- i = gfc_get_ha_sym_tree (name, &symtree);
+ i = gfc_get_ha_sym_tree (name, &symtree);
if (i)
- return MATCH_ERROR;
+ return MATCH_ERROR;
}
-
sym = symtree->n.sym;
e = NULL;
where = gfc_current_locus;
@@ -4181,15 +4179,15 @@ gfc_match_rvalue (gfc_expr **result)
|| sym->intmod_sym_id == ISOCBINDING_F_C_STRING
|| sym->intmod_sym_id == ISOCBINDING_FUNLOC
|| sym->intmod_sym_id == ISOCBINDING_ASSOCIATED)))
- {
- /* make sure we were given a param */
- if (actual_arglist == NULL)
- {
- gfc_error ("Missing argument to %qs at %C", sym->name);
- m = MATCH_ERROR;
- break;
- }
- }
+ {
+ /* make sure we were given a param */
+ if (actual_arglist == NULL)
+ {
+ gfc_error ("Missing argument to %qs at %C", sym->name);
+ m = MATCH_ERROR;
+ break;
+ }
+ }
if (sym->result == NULL)
sym->result = sym;
@@ -4372,12 +4370,12 @@ gfc_match_rvalue (gfc_expr **result)
generic_function:
/* Look for symbol first; if not found, look for STRUCTURE type symbol
- specially. Creates a generic symbol for derived types. */
+ specially. Creates a generic symbol for derived types. */
gfc_find_sym_tree (name, NULL, 1, &symtree);
if (!symtree)
- gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
+ gfc_find_sym_tree (gfc_dt_upper_string (name), NULL, 1, &symtree);
if (!symtree || symtree->n.sym->attr.flavor != FL_STRUCT)
- gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
+ gfc_get_sym_tree (name, NULL, &symtree, false); /* Can't fail */
e = gfc_get_expr ();
e->symtree = symtree;
@@ -4479,8 +4477,8 @@ match_variable (gfc_expr **result, int equiv_flag, int host_flag)
&& (dt_sym = gfc_find_dt_in_generic (sym)))
{
if (dt_sym->attr.flavor == FL_DERIVED)
- gfc_error ("Derived type %qs cannot be used as a variable at %C",
- sym->name);
+ gfc_error ("Derived type %qs cannot be used as a variable at %C",
+ sym->name);
return MATCH_ERROR;
}
diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 00b143c07db..636965fb583 100644
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -347,7 +347,7 @@ gfc_resolve_formal_arglist (gfc_symbol *proc)
if (as && as->rank > 0 && as->type == AS_DEFERRED
&& ((sym->ts.type != BT_CLASS
&& !(sym->attr.pointer || sym->attr.allocatable))
- || (sym->ts.type == BT_CLASS
+ || (sym->ts.type == BT_CLASS
&& !(CLASS_DATA (sym)->attr.class_pointer
|| CLASS_DATA (sym)->attr.allocatable)))
&& sym->attr.flavor != FL_PROCEDURE)
@@ -824,7 +824,7 @@ resolve_entries (gfc_namespace *ns)
!= fts->u.cl->length->expr_type)
|| (ts->u.cl->length
&& ts->u.cl->length->expr_type == EXPR_CONSTANT
- && mpz_cmp (ts->u.cl->length->value.integer,
+ && mpz_cmp (ts->u.cl->length->value.integer,
fts->u.cl->length->value.integer) != 0)))
gfc_notify_std (GFC_STD_GNU, "Function %s at %L with "
"entries returning variables of different "
@@ -1302,9 +1302,9 @@ resolve_structure_cons (gfc_expr *expr, int init)
if (expr->ts.type == BT_DERIVED || expr->ts.type == BT_UNION)
{
if (expr->ts.u.derived->attr.flavor == FL_DERIVED)
- resolve_fl_derived0 (expr->ts.u.derived);
+ resolve_fl_derived0 (expr->ts.u.derived);
else
- resolve_fl_struct (expr->ts.u.derived);
+ resolve_fl_struct (expr->ts.u.derived);
/* If this is a Parameterized Derived Type template, find the
instance corresponding to the PDT kind parameters. */
@@ -1348,10 +1348,10 @@ resolve_structure_cons (gfc_expr *expr, int init)
continue;
/* Unions use an EXPR_NULL contrived expression to tell the translation
- phase to generate an initializer of the appropriate length.
- Ignore it here. */
+ phase to generate an initializer of the appropriate length.
+ Ignore it here. */
if (cons->expr->ts.type == BT_UNION && cons->expr->expr_type == EXPR_NULL)
- continue;
+ continue;
if (!gfc_resolve_expr (cons->expr))
{
@@ -1363,7 +1363,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
if (comp->ts.type == BT_CLASS
&& !comp->ts.u.derived->attr.unlimited_polymorphic
&& CLASS_DATA (comp)->as)
- rank = CLASS_DATA (comp)->as->rank;
+ rank = CLASS_DATA (comp)->as->rank;
if (comp->ts.type == BT_CLASS && cons->expr->ts.type != BT_CLASS)
gfc_find_vtab (&cons->expr->ts);
@@ -1409,7 +1409,7 @@ resolve_structure_cons (gfc_expr *expr, int init)
/* For strings, the length of the constructor should be the same as
the one of the structure, ensure this if the lengths are known at
- compile time and when we are dealing with PARAMETER or structure
+ compile time and when we are dealing with PARAMETER or structure
constructors. */
if (cons->expr->ts.type == BT_CHARACTER
&& comp->ts.type == BT_CHARACTER
@@ -3170,8 +3170,8 @@ gfc_pure_function (gfc_expr *e, const char **name)
*name = NULL;
if (e->symtree != NULL
- && e->symtree->n.sym != NULL
- && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
+ && e->symtree->n.sym != NULL
+ && e->symtree->n.sym->attr.proc == PROC_ST_FUNCTION)
return pure_stmt_function (e, e->symtree->n.sym);
comp = gfc_get_proc_ptr_comp (e);
@@ -3420,7 +3420,7 @@ resolve_function (gfc_expr *expr)
if (expr->value.function.isym && expr->value.function.isym->inquiry)
inquiry_argument = true;
no_formal_args = sym && is_external_proc (sym)
- && gfc_sym_get_dummy_args (sym) == NULL;
+ && gfc_sym_get_dummy_args (sym) == NULL;
if (!resolve_actual_arglist (expr->value.function.actual,
p, no_formal_args))
@@ -4649,7 +4649,7 @@ resolve_operator (gfc_expr *e)
(e->value.op.op == INTRINSIC_AND || e->value.op.op == INTRINSIC_OR))
{
/* Warn about short-circuiting
- with impure function as second operand. */
+ with impure function as second operand. */
bool op2_f = false;
gfc_expr_walker (&op2, impure_function_callback, &op2_f);
}
@@ -5270,7 +5270,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
|| ((comp_stride_zero == CMP_GT || ar->stride[i] == NULL)
&& comp_start_end == CMP_LT)
|| (comp_stride_zero == CMP_LT
- && comp_start_end == CMP_GT))
+ && comp_start_end == CMP_GT))
{
if (compare_bound (AR_START, as->lower[i]) == CMP_LT)
{
@@ -5302,7 +5302,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
"(%ld < %ld) in dimension %d", &ar->c_where[i],
mpz_get_si (last_value),
mpz_get_si (as->lower[i]->value.integer), i+1);
- mpz_clear (last_value);
+ mpz_clear (last_value);
return true;
}
if (compare_bound_mpz_t (as->upper[i], last_value) == CMP_LT)
@@ -5311,7 +5311,7 @@ check_dimension (int i, gfc_array_ref *ar, gfc_array_spec *as)
"(%ld > %ld) in dimension %d", &ar->c_where[i],
mpz_get_si (last_value),
mpz_get_si (as->upper[i]->value.integer), i+1);
- mpz_clear (last_value);
+ mpz_clear (last_value);
return true;
}
}
@@ -5574,7 +5574,7 @@ resolve_array_ref (gfc_array_ref *ar)
check_scalar = ar->dimen_type[i] == DIMEN_RANGE;
/* Do not force gfc_index_integer_kind for the start. We can
- do fine with any integer kind. This avoids temporary arrays
+ do fine with any integer kind. This avoids temporary arrays
created for indexing with a vector. */
if (!gfc_resolve_index_1 (ar->start[i], check_scalar, 0))
return false;
@@ -6979,7 +6979,7 @@ check_host_association (gfc_expr *e)
if (old_sym->attr.flavor == FL_PROCEDURE
|| e->expr_type == EXPR_FUNCTION)
- {
+ {
/* Original was function so point to the new symbol, since
the actual argument list is already attached to the
expression. */
@@ -7024,7 +7024,7 @@ check_host_association (gfc_expr *e)
arg->expr = gfc_copy_expr (ref->u.ar.start[n]);
if (e->value.function.actual == NULL)
tail = e->value.function.actual = arg;
- else
+ else
{
tail->next = arg;
tail = arg;
@@ -7161,7 +7161,7 @@ update_arglist_pass (gfc_actual_arglist* lst, gfc_expr* po, unsigned argpos,
result->expr = po;
result->next = lst;
if (name)
- result->name = name;
+ result->name = name;
return result;
}
@@ -8160,7 +8160,7 @@ gfc_resolve_expr (gfc_expr *e)
character valued function elements to propagate the string length
to the expression. */
if (t && e->ts.type == BT_CHARACTER)
- {
+ {
/* For efficiency, we call gfc_expand_constructor for BT_CHARACTER
here rather then add a duplicate test for it above. */
gfc_expand_constructor (e, false);
@@ -8845,7 +8845,7 @@ resolve_deallocate_expr (gfc_expr *e)
case REF_ARRAY:
if (ref->u.ar.type != AR_FULL
&& !(ref->u.ar.type == AR_ELEMENT && ref->u.ar.as->rank == 0
- && ref->u.ar.codimen && gfc_ref_this_image (ref)))
+ && ref->u.ar.codimen && gfc_ref_this_image (ref)))
allocatable = 0;
break;
@@ -9052,7 +9052,7 @@ conformable_arrays (gfc_expr *e1, gfc_expr *e2)
gfc_error ("Source-expr at %L and allocate-object at %L must "
"have the same shape", &e1->where, &e2->where);
mpz_clear (s);
- return false;
+ return false;
}
}
@@ -9140,8 +9140,8 @@ resolve_allocate_expr (gfc_expr *e, gfc_code *code, bool *array_alloc_wo_spec)
{
switch (ref->type)
{
- case REF_ARRAY:
- if (ref->u.ar.codimen > 0)
+ case REF_ARRAY:
+ if (ref->u.ar.codimen > 0)
{
int n;
for (n = ref->u.ar.dimen;
@@ -11416,7 +11416,7 @@ resolve_select_rank (gfc_code *code, gfc_namespace *old_ns)
}
if (!c->low)
- continue;
+ continue;
/* Check F2018: C1155. */
if (case_value == -1 && (gfc_expr_attr (code->expr1).allocatable
@@ -11595,8 +11595,8 @@ resolve_transfer (gfc_code *code)
if (ts->type == BT_CLASS && dtio_sub == NULL)
{
gfc_error ("Data transfer element at %L cannot be polymorphic unless "
- "it is processed by a defined input/output procedure",
- &code->loc);
+ "it is processed by a defined input/output procedure",
+ &code->loc);
return;
}
@@ -11630,8 +11630,8 @@ resolve_transfer (gfc_code *code)
}
/* C_PTR and C_FUNPTR have private components which means they cannot
- be printed. However, if -std=gnu and not -pedantic, allow
- the component to be printed to help debugging. */
+ be printed. However, if -std=gnu and not -pedantic, allow
+ the component to be printed to help debugging. */
if (ts->u.derived->ts.f90_type == BT_VOID)
{
gfc_error ("Data transfer element at %L "
@@ -12360,11 +12360,11 @@ gfc_count_forall_iterators (gfc_code *code)
while (code)
{
if (code->op == EXEC_FORALL)
- {
- sub_iters = gfc_count_forall_iterators (code);
- if (sub_iters > max_iters)
- max_iters = sub_iters;
- }
+ {
+ sub_iters = gfc_count_forall_iterators (code);
+ if (sub_iters > max_iters)
+ max_iters = sub_iters;
+ }
code = code->next;
}
@@ -12393,7 +12393,7 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
if (forall_save == 0)
{
/* Count the total number of FORALL indices in the nested FORALL
- construct in order to allocate the VAR_EXPR with proper size. */
+ construct in order to allocate the VAR_EXPR with proper size. */
total_var = gfc_count_forall_iterators (code);
/* Allocate VAR_EXPR with NUMBER_OF_FORALL_INDEX elements. */
@@ -12755,7 +12755,7 @@ resolve_ordinary_assign (gfc_code *code, gfc_namespace *ns)
llen = gfc_mpz_get_hwi (lhs->ts.u.cl->length->value.integer);
if (rhs->expr_type == EXPR_CONSTANT)
- rlen = rhs->value.character.length;
+ rlen = rhs->value.character.length;
else if (rhs->ts.u.cl != NULL
&& rhs->ts.u.cl->length != NULL
@@ -13434,8 +13434,8 @@ generate_component_assignments (gfc_code **code, gfc_namespace *ns)
add_comp_ref (this_code->ext.actual->expr, comp1);
/* If the LHS variable is allocatable and wasn't allocated and
- the temporary is allocatable, pointer assign the address of
- the freshly allocated LHS to the temporary. */
+ the temporary is allocatable, pointer assign the address of
+ the freshly allocated LHS to the temporary. */
if ((*code)->expr1->symtree->n.sym->attr.allocatable
&& gfc_expr_attr ((*code)->expr1).allocatable)
{
@@ -13787,7 +13787,7 @@ gfc_resolve_code (gfc_code *code, gfc_namespace *ns)
/* Blocks are handled in resolve_select_type/rank because we
have to transform the SELECT TYPE into ASSOCIATE first. */
break;
- case EXEC_DO_CONCURRENT:
+ case EXEC_DO_CONCURRENT:
gfc_do_concurrent_flag = 1;
gfc_resolve_blocks (code->block, ns);
gfc_do_concurrent_flag = 2;
@@ -14432,7 +14432,7 @@ gfc_verify_binding_labels (gfc_symbol *sym)
gsym->ns = sym->ns;
gsym->mod_name = module;
if (sym->attr.function)
- gsym->type = GSYM_FUNCTION;
+ gsym->type = GSYM_FUNCTION;
else if (sym->attr.subroutine)
gsym->type = GSYM_SUBROUTINE;
/* Mark as variable/procedure as defined, unless its an INTERFACE. */
@@ -14668,8 +14668,8 @@ can_generate_init (gfc_symbol *sym)
|| a->external
|| a->pointer
|| (sym->ts.type == BT_CLASS && CLASS_DATA (sym)
- && (CLASS_DATA (sym)->attr.class_pointer
- || CLASS_DATA (sym)->attr.proc_pointer))
+ && (CLASS_DATA (sym)->attr.class_pointer
+ || CLASS_DATA (sym)->attr.proc_pointer))
|| a->in_equivalence
|| a->in_common
|| a->data
@@ -15365,24 +15365,24 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
if (!verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
sym->common_block))
- {
- /* Clear these to prevent looking at them again if there was an
- error. */
- sym->attr.is_bind_c = 0;
- sym->attr.is_c_interop = 0;
- sym->ts.is_c_interop = 0;
- }
+ {
+ /* Clear these to prevent looking at them again if there was an
+ error. */
+ sym->attr.is_bind_c = 0;
+ sym->attr.is_c_interop = 0;
+ sym->ts.is_c_interop = 0;
+ }
else
- {
- /* So far, no errors have been found. */
- sym->attr.is_c_interop = 1;
- sym->ts.is_c_interop = 1;
- }
+ {
+ /* So far, no errors have been found. */
+ sym->attr.is_c_interop = 1;
+ sym->ts.is_c_interop = 1;
+ }
curr_arg = gfc_sym_get_dummy_args (sym);
while (curr_arg != NULL)
- {
- /* Skip implicitly typed dummy args here. */
+ {
+ /* Skip implicitly typed dummy args here. */
if (curr_arg->sym && curr_arg->sym->attr.implicit_type == 0)
if (!gfc_verify_c_interop_param (curr_arg->sym))
/* If something is found to fail, record the fact so we
@@ -15391,8 +15391,8 @@ resolve_fl_procedure (gfc_symbol *sym, int mp_flag)
reported. */
has_non_interop_arg = 1;
- curr_arg = curr_arg->next;
- }
+ curr_arg = curr_arg->next;
+ }
/* See if any of the arguments were not interoperable and if so, clear
the procedure symbol to prevent duplicate error messages. */
@@ -16308,13 +16308,13 @@ resolve_typebound_procedure (gfc_symtree* stree)
if (resolve_bindings_derived->attr.pdt_template
&& gfc_pdt_is_instance_of (resolve_bindings_derived,
CLASS_DATA (me_arg)->ts.u.derived)
- && (me_arg->param_list != NULL)
- && (gfc_spec_list_type (me_arg->param_list,
+ && (me_arg->param_list != NULL)
+ && (gfc_spec_list_type (me_arg->param_list,
CLASS_DATA(me_arg)->ts.u.derived)
!= SPEC_ASSUMED))
{
- /* Add a check to verify if there are any LEN parameters in the
+ /* Add a check to verify if there are any LEN parameters in the
first place. If there are LEN parameters, throw this error.
If there are only KIND parameters, then don't trigger
this error. */
@@ -16330,10 +16330,10 @@ resolve_typebound_procedure (gfc_symtree* stree)
gcc_assert (c != NULL);
if (c->attr.pdt_kind)
- continue;
+ continue;
/* Getting here implies that there is a pdt_len parameter
- in the list. */
+ in the list. */
seen_len_param = true;
break;
}
@@ -16399,7 +16399,7 @@ resolve_typebound_procedure (gfc_symtree* stree)
/* Try to find a name collision with an inherited component. */
if (super_type && gfc_find_component (super_type, stree->name, true, true,
- NULL))
+ NULL))
{
gfc_error ("Procedure %qs at %L has the same name as an inherited"
" component of %qs",
@@ -16604,7 +16604,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& (!c->attr.allocatable || (c->as && c->as->type != AS_DEFERRED)))
{
gfc_error ("Coarray component %qs at %L must be allocatable with "
- "deferred shape", c->name, &c->loc);
+ "deferred shape", c->name, &c->loc);
return false;
}
@@ -16613,18 +16613,18 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& c->ts.u.derived->ts.is_iso_c)
{
gfc_error ("Component %qs at %L of TYPE(C_PTR) or TYPE(C_FUNPTR) "
- "shall not be a coarray", c->name, &c->loc);
+ "shall not be a coarray", c->name, &c->loc);
return false;
}
/* F2008, C444. */
if (gfc_bt_struct (c->ts.type) && c->ts.u.derived->attr.coarray_comp
&& (c->attr.codimension || c->attr.pointer || c->attr.dimension
- || c->attr.allocatable))
+ || c->attr.allocatable))
{
gfc_error ("Component %qs at %L with coarray component "
- "shall be a nonpointer, nonallocatable scalar",
- c->name, &c->loc);
+ "shall be a nonpointer, nonallocatable scalar",
+ c->name, &c->loc);
return false;
}
@@ -16648,7 +16648,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
if (attr && attr->contiguous && (!attr->dimension || !attr->pointer))
{
gfc_error ("Component %qs at %L has the CONTIGUOUS attribute but "
- "is not an array pointer", c->name, &c->loc);
+ "is not an array pointer", c->name, &c->loc);
return false;
}
@@ -16688,64 +16688,64 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
gfc_symbol *ifc = c->ts.interface;
if (!sym->attr.vtype && !check_proc_interface (ifc, &c->loc))
- {
- c->tb->error = 1;
- return false;
- }
+ {
+ c->tb->error = 1;
+ return false;
+ }
if (ifc->attr.if_source || ifc->attr.intrinsic)
- {
- /* Resolve interface and copy attributes. */
- if (ifc->formal && !ifc->formal_ns)
- resolve_symbol (ifc);
- if (ifc->attr.intrinsic)
- gfc_resolve_intrinsic (ifc, &ifc->declared_at);
-
- if (ifc->result)
- {
- c->ts = ifc->result->ts;
- c->attr.allocatable = ifc->result->attr.allocatable;
- c->attr.pointer = ifc->result->attr.pointer;
- c->attr.dimension = ifc->result->attr.dimension;
- c->as = gfc_copy_array_spec (ifc->result->as);
- c->attr.class_ok = ifc->result->attr.class_ok;
- }
- else
- {
- c->ts = ifc->ts;
- c->attr.allocatable = ifc->attr.allocatable;
- c->attr.pointer = ifc->attr.pointer;
- c->attr.dimension = ifc->attr.dimension;
- c->as = gfc_copy_array_spec (ifc->as);
- c->attr.class_ok = ifc->attr.class_ok;
- }
- c->ts.interface = ifc;
- c->attr.function = ifc->attr.function;
- c->attr.subroutine = ifc->attr.subroutine;
-
- c->attr.pure = ifc->attr.pure;
- c->attr.elemental = ifc->attr.elemental;
- c->attr.recursive = ifc->attr.recursive;
- c->attr.always_explicit = ifc->attr.always_explicit;
- c->attr.ext_attr |= ifc->attr.ext_attr;
- /* Copy char length. */
- if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
- {
- gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
- if (cl->length && !cl->resolved
- && !gfc_resolve_expr (cl->length))
- {
- c->tb->error = 1;
- return false;
- }
- c->ts.u.cl = cl;
- }
- }
+ {
+ /* Resolve interface and copy attributes. */
+ if (ifc->formal && !ifc->formal_ns)
+ resolve_symbol (ifc);
+ if (ifc->attr.intrinsic)
+ gfc_resolve_intrinsic (ifc, &ifc->declared_at);
+
+ if (ifc->result)
+ {
+ c->ts = ifc->result->ts;
+ c->attr.allocatable = ifc->result->attr.allocatable;
+ c->attr.pointer = ifc->result->attr.pointer;
+ c->attr.dimension = ifc->result->attr.dimension;
+ c->as = gfc_copy_array_spec (ifc->result->as);
+ c->attr.class_ok = ifc->result->attr.class_ok;
+ }
+ else
+ {
+ c->ts = ifc->ts;
+ c->attr.allocatable = ifc->attr.allocatable;
+ c->attr.pointer = ifc->attr.pointer;
+ c->attr.dimension = ifc->attr.dimension;
+ c->as = gfc_copy_array_spec (ifc->as);
+ c->attr.class_ok = ifc->attr.class_ok;
+ }
+ c->ts.interface = ifc;
+ c->attr.function = ifc->attr.function;
+ c->attr.subroutine = ifc->attr.subroutine;
+
+ c->attr.pure = ifc->attr.pure;
+ c->attr.elemental = ifc->attr.elemental;
+ c->attr.recursive = ifc->attr.recursive;
+ c->attr.always_explicit = ifc->attr.always_explicit;
+ c->attr.ext_attr |= ifc->attr.ext_attr;
+ /* Copy char length. */
+ if (ifc->ts.type == BT_CHARACTER && ifc->ts.u.cl)
+ {
+ gfc_charlen *cl = gfc_new_charlen (sym->ns, ifc->ts.u.cl);
+ if (cl->length && !cl->resolved
+ && !gfc_resolve_expr (cl->length))
+ {
+ c->tb->error = 1;
+ return false;
+ }
+ c->ts.u.cl = cl;
+ }
+ }
}
else if (c->attr.proc_pointer && c->ts.type == BT_UNKNOWN)
{
/* Since PPCs are not implicitly typed, a PPC without an explicit
- interface must be a subroutine. */
+ interface must be a subroutine. */
gfc_add_subroutine (&c->attr, c->name, &c->loc);
}
@@ -16756,106 +16756,106 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
gfc_symbol* me_arg;
if (c->tb->pass_arg)
- {
- gfc_formal_arglist* i;
-
- /* If an explicit passing argument name is given, walk the arg-list
- and look for it. */
-
- me_arg = NULL;
- c->tb->pass_arg_num = 1;
- for (i = c->ts.interface->formal; i; i = i->next)
- {
- if (!strcmp (i->sym->name, c->tb->pass_arg))
- {
- me_arg = i->sym;
- break;
- }
- c->tb->pass_arg_num++;
- }
-
- if (!me_arg)
- {
- gfc_error ("Procedure pointer component %qs with PASS(%s) "
- "at %L has no argument %qs", c->name,
- c->tb->pass_arg, &c->loc, c->tb->pass_arg);
- c->tb->error = 1;
- return false;
- }
- }
+ {
+ gfc_formal_arglist* i;
+
+ /* If an explicit passing argument name is given, walk the arg-list
+ and look for it. */
+
+ me_arg = NULL;
+ c->tb->pass_arg_num = 1;
+ for (i = c->ts.interface->formal; i; i = i->next)
+ {
+ if (!strcmp (i->sym->name, c->tb->pass_arg))
+ {
+ me_arg = i->sym;
+ break;
+ }
+ c->tb->pass_arg_num++;
+ }
+
+ if (!me_arg)
+ {
+ gfc_error ("Procedure pointer component %qs with PASS(%s) "
+ "at %L has no argument %qs", c->name,
+ c->tb->pass_arg, &c->loc, c->tb->pass_arg);
+ c->tb->error = 1;
+ return false;
+ }
+ }
else
- {
- /* Otherwise, take the first one; there should in fact be at least
- one. */
- c->tb->pass_arg_num = 1;
- if (!c->ts.interface->formal)
- {
- gfc_error ("Procedure pointer component %qs with PASS at %L "
- "must have at least one argument",
- c->name, &c->loc);
- c->tb->error = 1;
- return false;
- }
- me_arg = c->ts.interface->formal->sym;
- }
+ {
+ /* Otherwise, take the first one; there should in fact be at least
+ one. */
+ c->tb->pass_arg_num = 1;
+ if (!c->ts.interface->formal)
+ {
+ gfc_error ("Procedure pointer component %qs with PASS at %L "
+ "must have at least one argument",
+ c->name, &c->loc);
+ c->tb->error = 1;
+ return false;
+ }
+ me_arg = c->ts.interface->formal->sym;
+ }
/* Now check that the argument-type matches. */
gcc_assert (me_arg);
if ((me_arg->ts.type != BT_DERIVED && me_arg->ts.type != BT_CLASS)
- || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
- || (me_arg->ts.type == BT_CLASS
- && CLASS_DATA (me_arg)->ts.u.derived != sym))
- {
- gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
- " the derived type %qs", me_arg->name, c->name,
- me_arg->name, &c->loc, sym->name);
- c->tb->error = 1;
- return false;
- }
+ || (me_arg->ts.type == BT_DERIVED && me_arg->ts.u.derived != sym)
+ || (me_arg->ts.type == BT_CLASS
+ && CLASS_DATA (me_arg)->ts.u.derived != sym))
+ {
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L must be of"
+ " the derived type %qs", me_arg->name, c->name,
+ me_arg->name, &c->loc, sym->name);
+ c->tb->error = 1;
+ return false;
+ }
/* Check for F03:C453. */
if (CLASS_DATA (me_arg)->attr.dimension)
- {
- gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
- "must be scalar", me_arg->name, c->name, me_arg->name,
- &c->loc);
- c->tb->error = 1;
- return false;
- }
+ {
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
+ "must be scalar", me_arg->name, c->name, me_arg->name,
+ &c->loc);
+ c->tb->error = 1;
+ return false;
+ }
if (CLASS_DATA (me_arg)->attr.class_pointer)
- {
- gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
- "may not have the POINTER attribute", me_arg->name,
- c->name, me_arg->name, &c->loc);
- c->tb->error = 1;
- return false;
- }
+ {
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
+ "may not have the POINTER attribute", me_arg->name,
+ c->name, me_arg->name, &c->loc);
+ c->tb->error = 1;
+ return false;
+ }
if (CLASS_DATA (me_arg)->attr.allocatable)
- {
- gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
- "may not be ALLOCATABLE", me_arg->name, c->name,
- me_arg->name, &c->loc);
- c->tb->error = 1;
- return false;
- }
+ {
+ gfc_error ("Argument %qs of %qs with PASS(%s) at %L "
+ "may not be ALLOCATABLE", me_arg->name, c->name,
+ me_arg->name, &c->loc);
+ c->tb->error = 1;
+ return false;
+ }
if (gfc_type_is_extensible (sym) && me_arg->ts.type != BT_CLASS)
- {
- gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
- " at %L", c->name, &c->loc);
- return false;
- }
+ {
+ gfc_error ("Non-polymorphic passed-object dummy argument of %qs"
+ " at %L", c->name, &c->loc);
+ return false;
+ }
}
/* Check type-spec if this is not the parent-type component. */
if (((sym->attr.is_class
- && (!sym->components->ts.u.derived->attr.extension
+ && (!sym->components->ts.u.derived->attr.extension
|| c != CLASS_DATA (sym->components)))
|| (!sym->attr.is_class
- && (!sym->attr.extension || c != sym->components)))
+ && (!sym->attr.extension || c != sym->components)))
&& !sym->attr.vtype
&& !resolve_typespec_used (&c->ts, &c->loc, c->name))
return false;
@@ -16867,7 +16867,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
if (super_type
&& ((sym->attr.is_class
&& c == CLASS_DATA (sym->components))
- || (!sym->attr.is_class && c == sym->components))
+ || (!sym->attr.is_class && c == sym->components))
&& strcmp (super_type->name, c->name) == 0)
c->attr.access = super_type->attr.access;
@@ -16877,27 +16877,30 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
&& 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 "
@@ -16907,7 +16910,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
c->ts.u.cl->length->error = 1;
}
return false;
- }
+ }
}
if (c->ts.type == BT_CHARACTER && c->ts.deferred
@@ -16963,7 +16966,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
{
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.sequence == 0)
{
- gfc_error ("Component %s of SEQUENCE type declared at %L does "
+ gfc_error ("Component %s of SEQUENCE type declared at %L does "
"not have the SEQUENCE attribute",
c->ts.u.derived->name, &sym->declared_at);
return false;
@@ -16973,7 +16976,7 @@ resolve_component (gfc_component *c, gfc_symbol *sym)
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
else if (c->ts.type == BT_CLASS && c->attr.class_ok
- && CLASS_DATA (c)->ts.u.derived->attr.generic)
+ && CLASS_DATA (c)->ts.u.derived->attr.generic)
CLASS_DATA (c)->ts.u.derived
= gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
@@ -17026,7 +17029,7 @@ cons_where (gfc_expr *struct_expr)
for (; cons; cons = gfc_constructor_next (cons))
{
if (cons->expr && cons->expr->expr_type != EXPR_NULL)
- return &cons->expr->where;
+ return &cons->expr->where;
}
return &struct_expr->where;
@@ -17046,17 +17049,17 @@ resolve_fl_struct (gfc_symbol *sym)
if (sym->attr.flavor == FL_UNION)
{
for (c = sym->components; c; c = c->next)
- {
- if (init && c->initializer)
- {
- gfc_error ("Conflicting initializers in union at %L and %L",
- cons_where (init), cons_where (c->initializer));
- gfc_free_expr (c->initializer);
- c->initializer = NULL;
- }
- if (init == NULL)
- init = c->initializer;
- }
+ {
+ if (init && c->initializer)
+ {
+ gfc_error ("Conflicting initializers in union at %L and %L",
+ cons_where (init), cons_where (c->initializer));
+ gfc_free_expr (c->initializer);
+ c->initializer = NULL;
+ }
+ if (init == NULL)
+ init = c->initializer;
+ }
}
success = true;
@@ -17337,7 +17340,7 @@ resolve_fl_namelist (gfc_symbol *sym)
/* Check again, the check in match only works if NAMELIST comes
after the decl. */
if (nl->sym->as && nl->sym->as->type == AS_ASSUMED_SIZE)
- {
+ {
gfc_error ("Assumed size array %qs in namelist %qs at %L is not "
"allowed", nl->sym->name, sym->name, &sym->declared_at);
return false;
@@ -17452,7 +17455,7 @@ resolve_fl_parameter (gfc_symbol *sym)
/* A parameter array's shape needs to be constant. */
if (sym->as != NULL
&& (sym->as->type == AS_DEFERRED
- || is_non_constant_shape_array (sym)))
+ || is_non_constant_shape_array (sym)))
{
gfc_error ("Parameter array %qs at %L cannot be automatic "
"or of deferred shape", sym->name, &sym->declared_at);
@@ -17698,10 +17701,10 @@ skip_interfaces:
{
if (sym->attr.external)
gfc_error ("PROTECTED attribute conflicts with EXTERNAL attribute "
- "at %L", &sym->declared_at);
+ "at %L", &sym->declared_at);
else
gfc_error ("PROCEDURE attribute conflicts with PROTECTED attribute "
- "at %L", &sym->declared_at);
+ "at %L", &sym->declared_at);
return;
}
@@ -17718,7 +17721,7 @@ skip_interfaces:
return;
else if ((sym->attr.flavor == FL_STRUCT || sym->attr.flavor == FL_UNION)
- && !resolve_fl_struct (sym))
+ && !resolve_fl_struct (sym))
return;
/* Symbols that are module procedures with results (functions) have
@@ -17987,14 +17990,14 @@ skip_interfaces:
}
if (sym->attr.allocatable || sym->attr.codimension
|| sym->attr.pointer || sym->attr.value)
- {
+ {
gfc_error ("Assumed-type variable %s at %L may not have the "
"ALLOCATABLE, CODIMENSION, POINTER or VALUE attribute",
sym->name, &sym->declared_at);
return;
}
if (sym->attr.intent == INTENT_OUT)
- {
+ {
gfc_error ("Assumed-type variable %s at %L may not have the "
"INTENT(OUT) attribute",
sym->name, &sym->declared_at);
@@ -18043,40 +18046,40 @@ skip_interfaces:
t = false;
}
else if (sym->common_head != NULL && sym->attr.implicit_type == 0)
- {
- t = verify_com_block_vars_c_interop (sym->common_head);
- }
+ {
+ t = verify_com_block_vars_c_interop (sym->common_head);
+ }
else if (sym->attr.implicit_type == 0)
{
/* If type() declaration, we need to verify that the components
of the given type are all C interoperable, etc. */
if (sym->ts.type == BT_DERIVED &&
- sym->ts.u.derived->attr.is_c_interop != 1)
- {
- /* Make sure the user marked the derived type as BIND(C). If
- not, call the verify routine. This could print an error
- for the derived type more than once if multiple variables
- of that type are declared. */
- if (sym->ts.u.derived->attr.is_bind_c != 1)
- verify_bind_c_derived_type (sym->ts.u.derived);
- t = false;
- }
+ sym->ts.u.derived->attr.is_c_interop != 1)
+ {
+ /* Make sure the user marked the derived type as BIND(C). If
+ not, call the verify routine. This could print an error
+ for the derived type more than once if multiple variables
+ of that type are declared. */
+ if (sym->ts.u.derived->attr.is_bind_c != 1)
+ verify_bind_c_derived_type (sym->ts.u.derived);
+ t = false;
+ }
/* Verify the variable itself as C interoperable if it
- is BIND(C). It is not possible for this to succeed if
- the verify_bind_c_derived_type failed, so don't have to handle
- any error returned by verify_bind_c_derived_type. */
- t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
- sym->common_block);
+ is BIND(C). It is not possible for this to succeed if
+ the verify_bind_c_derived_type failed, so don't have to handle
+ any error returned by verify_bind_c_derived_type. */
+ t = verify_bind_c_sym (sym, &(sym->ts), sym->attr.in_common,
+ sym->common_block);
}
if (!t)
- {
- /* clear the is_bind_c flag to prevent reporting errors more than
- once if something failed. */
- sym->attr.is_bind_c = 0;
- return;
- }
+ {
+ /* clear the is_bind_c flag to prevent reporting errors more than
+ once if something failed. */
+ sym->attr.is_bind_c = 0;
+ return;
+ }
}
/* If a derived type symbol has reached this point, without its
@@ -18105,7 +18108,7 @@ skip_interfaces:
&& sym->ts.u.derived->attr.use_assoc
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE
- && !resolve_fl_derived (sym->ts.u.derived))
+ && !resolve_fl_derived (sym->ts.u.derived))
return;
/* Unless the derived-type declaration is use associated, Fortran 95
@@ -18198,7 +18201,7 @@ skip_interfaces:
&& (sym->attr.result || sym->result == sym))
{
gfc_error ("Function result %qs at %L shall not be a coarray or have "
- "a coarray component", sym->name, &sym->declared_at);
+ "a coarray component", sym->name, &sym->declared_at);
return;
}
@@ -18286,8 +18289,8 @@ skip_interfaces:
{
int i;
for (i = 0; gfc_logical_kinds[i].kind; i++)
- if (gfc_logical_kinds[i].kind == sym->ts.kind)
- break;
+ if (gfc_logical_kinds[i].kind == sym->ts.kind)
+ break;
if (!gfc_logical_kinds[i].c_bool && sym->attr.dummy
&& !gfc_notify_std (GFC_STD_GNU, "LOGICAL dummy argument %qs at "
"%L with non-C_Bool kind in BIND(C) procedure "
@@ -19300,7 +19303,7 @@ resolve_equivalence (gfc_equiv *eq)
if (sym->attr.is_protected)
cnt_protected++;
if (cnt_protected > 0 && cnt_protected != object)
- {
+ {
gfc_error ("Either all or none of the objects in the "
"EQUIVALENCE set at %L shall have the "
"PROTECTED attribute",
@@ -19448,8 +19451,8 @@ identical_types:
static bool
flag_fn_result_spec (gfc_expr *expr,
- gfc_symbol *sym,
- int *f ATTRIBUTE_UNUSED)
+ gfc_symbol *sym,
+ int *f ATTRIBUTE_UNUSED)
{
gfc_namespace *ns;
gfc_symbol *s;
diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index db34de44401..b11ef57f981 100644
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -11084,17 +11084,15 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, tree dest,
&& c->ts.u.derived && c->ts.u.derived->attr.pdt_type
&& !(c->attr.pointer || c->attr.allocatable))
{
- bool is_deferred = false;
gfc_actual_arglist *tail = c->param_list;
for (; tail; tail = tail->next)
- if (!tail->expr)
- is_deferred = true;
+ if (tail->expr)
+ gfc_insert_parameter_exprs (tail->expr, pdt_param_list);
- tail = is_deferred ? pdt_param_list : c->param_list;
tmp = gfc_allocate_pdt_comp (c->ts.u.derived, comp,
c->as ? c->as->rank : 0,
- tail);
+ c->param_list);
gfc_add_expr_to_block (&fnblock, tmp);
}
diff --git a/gcc/testsuite/gfortran.dg/pdt_55.f03 b/gcc/testsuite/gfortran.dg/pdt_55.f03
new file mode 100644
index 00000000000..bcdb1518fde
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/pdt_55.f03
@@ -0,0 +1,96 @@
+! { dg-do run }
+!
+! Test fix for PRs 102240, 102686 and 93175.
+!
+! PR102240
+! Contributed by Roland Wirth <[email protected]>
+!
+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 <[email protected]>
+!
+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 <[email protected]>
+!
+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
