gcc/gcc/fortran/trans-decl.c - Issue 3050029: [gcc] GCC 4.5.0=>4.5.1

Unified Diff: gcc/gcc/fortran/trans-decl.c

Issue 3050029: [gcc] GCC 4.5.0=>4.5.1 (Closed) Base URL: ssh://git@gitrw.chromium.org:9222/nacl-toolchain.git

Patch Set: Created 10 years, 5 months ago

Use n/p to move between diff chunks; N/P to move between comments. Draft comments are only viewable by you.

Jump to:

View side-by-side diff with in-line comments

Index: gcc/gcc/fortran/trans-decl.c

diff --git a/gcc/gcc/fortran/trans-decl.c b/gcc/gcc/fortran/trans-decl.c

index cc7912f6404e92cc9f33fb445291b84e9445a8f8..97eb1cd4d6140ada7997a8ad38a06bf451958a4c 100644

--- a/gcc/gcc/fortran/trans-decl.c

+++ b/gcc/gcc/fortran/trans-decl.c

@@ -1,5 +1,5 @@

/* Backend function setup

Free Software Foundation, Inc.

Contributed by Paul Brook

@@ -37,6 +37,7 @@ along with GCC; see the file COPYING3. If not see

#include "cgraph.h"

#include "debug.h"

#include "gfortran.h"

+#include "pointer-set.h"

#include "trans.h"

#include "trans-types.h"

#include "trans-array.h"

@@ -60,6 +61,12 @@ static GTY(()) tree current_function_return_label;

static GTY(()) tree saved_function_decls;

static GTY(()) tree saved_parent_function_decls;

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

@@ -83,6 +90,7 @@ tree gfor_fndecl_runtime_error_at;

tree gfor_fndecl_runtime_warning_at;

tree gfor_fndecl_os_error;

tree gfor_fndecl_generate_error;

+tree gfor_fndecl_set_args;

tree gfor_fndecl_set_fpe;

tree gfor_fndecl_set_options;

tree gfor_fndecl_set_convert;

@@ -176,6 +184,16 @@ gfc_add_decl_to_function (tree decl)

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

@@ -199,7 +217,8 @@ gfc_build_label_decl (tree label_id)

label_name = NULL;

/* Build the LABEL_DECL node. Labels have no type. */

- label_decl = build_decl (LABEL_DECL, label_id, void_type_node);

+ label_decl = build_decl (input_location,

+ LABEL_DECL, label_id, void_type_node);

DECL_CONTEXT (label_decl) = current_function_decl;

DECL_MODE (label_decl) = VOIDmode;

@@ -285,7 +304,10 @@ gfc_get_label_decl (gfc_st_label * lp)

static tree

gfc_sym_identifier (gfc_symbol * sym)

{

- return (get_identifier (sym->name));

+ if (sym->attr.is_main_program && strcmp (sym->name, "main") == 0)

+ return (get_identifier ("MAIN__"));

+ else

+ return (get_identifier (sym->name));

}

@@ -360,6 +382,14 @@ gfc_sym_mangled_function_id (gfc_symbol * sym)

}

+void

+gfc_set_decl_assembler_name (tree decl, tree name)

+ tree target_mangled = targetm.mangle_decl_assembler_name (decl, name);

+ SET_DECL_ASSEMBLER_NAME (decl, target_mangled);

/* Returns true if a variable of specified size should go on the stack. */

int

@@ -400,7 +430,8 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)

/* Parameters need to be dereferenced. */

if (sym->cp_pointer->attr.dummy)

- ptr_decl = build_fold_indirect_ref (ptr_decl);

+ ptr_decl = build_fold_indirect_ref_loc (input_location,

+ ptr_decl);

/* Check to see if we're dealing with a variable-sized array. */

if (sym->attr.dimension

@@ -414,7 +445,8 @@ gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)

{

ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),

ptr_decl);

- value = build_fold_indirect_ref (ptr_decl);

+ value = build_fold_indirect_ref_loc (input_location,

+ ptr_decl);

}

SET_DECL_VALUE_EXPR (decl, value);

@@ -486,8 +518,11 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)

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

}

@@ -502,7 +537,7 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)

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

@@ -560,6 +595,12 @@ gfc_finish_var_decl (tree decl, gfc_symbol * sym)

if (sym->attr.threadprivate

&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))

DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);

+ if (!sym->attr.target

+ && !sym->attr.pointer

+ && !sym->attr.cray_pointee

+ && !sym->attr.proc_pointer)

+ DECL_RESTRICTED_P (decl) = 1;

}

@@ -706,9 +747,6 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)

layout_type (type);

}

- if (write_symbols == NO_DEBUG)

- return;

if (TYPE_NAME (type) != NULL_TREE

&& GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE

&& TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)

@@ -746,7 +784,8 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)

DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;

}

- TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);

+ TYPE_NAME (type) = type_decl = build_decl (input_location,

+ TYPE_DECL, NULL, gtype);

DECL_ORIGINAL_TYPE (type_decl) = gtype;

}

@@ -780,7 +819,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)

/* Do we know the element size? */

known_size = sym->ts.type != BT_CHARACTER

- || INTEGER_CST_P (sym->ts.cl->backend_decl);

+ || INTEGER_CST_P (sym->ts.u.cl->backend_decl);

if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))

{

@@ -824,7 +863,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)

}

type = gfc_typenode_for_spec (&sym->ts);

- type = gfc_get_nodesc_array_type (type, sym->as, packed);

+ type = gfc_get_nodesc_array_type (type, sym->as, packed,

+ !sym->attr.target);

}

else

{

@@ -838,7 +878,8 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)

}

ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);

- decl = build_decl (VAR_DECL, get_identifier (name), type);

+ decl = build_decl (input_location,

+ VAR_DECL, get_identifier (name), type);

DECL_ARTIFICIAL (decl) = 1;

TREE_PUBLIC (decl) = 0;

@@ -872,6 +913,38 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)

return decl;

}

+/* For symbol SYM with GFC_DECL_SAVED_DESCRIPTOR used in contained

+ function add a VAR_DECL to the current function with DECL_VALUE_EXPR

+ pointing to the artificial variable for debug info purposes. */

+static void

+gfc_nonlocal_dummy_array_decl (gfc_symbol *sym)

+ tree decl, dummy;

+ if (! nonlocal_dummy_decl_pset)

+ nonlocal_dummy_decl_pset = pointer_set_create ();

+ if (pointer_set_insert (nonlocal_dummy_decl_pset, sym->backend_decl))

+ return;

+ dummy = GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl);

+ decl = build_decl (input_location, VAR_DECL, DECL_NAME (dummy),

+ TREE_TYPE (sym->backend_decl));

+ DECL_ARTIFICIAL (decl) = 0;

+ TREE_USED (decl) = 1;

+ TREE_PUBLIC (decl) = 0;

+ TREE_STATIC (decl) = 0;

+ DECL_EXTERNAL (decl) = 0;

+ if (DECL_BY_REFERENCE (dummy))

+ DECL_BY_REFERENCE (decl) = 1;

+ DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (sym->backend_decl);

+ SET_DECL_VALUE_EXPR (decl, sym->backend_decl);

+ DECL_HAS_VALUE_EXPR_P (decl) = 1;

+ DECL_CONTEXT (decl) = DECL_CONTEXT (sym->backend_decl);

+ TREE_CHAIN (decl) = nonlocal_dummy_decls;

+ nonlocal_dummy_decls = decl;

/* Return a constant or a variable to use as a string length. Does not

add the decl to the current scope. */

@@ -879,28 +952,30 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)

static tree

gfc_create_string_length (gfc_symbol * sym)

{

- tree length;

+ gcc_assert (sym->ts.u.cl);

+ gfc_conv_const_charlen (sym->ts.u.cl);

- gcc_assert (sym->ts.cl);

- gfc_conv_const_charlen (sym->ts.cl);

- if (sym->ts.cl->backend_decl == NULL_TREE)

+ if (sym->ts.u.cl->backend_decl == NULL_TREE)

{

+ tree length;

char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];

/* Also prefix the mangled name. */

strcpy (&name[1], sym->name);

name[0] = '.';

- length = build_decl (VAR_DECL, get_identifier (name),

+ length = build_decl (input_location,

+ VAR_DECL, get_identifier (name),

gfc_charlen_type_node);

DECL_ARTIFICIAL (length) = 1;

TREE_USED (length) = 1;

if (sym->ns->proc_name->tlink != NULL)

gfc_defer_symbol_init (sym);

- sym->ts.cl->backend_decl = length;

+ sym->ts.u.cl->backend_decl = length;

}

- return sym->ts.cl->backend_decl;

+ gcc_assert (sym->ts.u.cl->backend_decl != NULL_TREE);

+ return sym->ts.u.cl->backend_decl;

}

/* If a variable is assigned a label, we add another two auxiliary

@@ -918,9 +993,11 @@ gfc_add_assign_aux_vars (gfc_symbol * sym)

decl = sym->backend_decl;

gfc_allocate_lang_decl (decl);

GFC_DECL_ASSIGN (decl) = 1;

- length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),

+ length = build_decl (input_location,

+ VAR_DECL, create_tmp_var_name (sym->name),

gfc_charlen_type_node);

- addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),

+ addr = build_decl (input_location,

+ VAR_DECL, create_tmp_var_name (sym->name),

pvoid_type_node);

gfc_finish_var_decl (length, sym);

gfc_finish_var_decl (addr, sym);

@@ -937,6 +1014,26 @@ gfc_add_assign_aux_vars (gfc_symbol * sym)

GFC_DECL_ASSIGN_ADDR (decl) = addr;

}

+static tree

+add_attributes_to_decl (symbol_attribute sym_attr, tree list)

+ unsigned id;

+ tree attr;

+ for (id = 0; id < EXT_ATTR_NUM; id++)

+ if (sym_attr.ext_attr & (1 << id))

+ {

+ attr = build_tree_list (

+ get_identifier (ext_attr_list[id].middle_end_name),

+ NULL_TREE);

+ list = chainon (list, attr);

+ }

+ return list;

/* Return the decl for a gfc_symbol, create it if it doesn't already

exist. */

@@ -945,13 +1042,14 @@ gfc_get_symbol_decl (gfc_symbol * sym)

{

tree decl;

tree length = NULL_TREE;

+ tree attributes;

int byref;

gcc_assert (sym->attr.referenced

|| sym->attr.use_assoc

|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);

- if (sym->ns && sym->ns->proc_name->attr.function)

+ if (sym->ns && sym->ns->proc_name && sym->ns->proc_name->attr.function)

byref = gfc_return_by_reference (sym->ns->proc_name);

else

byref = 0;

@@ -976,10 +1074,10 @@ gfc_get_symbol_decl (gfc_symbol * sym)

/* Create a character length variable. */

if (sym->ts.type == BT_CHARACTER)

{

- if (sym->ts.cl->backend_decl == NULL_TREE)

+ if (sym->ts.u.cl->backend_decl == NULL_TREE)

length = gfc_create_string_length (sym);

else

- length = sym->ts.cl->backend_decl;

+ length = sym->ts.u.cl->backend_decl;

if (TREE_CODE (length) == VAR_DECL

&& DECL_CONTEXT (length) == NULL_TREE)

{

@@ -1011,12 +1109,45 @@ gfc_get_symbol_decl (gfc_symbol * sym)

{

gfc_add_assign_aux_vars (sym);

}

+ if (sym->attr.dimension

+ && DECL_LANG_SPECIFIC (sym->backend_decl)

+ && GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)

+ && DECL_CONTEXT (sym->backend_decl) != current_function_decl)

+ gfc_nonlocal_dummy_array_decl (sym);

return sym->backend_decl;

}

if (sym->backend_decl)

return sym->backend_decl;

+ /* If use associated and whole file compilation, use the module

+ declaration. This is only needed for intrinsic types because

+ they are substituted for one another during optimization. */

+ if (gfc_option.flag_whole_file

+ && sym->attr.flavor == FL_VARIABLE

+ && sym->ts.type != BT_DERIVED

+ && sym->attr.use_assoc

+ && sym->module)

+ {

+ gfc_gsymbol *gsym;

+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);

+ if (gsym && gsym->ns && gsym->type == GSYM_MODULE)

+ {

+ gfc_symbol *s;

+ s = NULL;

+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);

+ if (s && s->backend_decl)

+ {

+ if (sym->ts.type == BT_CHARACTER)

+ sym->ts.u.cl->backend_decl = s->ts.u.cl->backend_decl;

+ return s->backend_decl;

+ }

/* Catch function declarations. Only used for actual parameters and

procedure pointers. */

if (sym->attr.flavor == FL_PROCEDURE)

@@ -1035,16 +1166,19 @@ gfc_get_symbol_decl (gfc_symbol * sym)

length = gfc_create_string_length (sym);

/* Create the decl for the variable. */

- decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));

+ decl = build_decl (sym->declared_at.lb->location,

+ VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));

- gfc_set_decl_location (decl, &sym->declared_at);

+ /* Add attributes to variables. Functions are handled elsewhere. */

+ attributes = add_attributes_to_decl (sym->attr, NULL_TREE);

+ decl_attributes (&decl, attributes, 0);

/* Symbols from modules should have their assembler names mangled.

This is done here rather than in gfc_finish_var_decl because it

is different for string length variables. */

if (sym->module)

{

- SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));

+ gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));

if (sym->attr.use_assoc)

DECL_IGNORED_P (decl) = 1;

}

@@ -1054,22 +1188,23 @@ gfc_get_symbol_decl (gfc_symbol * sym)

/* 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.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);

@@ -1090,7 +1225,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)

name[0] = '.';

strcpy (&name[1],

IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));

- SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));

+ gfc_set_decl_assembler_name (decl, get_identifier (name));

}

gfc_finish_var_decl (length, sym);

gcc_assert (!sym->value);

@@ -1106,7 +1241,8 @@ gfc_get_symbol_decl (gfc_symbol * sym)

{

tree span;

GFC_DECL_SUBREF_ARRAY_P (decl) = 1;

- span = build_decl (VAR_DECL, create_tmp_var_name ("span"),

+ span = build_decl (input_location,

+ VAR_DECL, create_tmp_var_name ("span"),

gfc_array_index_type);

gfc_finish_var_decl (span, sym);

TREE_STATIC (span) = TREE_STATIC (decl);

@@ -1130,6 +1266,13 @@ gfc_get_symbol_decl (gfc_symbol * sym)

sym->attr.pointer || sym->attr.allocatable);

}

+ if (!TREE_STATIC (decl)

+ && POINTER_TYPE_P (TREE_TYPE (decl))

+ && !sym->attr.pointer

+ && !sym->attr.allocatable

+ && !sym->attr.proc_pointer)

+ DECL_BY_REFERENCE (decl) = 1;

return decl;

}

@@ -1166,12 +1309,14 @@ static tree

get_proc_pointer_decl (gfc_symbol *sym)

{

tree decl;

+ tree attributes;

decl = sym->backend_decl;

if (decl)

return decl;

- decl = build_decl (VAR_DECL, get_identifier (sym->name),

+ decl = build_decl (input_location,

+ VAR_DECL, get_identifier (sym->name),

build_pointer_type (gfc_get_function_type (sym)));

if ((sym->ns->proc_name

@@ -1205,9 +1350,14 @@ get_proc_pointer_decl (gfc_symbol *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);

+ decl_attributes (&decl, attributes, 0);

return decl;

}

@@ -1219,12 +1369,14 @@ gfc_get_extern_function_decl (gfc_symbol * sym)

{

tree type;

tree fndecl;

+ tree attributes;

gfc_expr e;

gfc_intrinsic_sym *isym;

gfc_expr argexpr;

char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */

tree name;

tree mangled_name;

+ gfc_gsymbol *gsym;

if (sym->backend_decl)

return sym->backend_decl;

@@ -1237,6 +1389,62 @@ gfc_get_extern_function_decl (gfc_symbol * sym)

if (sym->attr.proc_pointer)

return get_proc_pointer_decl (sym);

+ /* See if this is an external procedure from the same file. If so,

+ return the backend_decl. */

+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);

+ if (gfc_option.flag_whole_file

+ && !sym->attr.use_assoc

+ && !sym->backend_decl

+ && gsym && gsym->ns

+ && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))

+ && gsym->ns->proc_name->backend_decl)

+ {

+ /* If the namespace has entries, the proc_name is the

+ entry master. Find the entry and use its backend_decl.

+ otherwise, use the proc_name backend_decl. */

+ if (gsym->ns->entries)

+ {

+ gfc_entry_list *entry = gsym->ns->entries;

+ for (; entry; entry = entry->next)

+ {

+ if (strcmp (gsym->name, entry->sym->name) == 0)

+ {

+ sym->backend_decl = entry->sym->backend_decl;

+ break;

+ }

+ else

+ {

+ sym->backend_decl = gsym->ns->proc_name->backend_decl;

+ }

+ if (sym->backend_decl)

+ return sym->backend_decl;

+ }

+ /* See if this is a module procedure from the same file. If so,

+ return the backend_decl. */

+ if (sym->module)

+ gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module);

+ if (gfc_option.flag_whole_file

+ && gsym && gsym->ns

+ && gsym->type == GSYM_MODULE)

+ {

+ gfc_symbol *s;

+ s = NULL;

+ gfc_find_symbol (sym->name, gsym->ns, 0, &s);

+ if (s && s->backend_decl)

+ {

+ sym->backend_decl = s->backend_decl;

+ return sym->backend_decl;

+ }

if (sym->attr.intrinsic)

{

/* Call the resolution function to get the actual name. This is

@@ -1293,15 +1501,13 @@ gfc_get_extern_function_decl (gfc_symbol * sym)

}

type = gfc_get_function_type (sym);

- fndecl = build_decl (FUNCTION_DECL, name, type);

+ fndecl = build_decl (input_location,

+ FUNCTION_DECL, name, type);

- SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);

- /* If the return type is a pointer, avoid alias issues by setting

- DECL_IS_MALLOC to nonzero. This means that the function should be

- treated as if it were a malloc, meaning it returns a pointer that

- is not an alias. */

- if (POINTER_TYPE_P (type))

- DECL_IS_MALLOC (fndecl) = 1;

+ attributes = add_attributes_to_decl (sym->attr, NULL_TREE);

+ decl_attributes (&fndecl, attributes, 0);

+ gfc_set_decl_assembler_name (fndecl, mangled_name);

/* Set the context of this decl. */

if (0 && sym->ns && sym->ns->proc_name)

@@ -1355,7 +1561,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)

static void

build_function_decl (gfc_symbol * sym)

{

- tree fndecl, type;

+ tree fndecl, type, attributes;

symbol_attribute attr;

tree result_decl;

gfc_formal_arglist *f;

@@ -1374,17 +1580,21 @@ build_function_decl (gfc_symbol * sym)

== NAMESPACE_DECL);

type = gfc_get_function_type (sym);

- fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);

+ fndecl = build_decl (input_location,

+ FUNCTION_DECL, gfc_sym_identifier (sym), type);

+ attr = sym->attr;

+ attributes = add_attributes_to_decl (attr, NULL_TREE);

+ decl_attributes (&fndecl, attributes, 0);

/* Perform name mangling if this is a top level or module procedure. */

if (current_function_decl == NULL_TREE)

- SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));

+ gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));

/* Figure out the return type of the declared function, and build a

RESULT_DECL for it. If this is a subroutine with alternate

returns, build a RESULT_DECL for it. */

- attr = sym->attr;

result_decl = NULL_TREE;

/* TODO: Shouldn't this just be TREE_TYPE (TREE_TYPE (fndecl)). */

if (attr.function)

@@ -1418,7 +1628,8 @@ build_function_decl (gfc_symbol * sym)

type = void_type_node;

}

- result_decl = build_decl (RESULT_DECL, result_decl, type);

+ result_decl = build_decl (input_location,

+ RESULT_DECL, result_decl, type);

DECL_ARTIFICIAL (result_decl) = 1;

DECL_IGNORED_P (result_decl) = 1;

DECL_CONTEXT (result_decl) = fndecl;

@@ -1427,13 +1638,6 @@ build_function_decl (gfc_symbol * sym)

/* Don't call layout_decl for a RESULT_DECL.

layout_decl (result_decl, 0); */

- /* If the return type is a pointer, avoid alias issues by setting

- DECL_IS_MALLOC to nonzero. This means that the function should be

- treated as if it were a malloc, meaning it returns a pointer that

- is not an alias. */

- if (POINTER_TYPE_P (type))

- DECL_IS_MALLOC (fndecl) = 1;

/* Set up all attributes for the function. */

DECL_CONTEXT (fndecl) = current_function_decl;

DECL_EXTERNAL (fndecl) = 0;

@@ -1441,7 +1645,7 @@ build_function_decl (gfc_symbol * sym)

/* This specifies if a function is globally visible, i.e. it is

the opposite of declaring static in C. */

if (DECL_CONTEXT (fndecl) == NULL_TREE

- && !sym->attr.entry_master)

+ && !sym->attr.entry_master && !sym->attr.is_main_program)

TREE_PUBLIC (fndecl) = 1;

/* TREE_STATIC means the function body is defined here. */

@@ -1460,11 +1664,6 @@ build_function_decl (gfc_symbol * sym)

TREE_SIDE_EFFECTS (fndecl) = 0;

}

- /* For -fwhole-program to work well, the main program needs to have the

- "externally_visible" attribute. */

- if (attr.is_main_program)

- DECL_ATTRIBUTES (fndecl)

- = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);

/* Layout the function declaration and put it in the binding level

of the current function. */

@@ -1497,7 +1696,8 @@ create_function_arglist (gfc_symbol * sym)

if (sym->attr.entry_master)

{

type = TREE_VALUE (typelist);

- parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);

+ parm = build_decl (input_location,

+ PARM_DECL, get_identifier ("__entry"), type);

DECL_CONTEXT (parm) = fndecl;

DECL_ARG_TYPE (parm) = type;

@@ -1519,12 +1719,13 @@ create_function_arglist (gfc_symbol * sym)

tree len_type = TREE_VALUE (TREE_CHAIN (typelist));

gcc_assert (len_type == gfc_charlen_type_node);

- length = build_decl (PARM_DECL,

+ length = build_decl (input_location,

+ PARM_DECL,

get_identifier (".__result"),

len_type);

- if (!sym->ts.cl->length)

+ if (!sym->ts.u.cl->length)

{

- sym->ts.cl->backend_decl = length;

+ sym->ts.u.cl->backend_decl = length;

TREE_USED (length) = 1;

}

gcc_assert (TREE_CODE (length) == PARM_DECL);

@@ -1533,20 +1734,21 @@ create_function_arglist (gfc_symbol * sym)

TREE_READONLY (length) = 1;

DECL_ARTIFICIAL (length) = 1;

gfc_finish_decl (length);

- if (sym->ts.cl->backend_decl == NULL

- || sym->ts.cl->backend_decl == length)

+ if (sym->ts.u.cl->backend_decl == NULL

+ || sym->ts.u.cl->backend_decl == length)

{

gfc_symbol *arg;

tree backend_decl;

- if (sym->ts.cl->backend_decl == NULL)

+ if (sym->ts.u.cl->backend_decl == NULL)

{

- tree len = build_decl (VAR_DECL,

+ tree len = build_decl (input_location,

+ VAR_DECL,

get_identifier ("..__result"),

gfc_charlen_type_node);

DECL_ARTIFICIAL (len) = 1;

TREE_USED (len) = 1;

- sym->ts.cl->backend_decl = len;

+ sym->ts.u.cl->backend_decl = len;

}

/* Make sure PARM_DECL type doesn't point to incomplete type. */

@@ -1561,7 +1763,8 @@ create_function_arglist (gfc_symbol * sym)

}

- parm = build_decl (PARM_DECL, get_identifier ("__result"), type);

+ parm = build_decl (input_location,

+ PARM_DECL, get_identifier ("__result"), type);

DECL_CONTEXT (parm) = fndecl;

DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);

@@ -1595,7 +1798,8 @@ create_function_arglist (gfc_symbol * sym)

type = TREE_VALUE (typelist);

- if (f->sym->ts.type == BT_CHARACTER)

+ if (f->sym->ts.type == BT_CHARACTER

+ && (!sym->attr.is_bind_c || sym->attr.entry_master))

{

tree len_type = TREE_VALUE (hidden_typelist);

tree length = NULL_TREE;

@@ -1603,7 +1807,8 @@ create_function_arglist (gfc_symbol * sym)

strcpy (&name[1], f->sym->name);

name[0] = '_';

- length = build_decl (PARM_DECL, get_identifier (name), len_type);

+ length = build_decl (input_location,

+ PARM_DECL, get_identifier (name), len_type);

hidden_arglist = chainon (hidden_arglist, length);

DECL_CONTEXT (length) = fndecl;

@@ -1612,22 +1817,30 @@ create_function_arglist (gfc_symbol * sym)

TREE_READONLY (length) = 1;

gfc_finish_decl (length);

- /* TODO: Check string lengths when -fbounds-check. */

+ /* Remember the passed value. */

+ if (f->sym->ts.u.cl->passed_length != NULL)

+ {

+ /* This can happen if the same type is used for multiple

+ arguments. We need to copy cl as otherwise

+ cl->passed_length gets overwritten. */

+ f->sym->ts.u.cl = gfc_new_charlen (f->sym->ns, f->sym->ts.u.cl);

+ }

+ f->sym->ts.u.cl->passed_length = length;

/* Use the passed value for assumed length variables. */

- if (!f->sym->ts.cl->length)

+ if (!f->sym->ts.u.cl->length)

{

TREE_USED (length) = 1;

- gcc_assert (!f->sym->ts.cl->backend_decl);

- f->sym->ts.cl->backend_decl = length;

+ gcc_assert (!f->sym->ts.u.cl->backend_decl);

+ f->sym->ts.u.cl->backend_decl = length;

}

hidden_typelist = TREE_CHAIN (hidden_typelist);

- if (f->sym->ts.cl->backend_decl == NULL

- || f->sym->ts.cl->backend_decl == length)

+ if (f->sym->ts.u.cl->backend_decl == NULL

+ || f->sym->ts.u.cl->backend_decl == length)

{

- if (f->sym->ts.cl->backend_decl == NULL)

+ if (f->sym->ts.u.cl->backend_decl == NULL)

gfc_create_string_length (f->sym);

/* Make sure PARM_DECL type doesn't point to incomplete type. */

@@ -1657,7 +1870,8 @@ create_function_arglist (gfc_symbol * sym)

type = build_pointer_type (type);

/* Build the argument declaration. */

- parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);

+ parm = build_decl (input_location,

+ PARM_DECL, gfc_sym_identifier (f->sym), type);

/* Fill in arg stuff. */

DECL_CONTEXT (parm) = fndecl;

@@ -1687,30 +1901,6 @@ create_function_arglist (gfc_symbol * sym)

DECL_ARGUMENTS (fndecl) = arglist;

}

-/* Convert FNDECL's code to GIMPLE and handle any nested functions. */

-static void

-gfc_gimplify_function (tree fndecl)

- struct cgraph_node *cgn;

- gimplify_function_tree (fndecl);

- dump_function (TDI_generic, fndecl);

- /* Generate errors for structured block violations. */

- /* ??? Could be done as part of resolve_labels. */

- if (flag_openmp)

- diagnose_omp_structured_block_errors (fndecl);

- /* Convert all nested functions to GIMPLE now. We do things in this order

- so that items like VLA sizes are expanded properly in the context of the

- correct function. */

- cgn = cgraph_node (fndecl);

- for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)

- gfc_gimplify_function (cgn->decl);

/* Do the setup necessary before generating the body of a function. */

static void

@@ -1821,7 +2011,7 @@ build_entry_thunks (gfc_namespace * ns)

args);

if (formal->sym->ts.type == BT_CHARACTER)

{

- tmp = thunk_formal->sym->ts.cl->backend_decl;

+ tmp = thunk_formal->sym->ts.u.cl->backend_decl;

string_args = tree_cons (NULL_TREE, tmp, string_args);

}

@@ -1841,13 +2031,14 @@ build_entry_thunks (gfc_namespace * ns)

args = nreverse (args);

args = chainon (args, nreverse (string_args));

tmp = ns->proc_name->backend_decl;

- tmp = build_function_call_expr (tmp, args);

+ tmp = build_function_call_expr (input_location, tmp, args);

if (ns->proc_name->attr.mixed_entry_master)

{

tree union_decl, field;

tree master_type = TREE_TYPE (ns->proc_name->backend_decl);

- union_decl = build_decl (VAR_DECL, get_identifier ("__result"),

+ union_decl = build_decl (input_location,

+ VAR_DECL, get_identifier ("__result"),

TREE_TYPE (master_type));

DECL_ARTIFICIAL (union_decl) = 1;

DECL_EXTERNAL (union_decl) = 0;

@@ -1907,8 +2098,7 @@ build_entry_thunks (gfc_namespace * ns)

current_function_decl = NULL_TREE;

- gfc_gimplify_function (thunk_fndecl);

- cgraph_finalize_function (thunk_fndecl, false);

+ cgraph_finalize_function (thunk_fndecl, true);

/* We share the symbols in the formal argument list with other entry

points and the master function. Clear them so that they are

@@ -1918,15 +2108,15 @@ build_entry_thunks (gfc_namespace * ns)

{

formal->sym->backend_decl = NULL_TREE;

if (formal->sym->ts.type == BT_CHARACTER)

- formal->sym->ts.cl->backend_decl = NULL_TREE;

+ formal->sym->ts.u.cl->backend_decl = NULL_TREE;

}

if (thunk_sym->attr.function)

{

if (thunk_sym->ts.type == BT_CHARACTER)

- thunk_sym->ts.cl->backend_decl = NULL_TREE;

+ thunk_sym->ts.u.cl->backend_decl = NULL_TREE;

if (thunk_sym->result->ts.type == BT_CHARACTER)

- thunk_sym->result->ts.cl->backend_decl = NULL_TREE;

+ thunk_sym->result->ts.u.cl->backend_decl = NULL_TREE;

}

@@ -2035,10 +2225,10 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)

if (sym->ts.type == BT_CHARACTER)

{

- if (sym->ts.cl->backend_decl == NULL_TREE)

+ if (sym->ts.u.cl->backend_decl == NULL_TREE)

length = gfc_create_string_length (sym);

else

- length = sym->ts.cl->backend_decl;

+ length = sym->ts.u.cl->backend_decl;

if (TREE_CODE (length) == VAR_DECL

&& DECL_CONTEXT (length) == NULL_TREE)

gfc_add_decl_to_function (length);

@@ -2062,10 +2252,12 @@ gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)

IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));

if (!sym->attr.mixed_entry_master && sym->attr.function)

- decl = build_decl (VAR_DECL, get_identifier (name),

+ decl = build_decl (input_location,

+ VAR_DECL, get_identifier (name),

gfc_sym_type (sym));

else

- decl = build_decl (VAR_DECL, get_identifier (name),

+ decl = build_decl (input_location,

+ VAR_DECL, get_identifier (name),

TREE_TYPE (TREE_TYPE (this_function_decl)));

DECL_ARTIFICIAL (decl) = 1;

DECL_EXTERNAL (decl) = 0;

@@ -2125,7 +2317,8 @@ gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)

/* Build the function type and decl. */

fntype = build_function_type (rettype, arglist);

- fndecl = build_decl (FUNCTION_DECL, name, fntype);

+ fndecl = build_decl (input_location,

+ FUNCTION_DECL, name, fntype);

/* Mark this decl as external. */

DECL_EXTERNAL (fndecl) = 1;

@@ -2563,6 +2756,11 @@ gfc_build_builtin_function_decls (void)

/* The runtime_error function does not return. */

TREE_THIS_VOLATILE (gfor_fndecl_os_error) = 1;

+ gfor_fndecl_set_args =

+ gfc_build_library_function_decl (get_identifier (PREFIX("set_args")),

+ void_type_node, 2, integer_type_node,

+ build_pointer_type (pchar_type_node));

gfor_fndecl_set_fpe =

gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),

void_type_node, 1, integer_type_node);

@@ -2571,7 +2769,7 @@ gfc_build_builtin_function_decls (void)

gfor_fndecl_set_options =

gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),

void_type_node, 2, integer_type_node,

- pvoid_type_node);

+ build_pointer_type (integer_type_node));

gfor_fndecl_set_convert =

gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),

@@ -2636,12 +2834,12 @@ gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)

tree tmp;

gcc_assert (sym->backend_decl);

- gcc_assert (sym->ts.cl && sym->ts.cl->length);

+ gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);

gfc_start_block (&body);

/* Evaluate the string length expression. */

- gfc_conv_string_length (sym->ts.cl, NULL, &body);

+ gfc_conv_string_length (sym->ts.u.cl, NULL, &body);

gfc_trans_vla_type_sizes (sym, &body);

@@ -2797,11 +2995,12 @@ gfc_init_default_dt (gfc_symbol * sym, tree body)

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,

- tmp, build_empty_stmt ());

+ tmp, build_empty_stmt (input_location));

}

gfc_add_expr_to_block (&fnblock, tmp);

gfc_free_expr (e);

@@ -2829,19 +3028,23 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree body)

&& !f->sym->attr.pointer

&& f->sym->ts.type == BT_DERIVED)

{

- if (f->sym->ts.derived->attr.alloc_comp && !f->sym->value)

+ if (f->sym->ts.u.derived->attr.alloc_comp && !f->sym->value)

{

- tmp = gfc_deallocate_alloc_comp (f->sym->ts.derived,

+ 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 ());

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

}

- else if (f->sym->value)

+ else if (f->sym->value)

body = gfc_init_default_dt (f->sym, body);

}

@@ -2855,9 +3058,10 @@ init_intent_out_dt (gfc_symbol * proc_sym, tree 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;

@@ -2891,14 +3095,14 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)

/* An automatic character length, pointer array result. */

if (proc_sym->ts.type == BT_CHARACTER

- && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)

- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,

+ && TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)

+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,

fnbody);

}

else if (proc_sym->ts.type == BT_CHARACTER)

{

- if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)

- fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,

+ if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == VAR_DECL)

+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.u.cl,

fnbody);

}

else

@@ -2914,7 +3118,7 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)

for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)

{

bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)

- && sym->ts.derived->attr.alloc_comp;

+ && sym->ts.u.derived->attr.alloc_comp;

if (sym->attr.dimension)

{

switch (sym->as->type)

@@ -2956,10 +3160,11 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)

case AS_ASSUMED_SIZE:

/* Must be a dummy parameter. */

- gcc_assert (sym->attr.dummy);

+ gcc_assert (sym->attr.dummy || sym->as->cp_was_assumed);

/* We should always pass assumed size arrays the g77 way. */

- fnbody = gfc_trans_g77_array (sym, fnbody);

+ if (sym->attr.dummy)

+ fnbody = gfc_trans_g77_array (sym, fnbody);

break;

case AS_ASSUMED_SHAPE:

@@ -2983,12 +3188,49 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)

}

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

gfc_set_backend_locus (&sym->declared_at);

if (sym->attr.dummy || sym->attr.result)

- fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);

+ fnbody = gfc_trans_dummy_character (sym, sym->ts.u.cl, fnbody);

else

fnbody = gfc_trans_auto_character_variable (sym, fnbody);

gfc_set_backend_locus (&loc);

@@ -3015,8 +3257,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)

{

if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)

{

- gcc_assert (f->sym->ts.cl->backend_decl != NULL);

- if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)

+ gcc_assert (f->sym->ts.u.cl->backend_decl != NULL);

+ if (TREE_CODE (f->sym->ts.u.cl->backend_decl) == PARM_DECL)

gfc_trans_vla_type_sizes (f->sym, &body);

}

@@ -3024,8 +3266,8 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)

if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER

&& current_fake_result_decl != NULL)

{

- gcc_assert (proc_sym->ts.cl->backend_decl != NULL);

- if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)

+ gcc_assert (proc_sym->ts.u.cl->backend_decl != NULL);

+ if (TREE_CODE (proc_sym->ts.u.cl->backend_decl) == PARM_DECL)

gfc_trans_vla_type_sizes (proc_sym, &body);

}

@@ -3140,11 +3382,16 @@ gfc_create_module_variable (gfc_symbol * sym)

{

decl = sym->backend_decl;

gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);

- gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE

- || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);

- gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE

- || DECL_CONTEXT (TYPE_STUB_DECL (decl))

- == sym->ns->proc_name->backend_decl);

+ /* -fwhole-file mixes up the contexts so these asserts are unnecessary. */

+ if (!(gfc_option.flag_whole_file && sym->attr.use_assoc))

+ {

+ gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE

+ || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);

+ gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE

+ || DECL_CONTEXT (TYPE_STUB_DECL (decl))

+ == sym->ns->proc_name->backend_decl);

+ }

TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;

DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;

gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));

@@ -3177,7 +3424,7 @@ gfc_create_module_variable (gfc_symbol * sym)

&& (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);

@@ -3199,8 +3446,9 @@ gfc_create_module_variable (gfc_symbol * sym)

{

tree length;

- length = sym->ts.cl->backend_decl;

- if (!INTEGER_CST_P (length))

+ length = sym->ts.u.cl->backend_decl;

+ gcc_assert (length || sym->attr.proc_pointer);

+ if (length && !INTEGER_CST_P (length))

{

pushdecl (length);

rest_of_decl_compilation (length, 1, 0);

@@ -3223,7 +3471,8 @@ gfc_trans_use_stmts (gfc_namespace * ns)

if (entry->namespace_decl == NULL)

{

entry->namespace_decl

- = build_decl (NAMESPACE_DECL,

+ = build_decl (input_location,

+ NAMESPACE_DECL,

get_identifier (use_stmt->module_name),

void_type_node);

DECL_EXTERNAL (entry->namespace_decl) = 1;

@@ -3254,8 +3503,8 @@ gfc_trans_use_stmts (gfc_namespace * ns)

? rent->local_name : rent->use_name);

gcc_assert (st);

- /* Fixing-up doubly contained symbols, sometimes results in

- ambiguity, which is caught here. */

+ /* Sometimes, generic interfaces wind up being over-ruled by a

+ local symbol (see PR41062). */

if (!st->n.sym->attr.use_assoc)

continue;

@@ -3334,7 +3583,7 @@ check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,

case BT_DERIVED:

if (expr->expr_type != EXPR_STRUCTURE)

return false;

- cm = expr->ts.derived->components;

+ cm = expr->ts.u.derived->components;

for (c = expr->value.constructor; c; c = c->next, cm = cm->next)

{

if (!c->expr || cm->attr.allocatable)

@@ -3380,12 +3629,12 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)

if (sym->ts.type == BT_CHARACTER)

{

- gfc_conv_const_charlen (sym->ts.cl);

- if (sym->ts.cl->backend_decl == NULL

- || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)

+ gfc_conv_const_charlen (sym->ts.u.cl);

+ if (sym->ts.u.cl->backend_decl == NULL

+ || TREE_CODE (sym->ts.u.cl->backend_decl) != INTEGER_CST)

return;

}

- else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)

+ else if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.alloc_comp)

return;

if (sym->as)

@@ -3406,7 +3655,8 @@ gfc_emit_parameter_debug_info (gfc_symbol *sym)

return;

/* Create the decl for the variable or constant. */

- decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,

+ decl = build_decl (input_location,

+ sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,

gfc_sym_identifier (sym), gfc_sym_type (sym));

if (sym->attr.flavor == FL_PARAMETER)

TREE_READONLY (decl) = 1;

@@ -3512,10 +3762,10 @@ generate_dependency_declarations (gfc_symbol *sym)

int i;

if (sym->ts.type == BT_CHARACTER

- && sym->ts.cl

- && sym->ts.cl->length

- && sym->ts.cl->length->expr_type != EXPR_CONSTANT)

- generate_expr_decls (sym, sym->ts.cl->length);

+ && sym->ts.u.cl

+ && sym->ts.u.cl->length

+ && sym->ts.u.cl->length->expr_type != EXPR_CONSTANT)

+ generate_expr_decls (sym, sym->ts.u.cl->length);

if (sym->as && sym->as->rank)

{

@@ -3546,8 +3796,12 @@ generate_local_decl (gfc_symbol * sym)

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,

@@ -3566,27 +3820,28 @@ generate_local_decl (gfc_symbol * sym)

warning if requested. */

if (sym->attr.dummy && !sym->attr.referenced

&& sym->ts.type == BT_CHARACTER

- && sym->ts.cl->backend_decl != NULL

- && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)

+ && sym->ts.u.cl->backend_decl != NULL

+ && TREE_CODE (sym->ts.u.cl->backend_decl) == VAR_DECL)

{

sym->attr.referenced = 1;

gfc_get_symbol_decl (sym);

}

- /* INTENT(out) dummy arguments with allocatable components are reset

- by default and need to be set referenced to generate the code for

- automatic lengths. */

- if (sym->attr.dummy && !sym->attr.referenced

+ /* INTENT(out) dummy arguments and result variables with allocatable

+ components are reset by default and need to be set referenced to

+ generate the code for nullification and automatic lengths. */

+ if (!sym->attr.referenced

&& sym->ts.type == BT_DERIVED

+ && sym->ts.u.derived->attr.alloc_comp

&& !sym->attr.pointer

- && sym->ts.derived->attr.alloc_comp

- && sym->attr.intent == INTENT_OUT)

+ && ((sym->attr.dummy && sym->attr.intent == INTENT_OUT)

+ ||

+ (sym->attr.result && sym != sym->result)))

{

sym->attr.referenced = 1;

gfc_get_symbol_decl (sym);

}

/* Check for dependencies in the array specification and string

length, adding the necessary declarations to the function. We

mark the symbol now, as well as in traverse_ns, to prevent

@@ -3689,6 +3944,314 @@ gfc_trans_entry_master_switch (gfc_entry_list * el)

}

+/* Add code to string lengths of actual arguments passed to a function against

+ the expected lengths of the dummy arguments. */

+static void

+add_argument_checking (stmtblock_t *block, gfc_symbol *sym)

+ gfc_formal_arglist *formal;

+ for (formal = sym->formal; formal; formal = formal->next)

+ if (formal->sym && formal->sym->ts.type == BT_CHARACTER)

+ {

+ enum tree_code comparison;

+ tree cond;

+ tree argname;

+ gfc_symbol *fsym;

+ gfc_charlen *cl;

+ const char *message;

+ fsym = formal->sym;

+ cl = fsym->ts.u.cl;

+ gcc_assert (cl);

+ gcc_assert (cl->passed_length != NULL_TREE);

+ gcc_assert (cl->backend_decl != NULL_TREE);

+ /* For POINTER, ALLOCATABLE and assumed-shape dummy arguments, the

+ string lengths must match exactly. Otherwise, it is only required

+ that the actual string length is *at least* the expected one.

+ Sequence association allows for a mismatch of the string length

+ if the actual argument is (part of) an array, but only if the

+ dummy argument is an array. (See "Sequence association" in

+ Section 12.4.1.4 for F95 and 12.4.1.5 for F2003.) */

+ if (fsym->attr.pointer || fsym->attr.allocatable

+ || (fsym->as && fsym->as->type == AS_ASSUMED_SHAPE))

+ {

+ comparison = NE_EXPR;

+ message = _("Actual string length does not match the declared one"

+ " for dummy argument '%s' (%ld/%ld)");

+ }

+ else if (fsym->as && fsym->as->rank != 0)

+ continue;

+ else

+ {

+ comparison = LT_EXPR;

+ message = _("Actual string length is shorter than the declared one"

+ " for dummy argument '%s' (%ld/%ld)");

+ }

+ /* Build the condition. For optional arguments, an actual length

+ of 0 is also acceptable if the associated string is NULL, which

+ means the argument was not passed. */

+ cond = fold_build2 (comparison, boolean_type_node,

+ cl->passed_length, cl->backend_decl);

+ if (fsym->attr.optional)

+ {

+ tree not_absent;

+ tree not_0length;

+ tree absent_failed;

+ not_0length = fold_build2 (NE_EXPR, boolean_type_node,

+ cl->passed_length,

+ fold_convert (gfc_charlen_type_node,

+ integer_zero_node));

+ /* The symbol needs to be referenced for gfc_get_symbol_decl. */

+ fsym->attr.referenced = 1;

+ not_absent = gfc_conv_expr_present (fsym);

+ absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,

+ not_0length, not_absent);

+ cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,

+ cond, absent_failed);

+ }

+ /* Build the runtime check. */

+ argname = gfc_build_cstring_const (fsym->name);

+ argname = gfc_build_addr_expr (pchar_type_node, argname);

+ gfc_trans_runtime_check (true, false, cond, block, &fsym->declared_at,

+ message, argname,

+ fold_convert (long_integer_type_node,

+ cl->passed_length),

+ fold_convert (long_integer_type_node,

+ cl->backend_decl));

+ }

+static void

+create_main_function (tree fndecl)

+ tree old_context;

+ tree ftn_main;

+ tree tmp, decl, result_decl, argc, argv, typelist, arglist;

+ stmtblock_t body;

+ old_context = current_function_decl;

+ if (old_context)

+ {

+ push_function_context ();

+ saved_parent_function_decls = saved_function_decls;

+ saved_function_decls = NULL_TREE;

+ }

+ /* main() function must be declared with global scope. */

+ gcc_assert (current_function_decl == NULL_TREE);

+ /* Declare the function. */

+ tmp = build_function_type_list (integer_type_node, integer_type_node,

+ build_pointer_type (pchar_type_node),

+ NULL_TREE);

+ main_identifier_node = get_identifier ("main");

+ ftn_main = build_decl (input_location, FUNCTION_DECL,

+ main_identifier_node, tmp);

+ DECL_EXTERNAL (ftn_main) = 0;

+ TREE_PUBLIC (ftn_main) = 1;

+ TREE_STATIC (ftn_main) = 1;

+ DECL_ATTRIBUTES (ftn_main)

+ = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);

+ /* Setup the result declaration (for "return 0"). */

+ result_decl = build_decl (input_location,

+ RESULT_DECL, NULL_TREE, integer_type_node);

+ DECL_ARTIFICIAL (result_decl) = 1;

+ DECL_IGNORED_P (result_decl) = 1;

+ DECL_CONTEXT (result_decl) = ftn_main;

+ DECL_RESULT (ftn_main) = result_decl;

+ pushdecl (ftn_main);

+ /* Get the arguments. */

+ arglist = NULL_TREE;

+ typelist = TYPE_ARG_TYPES (TREE_TYPE (ftn_main));

+ tmp = TREE_VALUE (typelist);

+ argc = build_decl (input_location, PARM_DECL, get_identifier ("argc"), tmp);

+ DECL_CONTEXT (argc) = ftn_main;

+ DECL_ARG_TYPE (argc) = TREE_VALUE (typelist);

+ TREE_READONLY (argc) = 1;

+ gfc_finish_decl (argc);

+ arglist = chainon (arglist, argc);

+ typelist = TREE_CHAIN (typelist);

+ tmp = TREE_VALUE (typelist);

+ argv = build_decl (input_location, PARM_DECL, get_identifier ("argv"), tmp);

+ DECL_CONTEXT (argv) = ftn_main;

+ DECL_ARG_TYPE (argv) = TREE_VALUE (typelist);

+ TREE_READONLY (argv) = 1;

+ DECL_BY_REFERENCE (argv) = 1;

+ gfc_finish_decl (argv);

+ arglist = chainon (arglist, argv);

+ DECL_ARGUMENTS (ftn_main) = arglist;

+ current_function_decl = ftn_main;

+ announce_function (ftn_main);

+ rest_of_decl_compilation (ftn_main, 1, 0);

+ make_decl_rtl (ftn_main);

+ init_function_start (ftn_main);

+ pushlevel (0);

+ gfc_init_block (&body);

+ /* Call some libgfortran initialization routines, call then MAIN__(). */

+ /* Call _gfortran_set_args (argc, argv). */

+ TREE_USED (argc) = 1;

+ TREE_USED (argv) = 1;

+ tmp = build_call_expr_loc (input_location,

+ gfor_fndecl_set_args, 2, argc, argv);

+ gfc_add_expr_to_block (&body, tmp);

+ /* Add a call to set_options to set up the runtime library Fortran

+ language standard parameters. */

+ {

+ tree array_type, array, var;

+ /* Passing a new option to the library requires four modifications:

+ + add it to the tree_cons list below

+ + change the array size in the call to build_array_type

+ + change the first argument to the library call

+ gfor_fndecl_set_options

+ + modify the library (runtime/compile_options.c)! */

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,

+ gfc_option.warn_std), NULL_TREE);

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,

+ gfc_option.allow_std), array);

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node, pedantic),

+ array);

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,

+ gfc_option.flag_dump_core), array);

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,

+ gfc_option.flag_backtrace), array);

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,

+ gfc_option.flag_sign_zero), array);

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,

+ (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)), array);

+ array = tree_cons (NULL_TREE, build_int_cst (integer_type_node,

+ gfc_option.flag_range_check), array);

+ array_type = build_array_type (integer_type_node,

+ build_index_type (build_int_cst (NULL_TREE, 7)));

+ array = build_constructor_from_list (array_type, nreverse (array));

+ TREE_CONSTANT (array) = 1;

+ TREE_STATIC (array) = 1;

+ /* Create a static variable to hold the jump table. */

+ var = gfc_create_var (array_type, "options");

+ TREE_CONSTANT (var) = 1;

+ TREE_STATIC (var) = 1;

+ TREE_READONLY (var) = 1;

+ DECL_INITIAL (var) = array;

+ var = gfc_build_addr_expr (build_pointer_type (integer_type_node), var);

+ tmp = build_call_expr_loc (input_location,

+ gfor_fndecl_set_options, 2,

+ build_int_cst (integer_type_node, 8), var);

+ gfc_add_expr_to_block (&body, tmp);

+ }

+ /* If -ffpe-trap option was provided, add a call to set_fpe so that

+ the library will raise a FPE when needed. */

+ if (gfc_option.fpe != 0)

+ {

+ tmp = build_call_expr_loc (input_location,

+ gfor_fndecl_set_fpe, 1,

+ build_int_cst (integer_type_node,

+ gfc_option.fpe));

+ gfc_add_expr_to_block (&body, tmp);

+ }

+ /* If this is the main program and an -fconvert option was provided,

+ add a call to set_convert. */

+ if (gfc_option.convert != GFC_CONVERT_NATIVE)

+ {

+ tmp = build_call_expr_loc (input_location,

+ gfor_fndecl_set_convert, 1,

+ build_int_cst (integer_type_node,

+ gfc_option.convert));

+ gfc_add_expr_to_block (&body, tmp);

+ }

+ /* If this is the main program and an -frecord-marker option was provided,

+ add a call to set_record_marker. */

+ if (gfc_option.record_marker != 0)

+ {

+ tmp = build_call_expr_loc (input_location,

+ gfor_fndecl_set_record_marker, 1,

+ build_int_cst (integer_type_node,

+ gfc_option.record_marker));

+ gfc_add_expr_to_block (&body, tmp);

+ }

+ if (gfc_option.max_subrecord_length != 0)

+ {

+ tmp = build_call_expr_loc (input_location,

+ gfor_fndecl_set_max_subrecord_length, 1,

+ build_int_cst (integer_type_node,

+ gfc_option.max_subrecord_length));

+ gfc_add_expr_to_block (&body, tmp);

+ }

+ /* Call MAIN__(). */

+ tmp = build_call_expr_loc (input_location,

+ fndecl, 0);

+ gfc_add_expr_to_block (&body, tmp);

+ /* Mark MAIN__ as used. */

+ TREE_USED (fndecl) = 1;

+ /* "return 0". */

+ tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),

+ build_int_cst (integer_type_node, 0));

+ tmp = build1_v (RETURN_EXPR, tmp);

+ gfc_add_expr_to_block (&body, tmp);

+ DECL_SAVED_TREE (ftn_main) = gfc_finish_block (&body);

+ decl = getdecls ();

+ /* Finish off this function and send it for code generation. */

+ poplevel (1, 0, 1);

+ BLOCK_SUPERCONTEXT (DECL_INITIAL (ftn_main)) = ftn_main;

+ DECL_SAVED_TREE (ftn_main)

+ = build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (ftn_main),

+ DECL_INITIAL (ftn_main));

+ /* Output the GENERIC tree. */

+ dump_function (TDI_original, ftn_main);

+ cgraph_finalize_function (ftn_main, true);

+ if (old_context)

+ {

+ pop_function_context ();

+ saved_function_decls = saved_parent_function_decls;

+ }

+ current_function_decl = old_context;

/* Generate code for a function. */

void

@@ -3702,8 +4265,10 @@ gfc_generate_function_code (gfc_namespace * ns)

stmtblock_t block;

stmtblock_t body;

tree result;

+ tree recurcheckvar = NULL_TREE;

gfc_symbol *sym;

int rank;

+ bool is_recursive;

sym = ns->proc_name;

@@ -3736,10 +4301,10 @@ gfc_generate_function_code (gfc_namespace * ns)

gfc_entry_list *el;

tree backend_decl;

- gfc_conv_const_charlen (ns->proc_name->ts.cl);

- backend_decl = ns->proc_name->result->ts.cl->backend_decl;

+ gfc_conv_const_charlen (ns->proc_name->ts.u.cl);

+ backend_decl = ns->proc_name->result->ts.u.cl->backend_decl;

for (el = ns->entries; el; el = el->next)

- el->sym->result->ts.cl->backend_decl = backend_decl;

+ el->sym->result->ts.u.cl->backend_decl = backend_decl;

}

/* Translate COMMON blocks. */

@@ -3753,6 +4318,9 @@ gfc_generate_function_code (gfc_namespace * ns)

gfc_generate_contained_functions (ns);

+ nonlocal_dummy_decls = NULL;

+ nonlocal_dummy_decl_pset = NULL;

generate_local_vars (ns);

/* Keep the parent fake result declaration in module functions

@@ -3768,108 +4336,29 @@ gfc_generate_function_code (gfc_namespace * ns)

/* Now generate the code for the body of this function. */

gfc_init_block (&body);

- /* If this is the main program, add a call to set_options to set up the

- runtime library Fortran language standard parameters. */

- if (sym->attr.is_main_program)

- {

- tree array_type, array, var;

- /* Passing a new option to the library requires four modifications:

- + add it to the tree_cons list below

- + change the array size in the call to build_array_type

- + change the first argument to the library call

- gfor_fndecl_set_options

- + modify the library (runtime/compile_options.c)! */

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node,

- gfc_option.warn_std), NULL_TREE);

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node,

- gfc_option.allow_std), array);

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node, pedantic), array);

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node,

- gfc_option.flag_dump_core), array);

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node,

- gfc_option.flag_backtrace), array);

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node,

- gfc_option.flag_sign_zero), array);

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node,

- flag_bounds_check), array);

- array = tree_cons (NULL_TREE,

- build_int_cst (integer_type_node,

- gfc_option.flag_range_check), array);

- array_type = build_array_type (integer_type_node,

- build_index_type (build_int_cst (NULL_TREE,

- 7)));

- array = build_constructor_from_list (array_type, nreverse (array));

- TREE_CONSTANT (array) = 1;

- TREE_STATIC (array) = 1;

- /* Create a static variable to hold the jump table. */

- var = gfc_create_var (array_type, "options");

- TREE_CONSTANT (var) = 1;

- TREE_STATIC (var) = 1;

- TREE_READONLY (var) = 1;

- DECL_INITIAL (var) = array;

- var = gfc_build_addr_expr (pvoid_type_node, var);

- tmp = build_call_expr (gfor_fndecl_set_options, 2,

- build_int_cst (integer_type_node, 8), var);

- gfc_add_expr_to_block (&body, tmp);

- }

- /* If this is the main program and a -ffpe-trap option was provided,

- add a call to set_fpe so that the library will raise a FPE when

- needed. */

- if (sym->attr.is_main_program && gfc_option.fpe != 0)

- {

- tmp = build_call_expr (gfor_fndecl_set_fpe, 1,

- build_int_cst (integer_type_node,

- gfc_option.fpe));

- gfc_add_expr_to_block (&body, tmp);

- }

- /* If this is the main program and an -fconvert option was provided,

- add a call to set_convert. */

- if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)

- {

- tmp = build_call_expr (gfor_fndecl_set_convert, 1,

- build_int_cst (integer_type_node,

- gfc_option.convert));

- gfc_add_expr_to_block (&body, tmp);

- }

- /* If this is the main program and an -frecord-marker option was provided,

- add a call to set_record_marker. */

- if (sym->attr.is_main_program && gfc_option.record_marker != 0)

- {

- tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,

- build_int_cst (integer_type_node,

- gfc_option.record_marker));

- gfc_add_expr_to_block (&body, tmp);

- }

- if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)

- {

- tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,

- 1,

- build_int_cst (integer_type_node,

- gfc_option.max_subrecord_length));

- gfc_add_expr_to_block (&body, tmp);

+ is_recursive = sym->attr.recursive

+ || (sym->attr.entry_master

+ && sym->ns->entries->sym->attr.recursive);

+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)

+ && !is_recursive

+ && !gfc_option.flag_recursive)

+ {

+ char * msg;

+ asprintf (&msg, "Recursive call to nonrecursive procedure '%s'",

+ sym->name);

+ recurcheckvar = gfc_create_var (boolean_type_node, "is_recursive");

+ TREE_STATIC (recurcheckvar) = 1;

+ DECL_INITIAL (recurcheckvar) = boolean_false_node;

+ gfc_add_expr_to_block (&block, recurcheckvar);

+ gfc_trans_runtime_check (true, false, recurcheckvar, &block,

+ &sym->declared_at, msg);

+ gfc_add_modify (&block, recurcheckvar, boolean_true_node);

+ gfc_free (msg);

}

if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node

- && sym->attr.subroutine)

+ && sym->attr.subroutine)

{

tree alternate_return;

alternate_return = gfc_get_fake_result_decl (sym, 0);

@@ -3883,6 +4372,12 @@ gfc_generate_function_code (gfc_namespace * ns)

gfc_add_expr_to_block (&body, tmp);

}

+ /* If bounds-checking is enabled, generate code to check passed in actual

+ arguments against the expected dummy argument attributes (e.g. string

+ lengths). */

+ if ((gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) && !sym->attr.is_bind_c)

+ add_argument_checking (&body, sym);

tmp = gfc_trans_code (ns->code);

gfc_add_expr_to_block (&body, tmp);

@@ -3910,18 +4405,34 @@ gfc_generate_function_code (gfc_namespace * ns)

else

result = sym->result->backend_decl;

- if (result != NULL_TREE && sym->attr.function

- && sym->ts.type == BT_DERIVED

- && sym->ts.derived->attr.alloc_comp

+ if (result != NULL_TREE

+ && sym->attr.function

&& !sym->attr.pointer)

{

- rank = sym->as ? sym->as->rank : 0;

- tmp2 = gfc_nullify_alloc_comp (sym->ts.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_option.flag_openmp

+ && recurcheckvar != NULL_TREE)

+ {

+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);

+ recurcheckvar = NULL;

+ }

if (result == NULL_TREE)

{

/* TODO: move to the appropriate place in resolve.c. */

@@ -3944,7 +4455,18 @@ gfc_generate_function_code (gfc_namespace * ns)

}

else

- gfc_add_expr_to_block (&block, tmp);

+ {

+ gfc_add_expr_to_block (&block, tmp);

+ /* Reset recursion-check variable. */

+ if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)

+ && !is_recursive

+ && !gfc_option.flag_openmp

+ && recurcheckvar != NULL_TREE)

+ {

+ gfc_add_modify (&block, recurcheckvar, boolean_false_node);

+ recurcheckvar = NULL_TREE;

+ }

/* Add all the decls we created during processing. */

@@ -3971,6 +4493,15 @@ gfc_generate_function_code (gfc_namespace * ns)

= build3_v (BIND_EXPR, decl, DECL_SAVED_TREE (fndecl),

DECL_INITIAL (fndecl));

+ if (nonlocal_dummy_decls)

+ {

+ BLOCK_VARS (DECL_INITIAL (fndecl))

+ = chainon (BLOCK_VARS (DECL_INITIAL (fndecl)), nonlocal_dummy_decls);

+ pointer_set_destroy (nonlocal_dummy_decl_pset);

+ nonlocal_dummy_decls = NULL;

+ nonlocal_dummy_decl_pset = NULL;

+ }

/* Output the GENERIC tree. */

dump_function (TDI_original, fndecl);

@@ -3995,15 +4526,16 @@ gfc_generate_function_code (gfc_namespace * ns)

added to our parent's nested function list. */

(void) cgraph_node (fndecl);

else

- {

- gfc_gimplify_function (fndecl);

- cgraph_finalize_function (fndecl, false);

- }

+ cgraph_finalize_function (fndecl, true);

gfc_trans_use_stmts (ns);

gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);

+ if (sym->attr.is_main_program)

+ create_main_function (fndecl);

}

void

gfc_generate_constructors (void)

{

@@ -4022,10 +4554,12 @@ gfc_generate_constructors (void)

type = build_function_type (void_type_node,

gfc_chainon_list (NULL_TREE, void_type_node));

- fndecl = build_decl (FUNCTION_DECL, fnname, type);

+ fndecl = build_decl (input_location,

+ FUNCTION_DECL, fnname, type);

TREE_PUBLIC (fndecl) = 1;

- decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);

+ decl = build_decl (input_location,

+ RESULT_DECL, NULL_TREE, void_type_node);

DECL_ARTIFICIAL (decl) = 1;

DECL_IGNORED_P (decl) = 1;

DECL_CONTEXT (decl) = fndecl;

@@ -4045,8 +4579,9 @@ gfc_generate_constructors (void)

for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))

{

- tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);

- DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);

+ tmp = build_call_expr_loc (input_location,

+ TREE_VALUE (gfc_static_ctors), 0);

+ DECL_SAVED_TREE (fndecl) = build_stmt (input_location, EXPR_STMT, tmp);

}

decl = getdecls ();

@@ -4094,7 +4629,8 @@ gfc_generate_block_data (gfc_namespace * ns)

else

id = get_identifier ("__BLOCK_DATA__");

- decl = build_decl (VAR_DECL, id, gfc_array_index_type);

+ decl = build_decl (input_location,

+ VAR_DECL, id, gfc_array_index_type);

TREE_PUBLIC (decl) = 1;

TREE_STATIC (decl) = 1;

DECL_IGNORED_P (decl) = 1;

@@ -4104,4 +4640,28 @@ gfc_generate_block_data (gfc_namespace * ns)

}

+/* 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"

« no previous file with comments | « gcc/gcc/fortran/trans-const.c ('k') | gcc/gcc/fortran/trans-expr.c » ('j') | no next file with comments »