static struct pointer_set_t *nonlocal_dummy_decl_pset;
static GTY(()) tree nonlocal_dummy_decls;
+/* Holds the variable DECLs that are locals. */
+
+static GTY(()) tree saved_local_decls;
+
/* The namespace of the module we're currently generating. Only used while
outputting decls for module variables. Do not rely on this being set. */
saved_function_decls = decl;
}
+static void
+add_decl_as_local (tree decl)
+{
+ gcc_assert (decl);
+ TREE_USED (decl) = 1;
+ DECL_CONTEXT (decl) = current_function_decl;
+ TREE_CHAIN (decl) = saved_local_decls;
+ saved_local_decls = decl;
+}
+
/* Build a backend label declaration. Set TREE_USED for named labels.
The context of the label is always the current_function_decl. All
if (current_function_decl != NULL_TREE)
{
if (sym->ns->proc_name->backend_decl == current_function_decl
- || sym->result == sym)
+ || sym->result == sym)
gfc_add_decl_to_function (decl);
+ else if (sym->ns->proc_name->attr.flavor == FL_LABEL)
+ /* This is a BLOCK construct. */
+ add_decl_as_local (decl);
else
gfc_add_decl_to_parent_function (decl);
}
gfortran would typically put them in either the BSS or
initialized data segments, and only mark them as common if
they were part of common blocks. However, if they are not put
- into common space, then C cannot initialize global fortran
+ into common space, then C cannot initialize global Fortran
variables that it interoperates with and the draft says that
either Fortran or C should be able to initialize it (but not
both, of course.) (J3/04-007, section 15.3). */
/* Create variables to hold the non-constant bits of array info. */
gfc_build_qualified_array (decl, sym);
- /* Remember this variable for allocation/cleanup. */
- gfc_defer_symbol_init (sym);
-
if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
GFC_DECL_PACKED_ARRAY (decl) = 1;
}
- if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
- gfc_defer_symbol_init (sym);
- /* This applies a derived type default initializer. */
- else if (sym->ts.type == BT_DERIVED
- && sym->attr.save == SAVE_NONE
- && !sym->attr.data
- && !sym->attr.allocatable
- && (sym->value && !sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc)
+ /* Remember this variable for allocation/cleanup. */
+ if (sym->attr.dimension || sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS &&
+ (sym->ts.u.derived->components->attr.dimension
+ || sym->ts.u.derived->components->attr.allocatable))
+ || (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)
+ /* This applies a derived type default initializer. */
+ || (sym->ts.type == BT_DERIVED
+ && sym->attr.save == SAVE_NONE
+ && !sym->attr.data
+ && !sym->attr.allocatable
+ && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc))
gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
{
/* Add static initializer. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+ TREE_TYPE (decl),
+ sym->attr.proc_pointer ? false : sym->attr.dimension,
+ sym->attr.proc_pointer);
}
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
gfc_set_sym_referenced (sym);
e = gfc_lval_expr_from_sym (sym);
tmp = gfc_trans_assignment (e, sym->value, false);
- if (sym->attr.dummy)
+ if (sym->attr.dummy && (sym->attr.optional
+ || sym->ns->proc_name->attr.entry_master))
{
present = gfc_conv_expr_present (sym);
tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
&& !f->sym->attr.pointer
&& f->sym->ts.type == BT_DERIVED)
{
- if (f->sym->ts.u.derived->attr.alloc_comp)
+ if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)
{
tmp = gfc_deallocate_alloc_comp (f->sym->ts.u.derived,
f->sym->backend_decl,
f->sym->as ? f->sym->as->rank : 0);
- present = gfc_conv_expr_present (f->sym);
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
- tmp, build_empty_stmt (input_location));
+ if (f->sym->attr.optional
+ || f->sym->ns->proc_name->attr.entry_master)
+ {
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt (input_location));
+ }
gfc_add_expr_to_block (&fnblock, tmp);
}
-
- if (!f->sym->ts.u.derived->attr.alloc_comp
- && f->sym->value)
+ else if (f->sym->value)
body = gfc_init_default_dt (f->sym, body);
}
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 ASSIGN statement auxiliary variable.
+ Automatic deallocation. */
-static tree
+tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
locus loc;
}
else if (sym_has_alloc_comp)
fnbody = gfc_trans_deferred_array (sym, fnbody);
+ else if (sym->attr.allocatable
+ || (sym->ts.type == BT_CLASS
+ && sym->ts.u.derived->components->attr.allocatable))
+ {
+ if (!sym->attr.save)
+ {
+ /* Nullify and automatic deallocation of allocatable
+ scalars. */
+ tree tmp;
+ gfc_expr *e;
+ gfc_se se;
+ stmtblock_t block;
+
+ e = gfc_lval_expr_from_sym (sym);
+ if (sym->ts.type == BT_CLASS)
+ gfc_add_component_ref (e, "$data");
+
+ gfc_init_se (&se, NULL);
+ se.want_pointer = 1;
+ gfc_conv_expr (&se, e);
+ gfc_free_expr (e);
+
+ /* Nullify when entering the scope. */
+ gfc_start_block (&block);
+ gfc_add_modify (&block, se.expr,
+ fold_convert (TREE_TYPE (se.expr),
+ null_pointer_node));
+ gfc_add_expr_to_block (&block, fnbody);
+
+ /* Deallocate when leaving the scope. Nullifying is not
+ needed. */
+ tmp = gfc_deallocate_with_status (se.expr, NULL_TREE, true,
+ NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ fnbody = gfc_finish_block (&block);
+ }
+ }
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
- if (sym->backend_decl)
+ if (sym->backend_decl && !sym->attr.vtab)
internal_error ("backend decl for module variable %s already exists",
sym->name);
else if (warn_unused_variable
&& sym->attr.dummy
&& sym->attr.intent == INTENT_OUT)
- gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
- sym->name, &sym->declared_at);
+ {
+ if (!(sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->components->initializer))
+ gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) "
+ "but was not set", sym->name, &sym->declared_at);
+ }
/* Specific warning for unused dummy arguments. */
else if (warn_unused_variable && sym->attr.dummy)
gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
is_recursive = sym->attr.recursive
|| (sym->attr.entry_master
&& sym->ns->entries->sym->attr.recursive);
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
+ && !gfc_option.flag_recursive)
{
char * msg;
result = sym->result->backend_decl;
if (result != NULL_TREE && sym->attr.function
- && sym->ts.type == BT_DERIVED
- && sym->ts.u.derived->attr.alloc_comp
- && !sym->attr.pointer)
+ && !sym->attr.pointer)
{
- rank = sym->as ? sym->as->rank : 0;
- tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
- gfc_add_expr_to_block (&block, tmp2);
+ if (sym->ts.type == BT_DERIVED
+ && sym->ts.u.derived->attr.alloc_comp)
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp2 = gfc_nullify_alloc_comp (sym->ts.u.derived, result, rank);
+ gfc_add_expr_to_block (&block, tmp2);
+ }
+ else if (sym->attr.allocatable && sym->attr.dimension == 0)
+ gfc_add_modify (&block, result, fold_convert (TREE_TYPE (result),
+ null_pointer_node));
}
gfc_add_expr_to_block (&block, tmp);
/* Reset recursion-check variable. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
- {
- gfc_add_modify (&block, recurcheckvar, boolean_false_node);
- recurcheckvar = NULL;
- }
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
+ && !gfc_option.flag_openmp)
+ {
+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);
+ recurcheckvar = NULL;
+ }
if (result == NULL_TREE)
{
{
gfc_add_expr_to_block (&block, tmp);
/* Reset recursion-check variable. */
- if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive)
+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION) && !is_recursive
+ && !gfc_option.flag_openmp)
{
gfc_add_modify (&block, recurcheckvar, boolean_false_node);
recurcheckvar = NULL;
}
+/* Process the local variables of a BLOCK construct. */
+
+void
+gfc_process_block_locals (gfc_namespace* ns)
+{
+ tree decl;
+
+ gcc_assert (saved_local_decls == NULL_TREE);
+ generate_local_vars (ns);
+
+ decl = saved_local_decls;
+ while (decl)
+ {
+ tree next;
+
+ next = TREE_CHAIN (decl);
+ TREE_CHAIN (decl) = NULL_TREE;
+ pushdecl (decl);
+ decl = next;
+ }
+ saved_local_decls = NULL_TREE;
+}
+
+
#include "gt-fortran-trans-decl.h"
OSDN Git Service
