+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
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;
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;
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");
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 (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);
+ {
+ 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 ();
+
+ 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);
case_end:
accept_statement (st);
- assignTail->next = gfc_state_stack->head;
+ my_ns->code = gfc_state_stack->head;
break;
default:
}
}
+ /* 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
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
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;
+ }
}
break;
case EXEC_BLOCK:
- gfc_resolve (code->ext.block.ns);
+ resolve_block_construct (code);
break;
case EXEC_DO:
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. */
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;
+}
tree type;
int dim;
int nest;
+ gfc_namespace* procns;
type = TREE_TYPE (decl);
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++)
+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
! 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)
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
! { dg-options "-std=f2003" }
! PR fortran/38936
-! Check for errors with ASSOCIATE.
+! Check for errors with ASSOCIATE during parsing.
PROGRAM main
IMPLICIT NONE
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
OSDN Git Service
