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
+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.
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);
{
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,
{
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;
"INTEGER return specifier", &code->expr->where);
break;
+ case EXEC_INIT_ASSIGN:
+ break;
+
case EXEC_ASSIGN:
if (t == FAILURE)
break;
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
&& (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);
+ }
}
{
case EXEC_NOP:
case EXEC_ASSIGN:
+ case EXEC_INIT_ASSIGN:
case EXEC_GOTO:
case EXEC_CYCLE:
case EXEC_RETURN:
&& 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);
}
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;
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);
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);
}
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);
}
/* 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
/* 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
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);
/* 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 *);
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;
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 *);
+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
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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
git://gcc.gnu.org / gcc.git / commitdiff