re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr))
2010-08-15 Daniel Kraft <d@domob.eu> PR fortran/38936 * gfortran.h (gfc_find_proc_namespace): New method. * expr.c (gfc_build_intrinsic_call): No need to build symtree messing around with namespace. * symbol.c (gfc_find_proc_namespace): New method. * trans-decl.c (gfc_build_qualified_array): Use it for correct value of nest. * primary.c (gfc_match_varspec): Handle associate-names as arrays. * parse.c (parse_associate): Removed assignment-generation here... * resolve.c (resolve_block_construct): ...and added it here. (resolve_variable): Handle names that are arrays but were not parsed as such because of association. (resolve_code): Fix BLOCK resolution. (resolve_symbol): Generate array-spec for associate-names. 2010-08-15 Daniel Kraft <d@domob.eu> PR fortran/38936 * gfortran.dg/associate_1.f03: Enable test for array expressions. * gfortran.dg/associate_3.f03: Clarify comment. * gfortran.dg/associate_5.f03: New test. * gfortran.dg/associate_6.f03: New test. From-SVN: r163268
This commit is contained in:
Daniel Kraft
Daniel Kraft
parent
5fc265c14f
commit
52bf62f96b
|
|
@ -1,3 +1,20 @@
|
|||
2010-08-15 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/38936
|
||||
* gfortran.h (gfc_find_proc_namespace): New method.
|
||||
* expr.c (gfc_build_intrinsic_call): No need to build symtree messing
|
||||
around with namespace.
|
||||
* symbol.c (gfc_find_proc_namespace): New method.
|
||||
* trans-decl.c (gfc_build_qualified_array): Use it for correct
|
||||
value of nest.
|
||||
* primary.c (gfc_match_varspec): Handle associate-names as arrays.
|
||||
* parse.c (parse_associate): Removed assignment-generation here...
|
||||
* resolve.c (resolve_block_construct): ...and added it here.
|
||||
(resolve_variable): Handle names that are arrays but were not parsed
|
||||
as such because of association.
|
||||
(resolve_code): Fix BLOCK resolution.
|
||||
(resolve_symbol): Generate array-spec for associate-names.
|
||||
|
||||
2010-08-15 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/45211
|
||||
|
|
|
|||
|
|
@ -4221,7 +4221,6 @@ gfc_build_intrinsic_call (const char* name, locus where, unsigned numarg, ...)
|
|||
result->expr_type = EXPR_FUNCTION;
|
||||
result->ts = isym->ts;
|
||||
result->where = where;
|
||||
gfc_get_ha_sym_tree (isym->name, &result->symtree);
|
||||
result->value.function.name = name;
|
||||
result->value.function.isym = isym;
|
||||
|
||||
|
|
|
|||
|
|
@ -2577,6 +2577,7 @@ void gfc_copy_formal_args_ppc (gfc_component *, gfc_symbol *);
|
|||
void gfc_free_finalizer (gfc_finalizer *el); /* Needed in resolve.c, too */
|
||||
|
||||
gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
|
||||
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
|
||||
|
||||
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
|
||||
extern bool gfc_init_expr_flag;
|
||||
|
|
|
|||
|
|
@ -3206,7 +3206,6 @@ parse_associate (void)
|
|||
gfc_state_data s;
|
||||
gfc_statement st;
|
||||
gfc_association_list* a;
|
||||
gfc_code* assignTail;
|
||||
|
||||
gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
|
||||
|
||||
|
|
@ -3216,46 +3215,24 @@ parse_associate (void)
|
|||
new_st.ext.block.ns = my_ns;
|
||||
gcc_assert (new_st.ext.block.assoc);
|
||||
|
||||
/* Add all associations to expressions as BLOCK variables, and create
|
||||
assignments to them giving their values. */
|
||||
/* Add all associate-names as BLOCK variables. There values will be assigned
|
||||
to them during resolution of the ASSOCIATE construct. */
|
||||
gfc_current_ns = my_ns;
|
||||
assignTail = NULL;
|
||||
for (a = new_st.ext.block.assoc; a; a = a->next)
|
||||
if (!a->variable)
|
||||
{
|
||||
gfc_code* newAssign;
|
||||
{
|
||||
if (a->variable)
|
||||
{
|
||||
gfc_error ("Association to variables is not yet supported at %C");
|
||||
return;
|
||||
}
|
||||
|
||||
if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
|
||||
gcc_unreachable ();
|
||||
if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
|
||||
gcc_unreachable ();
|
||||
|
||||
/* Note that in certain cases, the target-expression's type is not yet
|
||||
known and so we have to adapt the symbol's ts also during resolution
|
||||
for these cases. */
|
||||
a->st->n.sym->ts = a->target->ts;
|
||||
a->st->n.sym->attr.flavor = FL_VARIABLE;
|
||||
a->st->n.sym->assoc = a;
|
||||
gfc_set_sym_referenced (a->st->n.sym);
|
||||
|
||||
/* Create the assignment to calculate the expression and set it. */
|
||||
newAssign = gfc_get_code ();
|
||||
newAssign->op = EXEC_ASSIGN;
|
||||
newAssign->loc = gfc_current_locus;
|
||||
newAssign->expr1 = gfc_get_variable_expr (a->st);
|
||||
newAssign->expr2 = a->target;
|
||||
|
||||
/* Hang it in. */
|
||||
if (assignTail)
|
||||
assignTail->next = newAssign;
|
||||
else
|
||||
gfc_current_ns->code = newAssign;
|
||||
assignTail = newAssign;
|
||||
}
|
||||
else
|
||||
{
|
||||
gfc_error ("Association to variables is not yet supported at %C");
|
||||
return;
|
||||
}
|
||||
gcc_assert (assignTail);
|
||||
a->st->n.sym->attr.flavor = FL_VARIABLE;
|
||||
a->st->n.sym->assoc = a;
|
||||
gfc_set_sym_referenced (a->st->n.sym);
|
||||
}
|
||||
|
||||
accept_statement (ST_ASSOCIATE);
|
||||
push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
|
||||
|
|
@ -3269,7 +3246,7 @@ loop:
|
|||
|
||||
case_end:
|
||||
accept_statement (st);
|
||||
assignTail->next = gfc_state_stack->head;
|
||||
my_ns->code = gfc_state_stack->head;
|
||||
break;
|
||||
|
||||
default:
|
||||
|
|
|
|||
|
|
@ -1748,6 +1748,13 @@ gfc_match_varspec (gfc_expr *primary, int equiv_flag, bool sub_flag,
|
|||
}
|
||||
}
|
||||
|
||||
/* For associate names, we may not yet know whether they are arrays or not.
|
||||
Thus if we have one and parentheses follow, we have to assume that it
|
||||
actually is one for now. The final decision will be made at
|
||||
resolution time, of course. */
|
||||
if (sym->assoc && gfc_peek_ascii_char () == '(')
|
||||
sym->attr.dimension = 1;
|
||||
|
||||
if ((equiv_flag && gfc_peek_ascii_char () == '(')
|
||||
|| gfc_peek_ascii_char () == '[' || sym->attr.codimension
|
||||
|| (sym->attr.dimension && !sym->attr.proc_pointer
|
||||
|
|
|
|||
|
|
@ -4814,11 +4814,26 @@ resolve_variable (gfc_expr *e)
|
|||
|
||||
if (e->symtree == NULL)
|
||||
return FAILURE;
|
||||
sym = e->symtree->n.sym;
|
||||
|
||||
/* If this is an associate-name, it may be parsed with references in error
|
||||
even though the target is scalar. Fail directly in this case. */
|
||||
if (sym->assoc && !sym->attr.dimension && e->ref)
|
||||
return FAILURE;
|
||||
|
||||
/* On the other hand, the parser may not have known this is an array;
|
||||
in this case, we have to add a FULL reference. */
|
||||
if (sym->assoc && sym->attr.dimension && !e->ref)
|
||||
{
|
||||
e->ref = gfc_get_ref ();
|
||||
e->ref->type = REF_ARRAY;
|
||||
e->ref->u.ar.type = AR_FULL;
|
||||
e->ref->u.ar.dimen = 0;
|
||||
}
|
||||
|
||||
if (e->ref && resolve_ref (e) == FAILURE)
|
||||
return FAILURE;
|
||||
|
||||
sym = e->symtree->n.sym;
|
||||
if (sym->attr.flavor == FL_PROCEDURE
|
||||
&& (!sym->attr.function
|
||||
|| (sym->attr.function && sym->result
|
||||
|
|
@ -8276,11 +8291,43 @@ gfc_resolve_forall (gfc_code *code, gfc_namespace *ns, int forall_save)
|
|||
static void
|
||||
resolve_block_construct (gfc_code* code)
|
||||
{
|
||||
/* For an ASSOCIATE block, the associations (and their targets) are already
|
||||
resolved during gfc_resolve_symbol. */
|
||||
|
||||
/* Resolve the BLOCK's namespace. */
|
||||
gfc_resolve (code->ext.block.ns);
|
||||
|
||||
/* For an ASSOCIATE block, the associations (and their targets) are already
|
||||
resolved during gfc_resolve_symbol. Here, we have to add code
|
||||
to assign expression values to the variables associated to expressions. */
|
||||
if (code->ext.block.assoc)
|
||||
{
|
||||
gfc_association_list* a;
|
||||
gfc_code* assignTail;
|
||||
gfc_code* assignHead;
|
||||
|
||||
assignHead = assignTail = NULL;
|
||||
for (a = code->ext.block.assoc; a; a = a->next)
|
||||
if (!a->variable)
|
||||
{
|
||||
gfc_code* newAssign;
|
||||
|
||||
newAssign = gfc_get_code ();
|
||||
newAssign->op = EXEC_ASSIGN;
|
||||
newAssign->loc = gfc_current_locus;
|
||||
newAssign->expr1 = gfc_lval_expr_from_sym (a->st->n.sym);
|
||||
newAssign->expr2 = a->target;
|
||||
|
||||
if (!assignHead)
|
||||
assignHead = newAssign;
|
||||
else
|
||||
{
|
||||
gcc_assert (assignTail);
|
||||
assignTail->next = newAssign;
|
||||
}
|
||||
assignTail = newAssign;
|
||||
}
|
||||
|
||||
assignTail->next = code->ext.block.ns->code;
|
||||
code->ext.block.ns->code = assignHead;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -8765,7 +8812,7 @@ resolve_code (gfc_code *code, gfc_namespace *ns)
|
|||
break;
|
||||
|
||||
case EXEC_BLOCK:
|
||||
gfc_resolve (code->ext.block.ns);
|
||||
resolve_block_construct (code);
|
||||
break;
|
||||
|
||||
case EXEC_DO:
|
||||
|
|
@ -11651,6 +11698,54 @@ resolve_symbol (gfc_symbol *sym)
|
|||
|
||||
sym->ts = sym->assoc->target->ts;
|
||||
gcc_assert (sym->ts.type != BT_UNKNOWN);
|
||||
|
||||
if (sym->attr.dimension && sym->assoc->target->rank == 0)
|
||||
{
|
||||
gfc_error ("Associate-name '%s' at %L is used as array",
|
||||
sym->name, &sym->declared_at);
|
||||
sym->attr.dimension = 0;
|
||||
return;
|
||||
}
|
||||
if (sym->assoc->target->rank > 0)
|
||||
sym->attr.dimension = 1;
|
||||
|
||||
if (sym->attr.dimension)
|
||||
{
|
||||
int dim;
|
||||
|
||||
sym->as = gfc_get_array_spec ();
|
||||
sym->as->rank = sym->assoc->target->rank;
|
||||
sym->as->type = AS_EXPLICIT;
|
||||
|
||||
/* Target must not be coindexed, thus the associate-variable
|
||||
has no corank. */
|
||||
sym->as->corank = 0;
|
||||
|
||||
for (dim = 0; dim < sym->assoc->target->rank; ++dim)
|
||||
{
|
||||
gfc_expr* dim_expr;
|
||||
gfc_expr* e;
|
||||
|
||||
dim_expr = gfc_get_constant_expr (BT_INTEGER,
|
||||
gfc_default_integer_kind,
|
||||
&sym->declared_at);
|
||||
mpz_set_si (dim_expr->value.integer, dim + 1);
|
||||
|
||||
e = gfc_build_intrinsic_call ("lbound", sym->declared_at, 3,
|
||||
gfc_copy_expr (sym->assoc->target),
|
||||
gfc_copy_expr (dim_expr), NULL);
|
||||
gfc_resolve_expr (e);
|
||||
sym->as->lower[dim] = e;
|
||||
|
||||
e = gfc_build_intrinsic_call ("ubound", sym->declared_at, 3,
|
||||
gfc_copy_expr (sym->assoc->target),
|
||||
gfc_copy_expr (dim_expr), NULL);
|
||||
gfc_resolve_expr (e);
|
||||
sym->as->upper[dim] = e;
|
||||
|
||||
gfc_free_expr (dim_expr);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* Assign default type to symbols that need one and don't have one. */
|
||||
|
|
|
|||
|
|
@ -4742,3 +4742,19 @@ gfc_type_compatible (gfc_typespec *ts1, gfc_typespec *ts2)
|
|||
else
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
/* Find the parent-namespace of the current function. If we're inside
|
||||
BLOCK constructs, it may not be the current one. */
|
||||
|
||||
gfc_namespace*
|
||||
gfc_find_proc_namespace (gfc_namespace* ns)
|
||||
{
|
||||
while (ns->construct_entities)
|
||||
{
|
||||
ns = ns->parent;
|
||||
gcc_assert (ns);
|
||||
}
|
||||
|
||||
return ns;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -658,6 +658,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
|
|||
tree type;
|
||||
int dim;
|
||||
int nest;
|
||||
gfc_namespace* procns;
|
||||
|
||||
type = TREE_TYPE (decl);
|
||||
|
||||
|
|
@ -666,7 +667,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
|
|||
return;
|
||||
|
||||
gcc_assert (GFC_ARRAY_TYPE_P (type));
|
||||
nest = (sym->ns->proc_name->backend_decl != current_function_decl)
|
||||
procns = gfc_find_proc_namespace (sym->ns);
|
||||
nest = (procns->proc_name->backend_decl != current_function_decl)
|
||||
&& !sym->attr.contained;
|
||||
|
||||
for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
|
||||
|
|
|
|||
|
|
@ -1,3 +1,11 @@
|
|||
2010-08-15 Daniel Kraft <d@domob.eu>
|
||||
|
||||
PR fortran/38936
|
||||
* gfortran.dg/associate_1.f03: Enable test for array expressions.
|
||||
* gfortran.dg/associate_3.f03: Clarify comment.
|
||||
* gfortran.dg/associate_5.f03: New test.
|
||||
* gfortran.dg/associate_6.f03: New test.
|
||||
|
||||
2010-08-15 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/45211
|
||||
|
|
|
|||
|
|
@ -24,13 +24,15 @@ PROGRAM main
|
|||
! TODO: Test association to derived types.
|
||||
|
||||
! Test association to arrays.
|
||||
! TODO: Enable when working.
|
||||
!ALLOCATE (arr(3))
|
||||
!arr = (/ 1, 2, 3 /)
|
||||
!ASSOCIATE (doubled => 2 * arr)
|
||||
! IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
|
||||
! CALL abort ()
|
||||
!END ASSOCIATE
|
||||
ALLOCATE (arr(3))
|
||||
arr = (/ 1, 2, 3 /)
|
||||
ASSOCIATE (doubled => 2 * arr, xyz => func ())
|
||||
IF (SIZE (doubled) /= SIZE (arr)) CALL abort ()
|
||||
IF (doubled(1) /= 2 .OR. doubled(2) /= 4 .OR. doubled(3) /= 6) &
|
||||
CALL abort ()
|
||||
|
||||
IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
|
||||
END ASSOCIATE
|
||||
|
||||
! Named and nested associate.
|
||||
myname: ASSOCIATE (x => a - b * c)
|
||||
|
|
@ -46,4 +48,12 @@ PROGRAM main
|
|||
IF (x /= 2 .OR. y /= 1) CALL abort ()
|
||||
END ASSOCIATE
|
||||
END ASSOCIATE
|
||||
|
||||
CONTAINS
|
||||
|
||||
FUNCTION func ()
|
||||
INTEGER :: func(3)
|
||||
func = (/ 1, 3, 5 /)
|
||||
END FUNCTION func
|
||||
|
||||
END PROGRAM main
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! { dg-options "-std=f2003" }
|
||||
|
||||
! PR fortran/38936
|
||||
! Check for errors with ASSOCIATE.
|
||||
! Check for errors with ASSOCIATE during parsing.
|
||||
|
||||
PROGRAM main
|
||||
IMPLICIT NONE
|
||||
|
|
|
|||
|
|
@ -0,0 +1,13 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-std=f2003" }
|
||||
|
||||
! PR fortran/38936
|
||||
! Check for errors with ASSOCIATE during resolution.
|
||||
|
||||
PROGRAM main
|
||||
IMPLICIT NONE
|
||||
|
||||
ASSOCIATE (a => 5) ! { dg-error "is used as array" }
|
||||
PRINT *, a(3)
|
||||
END ASSOCIATE
|
||||
END PROGRAM main
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-std=f2003 -fdump-tree-original" }
|
||||
|
||||
! PR fortran/38936
|
||||
! Check that array expression association (with correct bounds) works for
|
||||
! complicated expressions.
|
||||
|
||||
! Contributed by Daniel Kraft, d@domob.eu.
|
||||
|
||||
! FIXME: XFAIL'ed because this is not yet implemented 'correctly'.
|
||||
|
||||
MODULE m
|
||||
IMPLICIT NONE
|
||||
|
||||
CONTAINS
|
||||
|
||||
PURE FUNCTION func (n)
|
||||
INTEGER, INTENT(IN) :: n
|
||||
INTEGER :: func(2 : n+1)
|
||||
|
||||
INTEGER :: i
|
||||
|
||||
func = (/ (i, i = 1, n) /)
|
||||
END FUNCTION func
|
||||
|
||||
END MODULE m
|
||||
|
||||
PROGRAM main
|
||||
USE :: m
|
||||
IMPLICIT NONE
|
||||
|
||||
ASSOCIATE (arr => func (4))
|
||||
! func should only be called once here, not again for the bounds!
|
||||
END ASSOCIATE
|
||||
END PROGRAM main
|
||||
! { dg-final { cleanup-modules "m" } }
|
||||
! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } }
|
||||
! { dg-final { cleanup-tree-dump "original" } }
|
||||
Loading…
Reference in New Issue