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 |
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 |
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 |
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" |