On 15/07/2012 21:13, Tobias Burnus wrote:
> Hello,
>
> attached is an updated version of the patch. Changes:
>
Updated version of comments:
> diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
> index c3644b6..959a57b 100644
> --- a/gcc/fortran/decl.c
> +++ b/gcc/fortran/decl.c
> @@ -594,7 +594,7 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec
> *to, bool copy)
> {
> int i;
>
> - if (to->rank == 0 && from->rank > 0)
> + if (to->rank == 0 && from->rank != 0)
> {
> to->rank = from->rank;
> to->type = from->type;
I'm not sure it is relevant to support assumed rank here, as it is
mutually exclusive with codimensions.
If it is, I think there may be a problem as we are using from->rank to
index lower and upper bounds, which is bogus if from->rank == -1.
Maybe add:
gcc_assert (from->rank != -1 || to->corank == 0);
> @@ -622,20 +622,24 @@ merge_array_spec (gfc_array_spec *from, gfc_array_spec
> *to, bool copy)
> }
> else if (to->corank == 0 && from->corank > 0)
> {
> + int rank;
> +
> to->corank = from->corank;
> to->cotype = from->cotype;
>
> + rank = to->rank == -1 ? 0 : to->rank;
> +
> for (i = 0; i < from->corank; i++)
> {
> if (copy)
> {
> - to->lower[to->rank + i] = gfc_copy_expr (from->lower[i]);
> - to->upper[to->rank + i] = gfc_copy_expr (from->upper[i]);
> + to->lower[rank + i] = gfc_copy_expr (from->lower[i]);
> + to->upper[rank + i] = gfc_copy_expr (from->upper[i]);
> }
> else
> {
> - to->lower[to->rank + i] = from->lower[i];
> - to->upper[to->rank + i] = from->upper[i];
> + to->lower[rank + i] = from->lower[i];
> + to->upper[rank + i] = from->upper[i];
> }
> }
> }
Access to lower and upper bounds is OK, but again maybe we could
just assert here.
> diff --git a/gcc/fortran/interface.c b/gcc/fortran/interface.c
> index 6f40ba7..64efbcb 100644
> --- a/gcc/fortran/interface.c
> +++ b/gcc/fortran/interface.c
> @@ -1743,7 +1752,7 @@ compare_parameter (gfc_symbol *formal, gfc_expr *actual,
> }
>
> /* F2008, 12.5.2.5; IR F08/0073. */
> - if (formal->ts.type == BT_CLASS
> + if (formal->ts.type == BT_CLASS && actual->expr_type != EXPR_NULL
> && ((CLASS_DATA (formal)->attr.class_pointer
> && !formal->attr.intent == INTENT_IN)
> || CLASS_DATA (formal)->attr.allocatable))
About this hunk, ...
> @@ -2289,11 +2299,21 @@ compare_actual_formal (gfc_actual_arglist **ap,
> gfc_formal_arglist *formal,
> return 0;
> }
>
> - if (a->expr->expr_type == EXPR_NULL && !f->sym->attr.pointer
> - && (f->sym->attr.allocatable || !f->sym->attr.optional
> - || (gfc_option.allow_std & GFC_STD_F2008) == 0))
> - {
> - if (where && (f->sym->attr.allocatable || !f->sym->attr.optional))
> + if (a->expr->expr_type == EXPR_NULL
> + && ((f->sym->ts.type != BT_CLASS && !f->sym->attr.pointer
> + && (f->sym->attr.allocatable || !f->sym->attr.optional
> + || (gfc_option.allow_std & GFC_STD_F2008) == 0))
> + || (f->sym->ts.type == BT_CLASS
> + && !CLASS_DATA (f->sym)->attr.class_pointer
> + && (CLASS_DATA (f->sym)->attr.allocatable
> + || !f->sym->attr.optional
> + || (gfc_option.allow_std & GFC_STD_F2008) == 0))))
> + {
> + if (where
> + && (!f->sym->attr.optional
> + || (f->sym->ts.type != BT_CLASS && f->sym->attr.allocatable)
> + || (f->sym->ts.type == BT_CLASS
> + && CLASS_DATA (f->sym)->attr.allocatable)))
> gfc_error ("Unexpected NULL() intrinsic at %L to dummy '%s'",
> where, f->sym->name);
> else if (where)
... this hunk, ...
> diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
> index 5be1857..3534e63 100644
> --- a/gcc/fortran/resolve.c
> +++ b/gcc/fortran/resolve.c
> @@ -284,23 +286,34 @@ resolve_formal_arglist (gfc_symbol *proc)
> gfc_set_default_type (sym, 1, sym->ns);
> }
>
> - gfc_resolve_array_spec (sym->as, 0);
> + as = sym->ts.type == BT_CLASS && sym->attr.class_ok
> + ? CLASS_DATA (sym)->as : sym->as;
> +
> + gfc_resolve_array_spec (as, 0);
>
> /* We can't tell if an array with dimension (:) is assumed or deferred
> shape until we know if it has the pointer or allocatable attributes.
> */
> - if (sym->as && sym->as->rank > 0 && sym->as->type == AS_DEFERRED
> - && !(sym->attr.pointer || sym->attr.allocatable)
> + 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
> + && !(CLASS_DATA (sym)->attr.class_pointer
> + || CLASS_DATA (sym)->attr.allocatable)))
> && sym->attr.flavor != FL_PROCEDURE)
> {
> - sym->as->type = AS_ASSUMED_SHAPE;
> - for (i = 0; i < sym->as->rank; i++)
> - sym->as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind,
> - NULL, 1);
> + as->type = AS_ASSUMED_SHAPE;
> + for (i = 0; i < as->rank; i++)
> + as->lower[i] = gfc_get_int_expr (gfc_default_integer_kind, NULL, 1);
> }
>
> - if ((sym->as && sym->as->rank > 0 && sym->as->type == AS_ASSUMED_SHAPE)
> + if ((as && as->rank > 0 && as->type == AS_ASSUMED_SHAPE)
> + || (as && as->type == AS_ASSUMED_RANK)
> || sym->attr.pointer || sym->attr.allocatable || sym->attr.target
> + || (sym->ts.type == BT_CLASS && sym->attr.class_ok
> + && (CLASS_DATA (sym)->attr.class_pointer
> + || CLASS_DATA (sym)->attr.allocatable
> + || CLASS_DATA (sym)->attr.target))
> || sym->attr.optional)
> {
> proc->attr.always_explicit = 1;
... this hunk with the AS_ASSUMED_RANK line removed, ...
> diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> index 34e0f69..7ec40b1 100644
> --- a/gcc/fortran/trans-expr.c
> +++ b/gcc/fortran/trans-expr.c
> @@ -3620,10 +3741,15 @@ gfc_conv_procedure_call (gfc_se * se,
gfc_symbol * sym,
> parmse.string_length = build_int_cst (gfc_charlen_type_node, 0);
> }
> }
> - else if (arg->expr->expr_type == EXPR_NULL && fsym &&
> !fsym->attr.pointer)
> + else if (arg->expr->expr_type == EXPR_NULL
> + && fsym && !fsym->attr.pointer
> + && (fsym->ts.type != BT_CLASS
> + || !CLASS_DATA (fsym)->attr.class_pointer))
> {
> /* Pass a NULL pointer to denote an absent arg. */
> - gcc_assert (fsym->attr.optional && !fsym->attr.allocatable);
> + gcc_assert (fsym->attr.optional && !fsym->attr.allocatable
> + && (fsym->ts.type != BT_CLASS
> + || !CLASS_DATA (fsym)->attr.allocatable));
> gfc_init_se (&parmse, NULL);
> parmse.expr = null_pointer_node;
> if (arg->missing_arg_type == BT_CHARACTER)
... and this hunk:
The four of them are not directly related to the assumed rank stuff, and
thus deserve a separate commit.
As you said:
> * Unrelated bug fixes, found when writing the test cases and thus
included:
I assume they don't need testcases of their own, so that they are
approved as is.
> @@ -10332,10 +10408,10 @@ resolve_fl_var_and_proc (gfc_symbol *sym, int
> mp_flag)
> return FAILURE;
> }
>
> - if (pointer && dimension)
> + if (pointer && dimension && as->type != AS_ASSUMED_RANK)
> {
> - gfc_error ("Array pointer '%s' at %L must have a deferred shape",
> - sym->name, &sym->declared_at);
> + gfc_error ("Array pointer '%s' at %L must have a deferred shape or "
> + "deferred rank", sym->name, &sym->declared_at);
> return FAILURE;
> }
> }
s/deferred rank/assumed rank/ ?
> diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
> index 34e0f69..7ec40b1 100644
> --- a/gcc/fortran/trans-expr.c
> +++ b/gcc/fortran/trans-expr.c
> @@ -3808,7 +3936,23 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
> gfc_add_expr_to_block (&se->pre, tmp);
> }
>
> - if (fsym && e->expr_type != EXPR_NULL
> + /* Wrap scalar variable in a descriptor. We need to convert
> + the address of a pointer back to the pointer itself before,
> + we can assign it to the data field. */
> +
> + if (fsym && fsym->as && fsym->as->type == AS_ASSUMED_RANK
> + && fsym->ts.type != BT_CLASS && e->expr_type != EXPR_NULL)
> + {
> + tmp = parmse.expr;
> + if (TREE_CODE (tmp) == ADDR_EXPR
> + && POINTER_TYPE_P (TREE_TYPE (TREE_OPERAND (tmp, 0))))
This looks fragile. If you have {tmp = &ptr; value = tmp;} instead of
{value = &ptr;} it doesn't work anymore.
You can rely on fsym->attr.{pointer,allocatable,...) instead, or can't you?
> + tmp = TREE_OPERAND (tmp, 0);
> + parmse.expr = conv_scalar_to_descriptor (se, tmp,
> + fsym->attr);
> + parmse.expr = gfc_build_addr_expr (NULL_TREE,
> + parmse.expr);
> + }
> + else if (fsym && e->expr_type != EXPR_NULL
> && ((fsym->attr.pointer
> && fsym->attr.flavor != FL_PROCEDURE)
> || (fsym->attr.proc_pointer
Now about:
> Mikael Morin wrote:
>> What about naming the flag in_actual_arg and moving the
>> inquiry_argument condition to the error condition?
>
> That doesn't work as it is not only valid as inquiry argument but also
> for other actual arguments – those which have an assumed-type or
> assumed-rank dummy argument.
>
I didn't mean changing the semantics.
This assumed_type_rank_allowed flag is cleared in a function, set in
another, and used in a third, which makes it difficult to understand
what it does (the name, initially OK, doesn't help when assumed rank
gets in the mix). I was proposing using some flags (as I don't see how
to do without) with more trivial meaning, and get to the same result by
assembling them.
I attach a patch showing what I had in mind. I think it is equivalent;
it passes your assumed rank testcases at least. As a cherry on the cake,
it brings a small diagnostic improvement regarding assumed type/rank and
inquiry functions. Let's hope you like the wording.
As second attachment, there is a patch restoring the flags in case of
failure, as that was making me uncomfortable.
I'm regression testing them, and if they work and are fine to you, let's
go with these patches.
Regarding the assumed rank patch, it is in pretty good shape. I think
modulo the few nits outlined above, it is ready to go in.
Mikael
diff --git a/resolve.c b/resolve.c
index 10593ac..ccaa098 100644
--- a/resolve.c
+++ b/resolve.c
@@ -64,8 +64,13 @@ static code_stack *cs_base = NULL;
static int forall_flag;
static int do_concurrent_flag;
-/* Nonzero for assumed rank and for assumed type. */
-static bool assumed_rank_type_expr_allowed = false;
+/* True when we are resolving an expression that is an actual argument to
+ a procedure. */
+static bool actual_arg = false;
+/* True when we are resolving an expression that is the first actual argument
+ to a procedure. */
+static bool first_actual_arg = false;
+
/* Nonzero if we're inside a OpenMP WORKSHARE or PARALLEL WORKSHARE block. */
@@ -87,6 +92,7 @@ static bitmap_obstack labels_obstack;
/* True when simplifying a EXPR_VARIABLE argument to an inquiry function. */
static bool inquiry_argument = false;
+
int
gfc_is_formal_arg (void)
{
@@ -1612,8 +1618,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
+ bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
- assumed_rank_type_expr_allowed = true;
+ actual_arg = true;
+ first_actual_arg = true;
for (; arg; arg = arg->next)
{
@@ -1630,6 +1638,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
return FAILURE;
}
}
+ first_actual_arg = false;
continue;
}
@@ -1847,17 +1856,10 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
return FAILURE;
}
- /* TS29113, C407b and C535b: Assumed-type and assumed-rank are only
- allowed for the first argument.
- Cf. http://j3-fortran.org/pipermail/j3/2012-June/005419.html
- FIXME: It doesn't work reliably as inquiry_argument is not set
- for all inquiry functions in resolve_function; the reason is that
- the function-name resolution happens too late in that function. */
- if (inquiry_argument)
- assumed_rank_type_expr_allowed = false;
-
+ first_actual_arg = false;
}
- assumed_rank_type_expr_allowed = false;
+ actual_arg = actual_arg_sav;
+ first_actual_arg = first_actual_arg_sav;
return SUCCESS;
}
@@ -5109,33 +5111,60 @@ resolve_variable (gfc_expr *e)
sym = e->symtree->n.sym;
/* TS 29113, 407b. */
- if (e->ts.type == BT_ASSUMED && !assumed_rank_type_expr_allowed)
+ if (e->ts.type == BT_ASSUMED)
{
- gfc_error ("Invalid expression with assumed-type variable %s at %L",
- sym->name, &e->where);
- return FAILURE;
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-type variable %s at %L may only be used "
+ "as actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-type variable %s at %L as actual argument to "
+ "an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
}
/* TS 29113, C535b. */
- if (((sym->ts.type == BT_CLASS && sym->attr.class_ok
+ if ((sym->ts.type == BT_CLASS && sym->attr.class_ok
&& CLASS_DATA (sym)->as
&& CLASS_DATA (sym)->as->type == AS_ASSUMED_RANK)
|| (sym->ts.type != BT_CLASS && sym->as
&& sym->as->type == AS_ASSUMED_RANK))
- && !assumed_rank_type_expr_allowed)
{
- gfc_error ("Assumed-rank variable %s at %L may only be used as actual "
- "argument", sym->name, &e->where);
- return FAILURE;
+ if (!actual_arg)
+ {
+ gfc_error ("Assumed-rank variable %s at %L may only be used as "
+ "actual argument", sym->name, &e->where);
+ return FAILURE;
+ }
+ else if (inquiry_argument && !first_actual_arg)
+ {
+ /* FIXME: It doesn't work reliably as inquiry_argument is not set
+ for all inquiry functions in resolve_function; the reason is
+ that the function-name resolution happens too late in that
+ function. */
+ gfc_error ("Assumed-rank variable %s at %L as actual argument "
+ "to an inquiry function shall be the first argument",
+ sym->name, &e->where);
+ return FAILURE;
+ }
}
/* TS 29113, 407b. */
if (e->ts.type == BT_ASSUMED && e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
- && e->ref->next == NULL))
+ && e->ref->next == NULL))
{
- gfc_error ("Assumed-type variable %s with designator at %L",
- sym->name, &e->ref->u.ar.where);
+ gfc_error ("Assumed-type variable %s at %L shall not have a subobject "
+ "reference", sym->name, &e->ref->u.ar.where);
return FAILURE;
}
@@ -5147,7 +5176,7 @@ resolve_variable (gfc_expr *e)
&& sym->as->type == AS_ASSUMED_RANK))
&& e->ref
&& !(e->ref->type == REF_ARRAY && e->ref->u.ar.type == AR_FULL
- && e->ref->next == NULL))
+ && e->ref->next == NULL))
{
gfc_error ("Assumed-rank variable %s at %L shall not have a subobject "
"reference", sym->name, &e->ref->u.ar.where);
@@ -6365,19 +6394,21 @@ gfc_try
gfc_resolve_expr (gfc_expr *e)
{
gfc_try t;
- bool inquiry_save, assumed_rank_type_save;
+ bool inquiry_save, actual_arg_save, first_actual_arg_save;
if (e == NULL)
return SUCCESS;
/* inquiry_argument only applies to variables. */
inquiry_save = inquiry_argument;
- assumed_rank_type_save = assumed_rank_type_expr_allowed;
+ actual_arg_save = actual_arg;
+ first_actual_arg_save = first_actual_arg;
if (e->expr_type != EXPR_VARIABLE)
{
inquiry_argument = false;
- assumed_rank_type_expr_allowed = false;
+ actual_arg = false;
+ first_actual_arg = false;
}
switch (e->expr_type)
@@ -6468,7 +6499,8 @@ gfc_resolve_expr (gfc_expr *e)
fixup_charlen (e);
inquiry_argument = inquiry_save;
- assumed_rank_type_expr_allowed = assumed_rank_type_save;
+ actual_arg = actual_arg_save;
+ first_actual_arg = first_actual_arg_save;
return t;
}
diff --git a/resolve.c b/resolve.c
index ccaa098..76a1e2c 100644
--- a/resolve.c
+++ b/resolve.c
@@ -1618,6 +1618,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_symtree *parent_st;
gfc_expr *e;
int save_need_full_assumed_size;
+ gfc_try return_value = FAILURE;
bool actual_arg_sav = actual_arg, first_actual_arg_sav = first_actual_arg;
actual_arg = true;
@@ -1635,7 +1636,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Label %d referenced at %L is never defined",
arg->label->value, &arg->label->where);
- return FAILURE;
+ goto cleanup;
}
}
first_actual_arg = false;
@@ -1646,7 +1647,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
&& e->symtree->n.sym->attr.generic
&& no_formal_args
&& count_specific_procs (e) != 1)
- return FAILURE;
+ goto cleanup;
if (e->ts.type != BT_PROCEDURE)
{
@@ -1654,7 +1655,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
goto argument_list;
}
@@ -1698,7 +1699,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
"Fortran 2008: Internal procedure '%s' is"
" used as actual argument at %L",
sym->name, &e->where) == FAILURE)
- return FAILURE;
+ goto cleanup;
}
if (sym->attr.elemental && !sym->attr.intrinsic)
@@ -1711,8 +1712,8 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
/* Check if a generic interface has a specific procedure
with the same name before emitting an error. */
if (sym->attr.generic && count_specific_procs (e) != 1)
- return FAILURE;
-
+ goto cleanup;
+
/* Just in case a specific was found for the expression. */
sym = e->symtree->n.sym;
@@ -1733,7 +1734,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
gfc_error ("Unable to find a specific INTRINSIC procedure "
"for the reference '%s' at %L", sym->name,
&e->where);
- return FAILURE;
+ goto cleanup;
}
sym->ts = isym->ts;
sym->attr.intrinsic = 1;
@@ -1741,7 +1742,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
}
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
@@ -1753,7 +1754,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (gfc_find_sym_tree (sym->name, sym->ns->parent, 1, &parent_st))
{
gfc_error ("Symbol '%s' at %L is ambiguous", sym->name, &e->where);
- return FAILURE;
+ goto cleanup;
}
if (parent_st == NULL)
@@ -1767,7 +1768,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
|| sym->attr.external)
{
if (gfc_resolve_expr (e) == FAILURE)
- return FAILURE;
+ goto cleanup;
goto argument_list;
}
@@ -1795,7 +1796,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
if (e->expr_type != EXPR_VARIABLE)
need_full_assumed_size = 0;
if (gfc_resolve_expr (e) != SUCCESS)
- return FAILURE;
+ goto cleanup;
need_full_assumed_size = save_need_full_assumed_size;
argument_list:
@@ -1809,14 +1810,14 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not of numeric "
"type", &e->where);
- return FAILURE;
+ goto cleanup;
}
if (e->rank)
{
gfc_error ("By-value argument at %L cannot be an array or "
"an array section", &e->where);
- return FAILURE;
+ goto cleanup;
}
/* Intrinsics are still PROC_UNKNOWN here. However,
@@ -1830,7 +1831,7 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("By-value argument at %L is not allowed "
"in this context", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
@@ -1842,26 +1843,30 @@ resolve_actual_arglist (gfc_actual_arglist *arg, procedure_type ptype,
{
gfc_error ("Passing internal procedure at %L by location "
"not allowed", &e->where);
- return FAILURE;
+ goto cleanup;
}
}
}
/* Fortran 2008, C1237. */
if (e->expr_type == EXPR_VARIABLE && gfc_is_coindexed (e)
- && gfc_has_ultimate_pointer (e))
- {
- gfc_error ("Coindexed actual argument at %L with ultimate pointer "
+ && gfc_has_ultimate_pointer (e))
+ {
+ gfc_error ("Coindexed actual argument at %L with ultimate pointer "
"component", &e->where);
- return FAILURE;
- }
+ goto cleanup;
+ }
first_actual_arg = false;
}
+
+ return_value = SUCCESS;
+
+cleanup:
actual_arg = actual_arg_sav;
first_actual_arg = first_actual_arg_sav;
- return SUCCESS;
+ return return_value;
}
