mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-02-26 01:55:34 +08:00
Code Issues Packages Projects Releases Wiki Activity

re PR fortran/38936 ([F03] ASSOCIATE construct / improved SELECT TYPE (a=>expr))

Browse Source 
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 2010-08-15 21:46:21 +02:00 committed by Daniel Kraft
parent 5fc265c14f
commit 52bf62f96b
13 changed files with 236 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
gcc/fortran/ChangeLog
View File

@ -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

1
gcc/fortran/expr.c
View File

@ -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;

1
gcc/fortran/gfortran.h
View File

@ -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;

47
gcc/fortran/parse.c
View File

@ -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 (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
if (a->variable)
{
gfc_error ("Association to variables is not yet supported at %C");
return;
}
gcc_assert (assignTail);
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);
@ -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:

7
gcc/fortran/primary.c
View File

@ -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

105
gcc/fortran/resolve.c
View File

@ -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. */

16
gcc/fortran/symbol.c
View File

@ -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;
}

4
gcc/fortran/trans-decl.c
View File

@ -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++)

8
gcc/testsuite/ChangeLog
View File

@ -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
gcc/testsuite/gfortran.dg/associate_1.f03
View File

@ -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
gcc/testsuite/gfortran.dg/associate_3.f03
View File

@ -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

13
gcc/testsuite/gfortran.dg/associate_5.f03 Normal file
View File

@ -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

38
gcc/testsuite/gfortran.dg/associate_6.f03 Normal file
View File

@ -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" } }