+2010-08-17 Daniel Kraft <d@domob.eu>
+
+ PR fortran/38936
+ * gfortran.h (struct gfc_association_list): New member `where'.
+ (gfc_is_associate_pointer) New method.
+ * match.c (gfc_match_associate): Remember locus for each associate
+ name matched and do not try to set variable flag.
+ * parse.c (parse_associate): Use remembered locus for symbols.
+ * primary.c (match_variable): Instead of variable-flag check for
+ associate names set it for all such names used.
+ * symbol.c (gfc_is_associate_pointer): New method.
+ * resolve.c (resolve_block_construct): Don't generate assignments
+ to give associate-names their values.
+ (resolve_fl_var_and_proc): Allow associate-names to be deferred-shape.
+ (resolve_symbol): Set some more attributes for associate variables,
+ set variable flag here and check it and don't try to build an
+ explicitely shaped array-spec for array associate variables.
+ * trans-expr.c (gfc_conv_variable): Dereference in case of association
+ to scalar variable.
+ * trans-types.c (gfc_is_nodesc_array): Handle array association symbols.
+ (gfc_sym_type): Return pointer type for association to scalar vars.
+ * trans-decl.c (gfc_get_symbol_decl): Defer association symbols.
+ (trans_associate_var): New method.
+ (gfc_trans_deferred_vars): Handle association symbols.
+
2010-08-16 Joseph Myers <joseph@codesourcery.com>
* lang.opt (MDX): Change back to MD. Mark NoDriverArg instead of
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symtree *st; /* Symtree corresponding to name. */
+ locus where;
+
gfc_expr *target;
}
gfc_association_list;
gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
+bool gfc_is_associate_pointer (gfc_symbol*);
+
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
extern bool gfc_init_expr_flag;
gfc_error ("Expected association at %C");
goto assocListError;
}
+ newAssoc->where = gfc_current_locus;
/* Check that the current name is not yet in the list. */
for (a = new_st.ext.block.assoc; a; a = a->next)
goto assocListError;
}
- /* The target is a variable (and may be used as lvalue) if it's an
- EXPR_VARIABLE and does not have vector-subscripts. */
- newAssoc->variable = (newAssoc->target->expr_type == EXPR_VARIABLE
- && !gfc_has_vector_subscript (newAssoc->target));
+ /* The `variable' field is left blank for now; because the target is not
+ yet resolved, we can't use gfc_has_vector_subscript to determine it
+ for now. Instead, if the symbol is matched as variable, this field
+ is set -- and during resolution we check that. */
+ newAssoc->variable = 0;
/* Put it into the list. */
newAssoc->next = new_st.ext.block.assoc;
new_st.ext.block.ns = my_ns;
gcc_assert (new_st.ext.block.assoc);
- /* Add all associate-names as BLOCK variables. There values will be assigned
- to them during resolution of the ASSOCIATE construct. */
+ /* Add all associate-names as BLOCK variables. Creating them is enough
+ for now, they'll get their values during trans-* phase. */
gfc_current_ns = my_ns;
for (a = new_st.ext.block.assoc; a; a = a->next)
{
- if (a->variable)
- {
- gfc_error ("Association to variables is not yet supported at %C");
- return;
- }
+ gfc_symbol* sym;
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);
+ sym = a->st->n.sym;
+ sym->attr.flavor = FL_VARIABLE;
+ sym->assoc = a;
+ sym->declared_at = a->where;
+ gfc_set_sym_referenced (sym);
}
accept_statement (ST_ASSOCIATE);
gfc_error ("Assigning to PROTECTED variable at %C");
return MATCH_ERROR;
}
- if (sym->assoc && !sym->assoc->variable)
- {
- gfc_error ("'%s' associated to expression can't appear in a variable"
- " definition context at %C", sym->name);
- return MATCH_ERROR;
- }
+ if (sym->assoc)
+ sym->assoc->variable = 1;
break;
case FL_UNKNOWN:
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;
- }
+ resolved during gfc_resolve_symbol. */
}
sym->name, &sym->declared_at);
return FAILURE;
}
-
}
else
{
if (!mp_flag && !sym->attr.allocatable && !sym->attr.pointer
- && !sym->attr.dummy && sym->ts.type != BT_CLASS)
+ && !sym->attr.dummy && sym->ts.type != BT_CLASS && !sym->assoc)
{
gfc_error ("Array '%s' at %L cannot have a deferred shape",
sym->name, &sym->declared_at);
they get their type-spec set this way. */
if (sym->assoc)
{
+ gfc_expr* target;
+ bool to_var;
+
gcc_assert (sym->attr.flavor == FL_VARIABLE);
- if (gfc_resolve_expr (sym->assoc->target) != SUCCESS)
+
+ target = sym->assoc->target;
+ if (gfc_resolve_expr (target) != SUCCESS)
return;
- sym->ts = sym->assoc->target->ts;
+ /* For variable targets, we get some attributes from the target. */
+ if (target->expr_type == EXPR_VARIABLE)
+ {
+ gfc_symbol* tsym;
+
+ gcc_assert (target->symtree);
+ tsym = target->symtree->n.sym;
+
+ sym->attr.asynchronous = tsym->attr.asynchronous;
+ sym->attr.volatile_ = tsym->attr.volatile_;
+
+ sym->attr.target = (tsym->attr.target || tsym->attr.pointer);
+ }
+
+ sym->ts = target->ts;
gcc_assert (sym->ts.type != BT_UNKNOWN);
- if (sym->attr.dimension && sym->assoc->target->rank == 0)
+ /* See if this is a valid association-to-variable. */
+ to_var = (target->expr_type == EXPR_VARIABLE
+ && !gfc_has_vector_subscript (target));
+ if (sym->assoc->variable && !to_var)
+ {
+ if (target->expr_type == EXPR_VARIABLE)
+ gfc_error ("'%s' at %L associated to vector-indexed target can not"
+ " be used in a variable definition context",
+ sym->name, &sym->declared_at);
+ else
+ gfc_error ("'%s' at %L associated to expression can not"
+ " be used in a variable definition context",
+ sym->name, &sym->declared_at);
+
+ return;
+ }
+ sym->assoc->variable = to_var;
+
+ /* Finally resolve if this is an array or not. */
+ if (sym->attr.dimension && 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)
+ if (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;
+ sym->as->rank = target->rank;
+ sym->as->type = AS_DEFERRED;
/* 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);
- }
}
}
return ns;
}
+
+
+/* Check if an associate-variable should be translated as an `implicit' pointer
+ internally (if it is associated to a variable and not an array with
+ descriptor). */
+
+bool
+gfc_is_associate_pointer (gfc_symbol* sym)
+{
+ if (!sym->assoc)
+ return false;
+
+ if (!sym->assoc->variable)
+ return false;
+
+ if (sym->attr.dimension && sym->as->type != AS_EXPLICIT)
+ return false;
+
+ return true;
+}
}
/* Remember this variable for allocation/cleanup. */
- if (sym->attr.dimension || sym->attr.allocatable
+ if (sym->attr.dimension || sym->attr.allocatable || sym->assoc
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
}
+/* Do proper initialization for ASSOCIATE names. */
+
+static void
+trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
+{
+ gfc_expr* e;
+ tree tmp;
+
+ gcc_assert (sym->assoc);
+ e = sym->assoc->target;
+
+ /* Do a `pointer assignment' with updated descriptor (or assign descriptor
+ to array temporary) for arrays with either unknown shape or if associating
+ to a variable. */
+ if (sym->attr.dimension
+ && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
+ {
+ gfc_se se;
+ gfc_ss* ss;
+ tree desc;
+
+ desc = sym->backend_decl;
+
+ /* If association is to an expression, evaluate it and create temporary.
+ Otherwise, get descriptor of target for pointer assignment. */
+ gfc_init_se (&se, NULL);
+ ss = gfc_walk_expr (e);
+ if (sym->assoc->variable)
+ {
+ se.direct_byref = 1;
+ se.expr = desc;
+ }
+ gfc_conv_expr_descriptor (&se, e, ss);
+
+ /* If we didn't already do the pointer assignment, set associate-name
+ descriptor to the one generated for the temporary. */
+ if (!sym->assoc->variable)
+ {
+ tree offs;
+ int dim;
+
+ gfc_add_modify (&se.pre, desc, se.expr);
+
+ /* The generated descriptor has lower bound zero (as array
+ temporary), shift bounds so we get lower bounds of 1 all the time.
+ The offset has to be corrected as well.
+ Because the ubound shift and offset depends on the lower bounds, we
+ first calculate those and set the lbound to one last. */
+
+ offs = gfc_conv_descriptor_offset_get (desc);
+ for (dim = 0; dim < e->rank; ++dim)
+ {
+ tree from, to;
+ tree stride;
+
+ from = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[dim]);
+ to = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[dim]);
+ stride = gfc_conv_descriptor_stride_get (desc, gfc_rank_cst[dim]);
+
+ tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
+ gfc_index_one_node, from);
+ to = fold_build2 (PLUS_EXPR, gfc_array_index_type, to, tmp);
+
+ tmp = fold_build2 (MULT_EXPR, gfc_array_index_type, tmp, stride);
+ offs = fold_build2 (MINUS_EXPR, gfc_array_index_type, offs, tmp);
+
+ gfc_conv_descriptor_ubound_set (&se.pre, desc,
+ gfc_rank_cst[dim], to);
+ }
+ gfc_conv_descriptor_offset_set (&se.pre, desc, offs);
+
+ for (dim = 0; dim < e->rank; ++dim)
+ gfc_conv_descriptor_lbound_set (&se.pre, desc, gfc_rank_cst[dim],
+ gfc_index_one_node);
+ }
+
+ /* Done, register stuff as init / cleanup code. */
+ gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
+ gfc_finish_block (&se.post));
+ }
+
+ /* Do a scalar pointer assignment; this is for scalar variable targets. */
+ else if (gfc_is_associate_pointer (sym))
+ {
+ gfc_se se;
+
+ gcc_assert (!sym->attr.dimension);
+
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, e);
+
+ tmp = TREE_TYPE (sym->backend_decl);
+ tmp = gfc_build_addr_expr (tmp, se.expr);
+ gfc_add_modify (&se.pre, sym->backend_decl, tmp);
+
+ gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
+ gfc_finish_block (&se.post));
+ }
+
+ /* Do a simple assignment. This is for scalar expressions, where we
+ can simply use expression assignment. */
+ else
+ {
+ gfc_expr* lhs;
+
+ lhs = gfc_lval_expr_from_sym (sym);
+ tmp = gfc_trans_assignment (lhs, e, false, true);
+ gfc_add_init_cleanup (block, tmp, NULL_TREE);
+ }
+}
+
+
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
Allocation of character string variables.
Initialization and possibly repacking of dummy arrays.
Initialization of ASSIGN statement auxiliary variable.
+ Initialization of ASSOCIATE names.
Automatic deallocation. */
void
{
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
&& sym->ts.u.derived->attr.alloc_comp;
- if (sym->attr.dimension)
+ if (sym->assoc)
+ trans_associate_var (sym, block);
+ else if (sym->attr.dimension)
{
switch (sym->as->type)
{
se->expr = build_fold_indirect_ref_loc (input_location,
se->expr);
- /* Dereference non-character pointer variables.
+ /* Dereference non-character pointer variables.
These must be dummies, results, or scalars. */
- if ((sym->attr.pointer || sym->attr.allocatable)
+ if ((sym->attr.pointer || sym->attr.allocatable
+ || gfc_is_associate_pointer (sym))
&& (sym->attr.dummy
|| sym->attr.function
|| sym->attr.result
if (sym->attr.pointer || sym->attr.allocatable)
return 0;
+ /* We want a descriptor for associate-name arrays that do not have an
+ explicitely known shape already. */
+ if (sym->assoc && sym->as->type != AS_EXPLICIT)
+ return 0;
+
if (sym->attr.dummy)
- {
- if (sym->as->type != AS_ASSUMED_SHAPE)
- return 1;
- else
- return 0;
- }
+ return sym->as->type != AS_ASSUMED_SHAPE;
if (sym->attr.result || sym->attr.function)
return 0;
}
else
{
- if (sym->attr.allocatable || sym->attr.pointer)
+ if (sym->attr.allocatable || sym->attr.pointer
+ || gfc_is_associate_pointer (sym))
type = gfc_build_pointer_type (sym, type);
if (sym->attr.pointer || sym->attr.cray_pointee)
GFC_POINTER_TYPE_P (type) = 1;
+2010-08-17 Daniel Kraft <d@domob.eu>
+
+ PR fortran/38936
+ * gfortran.dg/associate_1.f03: Extended to test newly supported
+ features like association to variables.
+ * gfortran.dg/associate_3.f03: Removed check for illegal change
+ of associate-name here...
+ * gfortran.dg/associate_5.f03: ...and added it here.
+ * gfortran.dg/associate_6.f03: No longer XFAIL'ed.
+ * gfortran.dg/associate_7.f03: New test.
+
2010-08-15 Kaz Kojima <kkojima@gcc.gnu.org>
* gcc.dg/tree-ssa/pr42585.c: Skip dump scan on sh.
! { dg-do run }
-! { dg-options "-std=f2003 -fall-intrinsics" }
+! { dg-options "-std=f2003 -fall-intrinsics -cpp" }
! PR fortran/38936
! Check the basic semantics of the ASSOCIATE construct.
IMPLICIT NONE
REAL :: a, b, c
INTEGER, ALLOCATABLE :: arr(:)
+ INTEGER :: mat(3, 3)
+
+ TYPE :: myt
+ INTEGER :: comp
+ END TYPE myt
+
+ TYPE(myt) :: tp
a = -2.0
b = 3.0
IF (ABS (t - a - b) > 1.0e-3) CALL abort ()
END ASSOCIATE
- ! TODO: Test association to variables when that is supported.
- ! TODO: Test association to derived types.
-
! Test association to arrays.
ALLOCATE (arr(3))
arr = (/ 1, 2, 3 /)
IF (ANY (xyz /= (/ 1, 3, 5 /))) CALL abort ()
END ASSOCIATE
+ ! Target is vector-indexed.
+ ASSOCIATE (foo => arr((/ 3, 1 /)))
+ IF (LBOUND (foo, 1) /= 1 .OR. UBOUND (foo, 1) /= 2) CALL abort ()
+ IF (foo(1) /= 3 .OR. foo(2) /= 1) CALL abort ()
+ END ASSOCIATE
+
! Named and nested associate.
myname: ASSOCIATE (x => a - b * c)
ASSOCIATE (y => 2.0 * x)
END ASSOCIATE
END ASSOCIATE
+ ! Association to variables.
+ mat = 0
+ mat(2, 2) = 5;
+ ASSOCIATE (x => arr(2), y => mat(2:3, 1:2))
+ IF (x /= 2) CALL abort ()
+ IF (ANY (LBOUND (y) /= (/ 1, 1 /) .OR. UBOUND (y) /= (/ 2, 2 /))) &
+ CALL abort ()
+ IF (y(1, 2) /= 5) CALL abort ()
+
+ x = 7
+ y = 8
+ END ASSOCIATE
+ IF (arr(2) /= 7 .OR. ANY (mat(2:3, 1:2) /= 8)) CALL abort ()
+
+ ! Association to derived type and component.
+ tp = myt (1)
+ ASSOCIATE (x => tp, y => tp%comp)
+ ! FIXME: Parsing of derived-type associate names, tests with x.
+ IF (y /= 1) CALL abort ()
+ y = 5
+ END ASSOCIATE
+ IF (tp%comp /= 5) CALL abort ()
+
+ ! Association to character variables.
+ ! FIXME: Enable character test, once this works.
+ !CALL test_char (5)
+
CONTAINS
FUNCTION func ()
func = (/ 1, 3, 5 /)
END FUNCTION func
+#if 0
+ ! Test association to character variable with automatic length.
+ SUBROUTINE test_char (n)
+ INTEGER, INTENT(IN) :: n
+
+ CHARACTER(LEN=n) :: str
+
+ str = "foobar"
+ ASSOCIATE (my => str)
+ IF (LEN (my) /= n) CALL abort ()
+ IF (my /= "fooba") CALL abort ()
+ my = "abcdef"
+ END ASSOCIATE
+ IF (str /= "abcde") CALL abort ()
+ END SUBROUTINE test_char
+#endif
+
END PROGRAM main
ASSOCIATE (a => 1, b => 2, a => 3) ! { dg-error "Duplicate name 'a'" }
ASSOCIATE (a => 5)
- a = 4 ! { dg-error "variable definition context" }
- ENd ASSOCIATE
-
- ASSOCIATE (a => 5)
INTEGER :: b ! { dg-error "Unexpected data declaration statement" }
END ASSOCIATE
END PROGRAM main ! { dg-error "Expecting END ASSOCIATE" }
PROGRAM main
IMPLICIT NONE
+ INTEGER :: nontarget
+ INTEGER :: arr(3)
+ INTEGER, POINTER :: ptr
ASSOCIATE (a => 5) ! { dg-error "is used as array" }
PRINT *, a(3)
END ASSOCIATE
+
+ ASSOCIATE (a => nontarget)
+ ptr => a ! { dg-error "neither TARGET nor POINTER" }
+ END ASSOCIATE
+
+ ASSOCIATE (a => 5, & ! { dg-error "variable definition context" }
+ b => arr((/ 1, 3 /))) ! { dg-error "variable definition context" }
+ a = 4
+ b = 7
+ END ASSOCIATE
END PROGRAM main
! Contributed by Daniel Kraft, d@domob.eu.
-! FIXME: XFAIL'ed because this is not yet implemented 'correctly'.
-
MODULE m
IMPLICIT NONE
ASSOCIATE (arr => func (4))
! func should only be called once here, not again for the bounds!
+
+ IF (LBOUND (arr, 1) /= 1 .OR. UBOUND (arr, 1) /= 4) CALL abort ()
+ IF (arr(1) /= 1 .OR. arr(4) /= 4) CALL abort ()
END ASSOCIATE
END PROGRAM main
! { dg-final { cleanup-modules "m" } }
-! { dg-final { scan-tree-dump-times "func" 2 "original" { xfail *-*-* } } }
+! { dg-final { scan-tree-dump-times "func" 2 "original" } }
! { dg-final { cleanup-tree-dump "original" } }
--- /dev/null
+! { dg-do run }
+! { dg-options "-std=f2003 -fall-intrinsics" }
+
+! PR fortran/38936
+! Check association and pointers.
+
+! Contributed by Daniel Kraft, d@domob.eu.
+
+PROGRAM main
+ IMPLICIT NONE
+ INTEGER, TARGET :: tgt
+ INTEGER, POINTER :: ptr
+
+ tgt = 1
+ ASSOCIATE (x => tgt)
+ ptr => x
+ IF (ptr /= 1) CALL abort ()
+ ptr = 2
+ END ASSOCIATE
+ IF (tgt /= 2) CALL abort ()
+END PROGRAM main
projects / platform / upstream / gcc.git / commitdiff