mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-10 18:20:51 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
2006-10-19  Paul Thomas <pault@gcc.gnu.org>

	PR fortran/29216
	PR fortran/29314
	* gfortran.h : Add EXEC_INIT_ASSIGN.
	* dump-parse-tree.c (gfc_show_code_node): The same.
	* trans-openmp.c (gfc_trans_omp_array_reduction): Set new
	argument for gfc_trans_assignment to false.
	* trans-stmt.c (gfc_trans_forall_1): The same.
	* trans-expr.c (gfc_conv_function_call, gfc_trans_assign,
	gfc_trans_arrayfunc_assign, gfc_trans_assignment): The
	same. In the latter function, use the new flag to stop
	the checking of the lhs for deallocation.
	(gfc_trans_init_assign): New function.
	* trans-stmt.h : Add prototype for gfc_trans_init_assign.
	* trans.c (gfc_trans_code): Implement EXEC_INIT_ASSIGN.
	* trans.h : Add new boolean argument to the prototype of
	gfc_trans_assignment.
	* resolve.c (resolve_allocate_exp): Replace EXEC_ASSIGN by
	EXEC_INIT_ASSIGN.
	(resolve_code): EXEC_INIT_ASSIGN does not need resolution.
	(apply_default_init): New function.
	(resolve_symbol): Call it for derived types that become
	defined but which do not already have an initialization
	expression..
	* st.c (gfc_free_statement): Include EXEC_INIT_ASSIGN.

2006-10-19  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/29216
	* gfortran.dg/result_default_init_1.f90: New test.

	PR fortran/29314
	* gfortran.dg/automatic_default_init_1.f90: New test.

	* gfortran.dg/alloc_comp_basics_1.f90: Reduce deallocate count
	from 38 to 33.

From-SVN: r117879
This commit is contained in:
Paul Thomas 2006-10-19 04:51:14 +00:00
parent 2d142abdf3
commit 6b591ec0ba
15 changed files with 200 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
gcc/fortran/ChangeLog
View File

@ -1,3 +1,30 @@
2006-10-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29216
PR fortran/29314
* gfortran.h : Add EXEC_INIT_ASSIGN.
* dump-parse-tree.c (gfc_show_code_node): The same.
* trans-openmp.c (gfc_trans_omp_array_reduction): Set new
argument for gfc_trans_assignment to false.
* trans-stmt.c (gfc_trans_forall_1): The same.
* trans-expr.c (gfc_conv_function_call, gfc_trans_assign,
gfc_trans_arrayfunc_assign, gfc_trans_assignment): The
same. In the latter function, use the new flag to stop
the checking of the lhs for deallocation.
(gfc_trans_init_assign): New function.
* trans-stmt.h : Add prototype for gfc_trans_init_assign.
* trans.c (gfc_trans_code): Implement EXEC_INIT_ASSIGN.
* trans.h : Add new boolean argument to the prototype of
gfc_trans_assignment.
* resolve.c (resolve_allocate_exp): Replace EXEC_ASSIGN by
EXEC_INIT_ASSIGN.
(resolve_code): EXEC_INIT_ASSIGN does not need resolution.
(apply_default_init): New function.
(resolve_symbol): Call it for derived types that become
defined but which do not already have an initialization
expression..
* st.c (gfc_free_statement): Include EXEC_INIT_ASSIGN.
2006-10-16 Tobias Burnus <burnus@net-b.de>
* primary.c: Revert 'significand'-to-'significant' comment change.

1
gcc/fortran/dump-parse-tree.c
View File

@ -1021,6 +1021,7 @@ gfc_show_code_node (int level, gfc_code * c)
gfc_status ("ENTRY %s", c->ext.entry->sym->name);
break;
case EXEC_INIT_ASSIGN:
case EXEC_ASSIGN:
gfc_status ("ASSIGN ");
gfc_show_expr (c->expr);

2
gcc/fortran/gfortran.h
View File

@ -1507,7 +1507,7 @@ typedef enum
{
EXEC_NOP = 1, EXEC_ASSIGN, EXEC_LABEL_ASSIGN, EXEC_POINTER_ASSIGN,
EXEC_GOTO, EXEC_CALL, EXEC_ASSIGN_CALL, EXEC_RETURN, EXEC_ENTRY,
EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE,
EXEC_PAUSE, EXEC_STOP, EXEC_CONTINUE, EXEC_INIT_ASSIGN,
EXEC_IF, EXEC_ARITHMETIC_IF, EXEC_DO, EXEC_DO_WHILE, EXEC_SELECT,
EXEC_FORALL, EXEC_WHERE, EXEC_CYCLE, EXEC_EXIT,
EXEC_ALLOCATE, EXEC_DEALLOCATE,

90
gcc/fortran/resolve.c
View File

@ -3556,7 +3556,7 @@ resolve_allocate_expr (gfc_expr * e, gfc_code * code)
{
init_st = gfc_get_code ();
init_st->loc = code->loc;
init_st->op = EXEC_ASSIGN;
init_st->op = EXEC_INIT_ASSIGN;
init_st->expr = expr_to_initialize (e);
init_st->expr2 = init_e;
init_st->next = code->next;
@ -4907,6 +4907,9 @@ resolve_code (gfc_code * code, gfc_namespace * ns)
"INTEGER return specifier", &code->expr->where);
break;
case EXEC_INIT_ASSIGN:
break;
case EXEC_ASSIGN:
if (t == FAILURE)
break;
@ -5222,6 +5225,75 @@ is_non_constant_shape_array (gfc_symbol *sym)
return not_constant;
}
/* Assign the default initializer to a derived type variable or result. */
static void
apply_default_init (gfc_symbol *sym)
{
gfc_expr *lval;
gfc_expr *init = NULL;
gfc_code *init_st;
gfc_namespace *ns = sym->ns;
if (sym->attr.flavor != FL_VARIABLE && !sym->attr.function)
return;
if (sym->ts.type == BT_DERIVED && sym->ts.derived)
init = gfc_default_initializer (&sym->ts);
if (init == NULL)
return;
/* Search for the function namespace if this is a contained
function without an explicit result. */
if (sym->attr.function && sym == sym->result
&& sym->name != sym->ns->proc_name->name)
{
ns = ns->contained;
for (;ns; ns = ns->sibling)
if (strcmp (ns->proc_name->name, sym->name) == 0)
break;
}
if (ns == NULL)
{
gfc_free_expr (init);
return;
}
/* Build an l-value expression for the result. */
lval = gfc_get_expr ();
lval->expr_type = EXPR_VARIABLE;
lval->where = sym->declared_at;
lval->ts = sym->ts;
lval->symtree = gfc_find_symtree (sym->ns->sym_root, sym->name);
/* It will always be a full array. */
lval->rank = sym->as ? sym->as->rank : 0;
if (lval->rank)
{
lval->ref = gfc_get_ref ();
lval->ref->type = REF_ARRAY;
lval->ref->u.ar.type = AR_FULL;
lval->ref->u.ar.dimen = lval->rank;
lval->ref->u.ar.where = sym->declared_at;
lval->ref->u.ar.as = sym->as;
}
/* Add the code at scope entry. */
init_st = gfc_get_code ();
init_st->next = ns->code;
ns->code = init_st;
/* Assign the default initializer to the l-value. */
init_st->loc = sym->declared_at;
init_st->op = EXEC_INIT_ASSIGN;
init_st->expr = lval;
init_st->expr2 = init;
}
/* Resolution of common features of flavors variable and procedure. */
static try
@ -5960,6 +6032,22 @@ resolve_symbol (gfc_symbol * sym)
&& (sym->ns->proc_name == NULL
|| sym->ns->proc_name->attr.flavor != FL_MODULE)))
gfc_error ("Threadprivate at %L isn't SAVEd", &sym->declared_at);
/* If we have come this far we can apply default-initializers, as
described in 14.7.5, to those variables that have not already
been assigned one. */
if (sym->ts.type == BT_DERIVED && sym->ns == gfc_current_ns && !sym->value
&& !sym->attr.allocatable && !sym->attr.alloc_comp)
{
symbol_attribute *a = &sym->attr;
if ((!a->save && !a->dummy && !a->pointer
&& !a->in_common && !a->use_assoc
&& !(a->function && sym != sym->result))
||
(a->dummy && a->intent == INTENT_OUT))
apply_default_init (sym);
}
}

1
gcc/fortran/st.c
View File

@ -93,6 +93,7 @@ gfc_free_statement (gfc_code * p)
{
case EXEC_NOP:
case EXEC_ASSIGN:
case EXEC_INIT_ASSIGN:
case EXEC_GOTO:
case EXEC_CYCLE:
case EXEC_RETURN:

18
gcc/fortran/trans-expr.c
View File

@ -2031,7 +2031,7 @@ gfc_conv_function_call (gfc_se * se, gfc_symbol * sym,
&& fsym->value)
{
gcc_assert (!fsym->attr.allocatable);
tmp = gfc_trans_assignment (e, fsym->value);
tmp = gfc_trans_assignment (e, fsym->value, false);
gfc_add_expr_to_block (&se->pre, tmp);
}
@ -3363,7 +3363,7 @@ gfc_trans_arrayfunc_assign (gfc_expr * expr1, gfc_expr * expr2)
setting up the scalarizer. */
tree
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2, bool init_flag)
{
gfc_se lse;
gfc_se rse;
@ -3466,7 +3466,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
else
gfc_conv_expr (&lse, expr1);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, l_is_temp,
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
l_is_temp || init_flag,
expr2->expr_type == EXPR_VARIABLE);
gfc_add_expr_to_block (&body, tmp);
@ -3500,7 +3501,8 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
gcc_assert (lse.ss == gfc_ss_terminator
&& rse.ss == gfc_ss_terminator);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
false, false);
gfc_add_expr_to_block (&body, tmp);
}
@ -3517,8 +3519,14 @@ gfc_trans_assignment (gfc_expr * expr1, gfc_expr * expr2)
return gfc_finish_block (&block);
}
tree
gfc_trans_init_assign (gfc_code * code)
{
return gfc_trans_assignment (code->expr, code->expr2, true);
}
tree
gfc_trans_assign (gfc_code * code)
{
return gfc_trans_assignment (code->expr, code->expr2);
return gfc_trans_assignment (code->expr, code->expr2, false);
}

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

@ -424,7 +424,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
/* Create the init statement list. */
pushlevel (0);
stmt = gfc_trans_assignment (e1, e2);
stmt = gfc_trans_assignment (e1, e2, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else
@ -433,7 +433,7 @@ gfc_trans_omp_array_reduction (tree c, gfc_symbol *sym, locus where)
/* Create the merge statement list. */
pushlevel (0);
stmt = gfc_trans_assignment (e3, e4);
stmt = gfc_trans_assignment (e3, e4, false);
if (TREE_CODE (stmt) != BIND_EXPR)
stmt = build3_v (BIND_EXPR, NULL, stmt, poplevel (1, 0, 0));
else

2
gcc/fortran/trans-stmt.c
View File

@ -2638,7 +2638,7 @@ gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
else
{
/* Use the normal assignment copying routines. */
assign = gfc_trans_assignment (c->expr, c->expr2);
assign = gfc_trans_assignment (c->expr, c->expr2, false);
/* Generate body and loops. */
tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);

1
gcc/fortran/trans-stmt.h
View File

@ -28,6 +28,7 @@ tree gfc_trans_code (gfc_code *);
/* trans-expr.c */
tree gfc_trans_assign (gfc_code *);
tree gfc_trans_pointer_assign (gfc_code *);
tree gfc_trans_init_assign (gfc_code *);
/* trans-stmt.c */
tree gfc_trans_cycle (gfc_code *);

4
gcc/fortran/trans.c
View File

@ -477,6 +477,10 @@ gfc_trans_code (gfc_code * code)
res = gfc_trans_pointer_assign (code);
break;
case EXEC_INIT_ASSIGN:
res = gfc_trans_init_assign (code);
break;
case EXEC_CONTINUE:
res = NULL_TREE;
break;

2
gcc/fortran/trans.h
View File

@ -426,7 +426,7 @@ bool get_array_ctor_strlen (gfc_constructor *, tree *);
void gfc_trans_runtime_check (tree, const char *, stmtblock_t *, locus *);
/* Generate code for an assignment, includes scalarization. */
tree gfc_trans_assignment (gfc_expr *, gfc_expr *);
tree gfc_trans_assignment (gfc_expr *, gfc_expr *, bool);
/* Generate code for a pointer assignment. */
tree gfc_trans_pointer_assignment (gfc_expr *, gfc_expr *);

11
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,14 @@
2006-10-19 Paul Thomas <pault@gcc.gnu.org>
PR fortran/29216
* gfortran.dg/result_default_init_1.f90: New test.
PR fortran/29314
* gfortran.dg/automatic_default_init_1.f90: New test.
* gfortran.dg/alloc_comp_basics_1.f90: Reduce deallocate count
from 38 to 33.
2006-10-18 Geoffrey Keating <geoffk@apple.com>
* g++.old-deja/g++.robertl/eb133b.C: Add XFAILed error for

2
gcc/testsuite/gfortran.dg/alloc_comp_basics_1.f90
View File

@ -139,5 +139,5 @@ contains
end subroutine check_alloc2
end program alloc
! { dg-final { scan-tree-dump-times "deallocate" 38 "original" } }
! { dg-final { scan-tree-dump-times "deallocate" 33 "original" } }
! { dg-final { cleanup-tree-dump "original" } }

21
gcc/testsuite/gfortran.dg/automatic_default_init_1.f90 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do run }
! { dg-options "-O" }
! Test the fix for PR29394 in which automatic arrays did not
! get default initialization.
! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
!
MODULE M1
TYPE T1
INTEGER :: I=7
END TYPE T1
CONTAINS
SUBROUTINE S1(I)
INTEGER, INTENT(IN) :: I
TYPE(T1) :: D(1:I)
IF (any (D(:)%I.NE.7)) CALL ABORT()
END SUBROUTINE S1
END MODULE M1
USE M1
CALL S1(2)
END
! { dg-final { cleanup-modules "m1" } }

26
gcc/testsuite/gfortran.dg/result_default_init_1.f90 Normal file
View File

@ -0,0 +1,26 @@
! { dg-do run }
! { dg-options "-O" }
! Test the fix for PR29216 in which function results did not
! get default initialization.
! Contributed by Stephan Kramer <stephan.kramer@imperial.ac.uk>
!
type A
integer, pointer:: p => null ()
integer:: i=3
end type A
type(A):: x,y
if (associated(x%p) .or. x%i /= 3) call abort ()
x=f()
if (associated(x%p) .or. x%i /= 3) call abort ()
x=g()
if (associated(x%p) .or. x%i /= 3) call abort ()
contains
function f() result (fr)
type(A):: fr
if (associated(fr%p) .or. fr%i /= 3) call abort ()
end function f
function g()
type(A):: g
if (associated(g%p) .or. g%i /= 3) call abort ()
end function g
end