#include "config.h"
#include "system.h"
#include "coretypes.h"
#include "tree.h"
#include "tree-dump.h"
#include "tree-gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "tm.h"
#include "target.h"
#include "function.h"
#include "errors.h"
#include "flags.h"
#include "cgraph.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
#include "trans-array.h"
#include "trans-const.h"
#include "trans-stmt.h"
#define MAX_LABEL_VALUE 99999
static GTY(()) tree current_fake_result_decl;
static GTY(()) tree current_function_return_label;
static GTY(()) tree saved_function_decls = NULL_TREE;
static GTY(()) tree saved_parent_function_decls = NULL_TREE;
static gfc_namespace *module_namespace;
tree gfc_static_ctors;
tree gfor_fndecl_internal_malloc;
tree gfor_fndecl_internal_malloc64;
tree gfor_fndecl_internal_free;
tree gfor_fndecl_allocate;
tree gfor_fndecl_allocate64;
tree gfor_fndecl_deallocate;
tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_select_string;
tree gfor_fndecl_runtime_error;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
tree gfor_fndecl_associated;
gfc_powdecl_list gfor_fndecl_math_powi[3][2];
tree gfor_fndecl_math_cpowf;
tree gfor_fndecl_math_cpow;
tree gfor_fndecl_math_ishftc4;
tree gfor_fndecl_math_ishftc8;
tree gfor_fndecl_math_exponent4;
tree gfor_fndecl_math_exponent8;
tree gfor_fndecl_copy_string;
tree gfor_fndecl_compare_string;
tree gfor_fndecl_concat_string;
tree gfor_fndecl_string_len_trim;
tree gfor_fndecl_string_index;
tree gfor_fndecl_string_scan;
tree gfor_fndecl_string_verify;
tree gfor_fndecl_string_trim;
tree gfor_fndecl_string_repeat;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
tree gfor_fndecl_size0;
tree gfor_fndecl_size1;
tree gfor_fndecl_iargc;
tree gfor_fndecl_si_kind;
tree gfor_fndecl_sr_kind;
static void
gfc_add_decl_to_parent_function (tree decl)
{
gcc_assert (decl);
DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
DECL_NONLOCAL (decl) = 1;
TREE_CHAIN (decl) = saved_parent_function_decls;
saved_parent_function_decls = decl;
}
void
gfc_add_decl_to_function (tree decl)
{
gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
TREE_CHAIN (decl) = saved_function_decls;
saved_function_decls = decl;
}
tree
gfc_build_label_decl (tree label_id)
{
static unsigned int tmp_num = 1;
tree label_decl;
char *label_name;
if (label_id == NULL_TREE)
{
ASM_FORMAT_PRIVATE_NAME (label_name, "L", tmp_num++);
label_id = get_identifier (label_name);
}
else
label_name = NULL;
label_decl = build_decl (LABEL_DECL, label_id, void_type_node);
DECL_CONTEXT (label_decl) = current_function_decl;
DECL_MODE (label_decl) = VOIDmode;
TREE_USED (label_decl) = 1;
DECL_ARTIFICIAL (label_decl) = 1;
return label_decl;
}
tree
gfc_get_return_label (void)
{
char name[GFC_MAX_SYMBOL_LEN + 10];
if (current_function_return_label)
return current_function_return_label;
sprintf (name, "__return_%s",
IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
current_function_return_label =
gfc_build_label_decl (get_identifier (name));
DECL_ARTIFICIAL (current_function_return_label) = 1;
return current_function_return_label;
}
void
gfc_set_decl_location (tree decl, locus * loc)
{
#ifdef USE_MAPPED_LOCATION
DECL_SOURCE_LOCATION (decl) = loc->lb->location;
#else
DECL_SOURCE_LINE (decl) = loc->lb->linenum;
DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
#endif
}
tree
gfc_get_label_decl (gfc_st_label * lp)
{
if (lp->backend_decl)
return lp->backend_decl;
else
{
char label_name[GFC_MAX_SYMBOL_LEN + 1];
tree label_decl;
gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
sprintf (label_name, "__label_%.6d", lp->value);
label_decl = gfc_build_label_decl (get_identifier (label_name));
if (lp->value <= MAX_LABEL_VALUE)
gfc_set_decl_location (label_decl, &lp->where);
else
DECL_ARTIFICIAL (label_decl) = 1;
lp->backend_decl = label_decl;
return label_decl;
}
}
static tree
gfc_sym_identifier (gfc_symbol * sym)
{
return (get_identifier (sym->name));
}
static tree
gfc_sym_mangled_identifier (gfc_symbol * sym)
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
{
snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
return get_identifier (name);
}
}
static tree
gfc_sym_mangled_function_id (gfc_symbol * sym)
{
int has_underscore;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
{
if (strcmp (sym->name, "MAIN__") == 0
|| sym->attr.proc == PROC_INTRINSIC)
return get_identifier (sym->name);
if (gfc_option.flag_underscoring)
{
has_underscore = strchr (sym->name, '_') != 0;
if (gfc_option.flag_second_underscore && has_underscore)
snprintf (name, sizeof name, "%s__", sym->name);
else
snprintf (name, sizeof name, "%s_", sym->name);
return get_identifier (name);
}
else
return get_identifier (sym->name);
}
else
{
snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
return get_identifier (name);
}
}
int
gfc_can_put_var_on_stack (tree size)
{
unsigned HOST_WIDE_INT low;
if (!INTEGER_CST_P (size))
return 0;
if (gfc_option.flag_max_stack_var_size < 0)
return 1;
if (TREE_INT_CST_HIGH (size) != 0)
return 0;
low = TREE_INT_CST_LOW (size);
if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
return 0;
return 1;
}
static void
gfc_finish_decl (tree decl, tree init)
{
if (TREE_CODE (decl) == PARM_DECL)
gcc_assert (init == NULL_TREE);
else if (init == NULL_TREE)
gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
else
gcc_assert (DECL_INITIAL (decl) == error_mark_node);
if (init != NULL_TREE)
{
if (TREE_CODE (decl) != TYPE_DECL)
DECL_INITIAL (decl) = init;
else
{
TREE_TYPE (decl) = TREE_TYPE (init);
DECL_INITIAL (decl) = init = 0;
}
}
if (TREE_CODE (decl) == VAR_DECL)
{
if (DECL_SIZE (decl) == NULL_TREE
&& TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
layout_decl (decl, 0);
if (DECL_SIZE (decl) == NULL_TREE
&& (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
|| DECL_CONTEXT (decl) != 0)
: !DECL_EXTERNAL (decl)))
{
gfc_fatal_error ("storage size not known");
}
if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
&& (DECL_SIZE (decl) != 0)
&& (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
{
gfc_fatal_error ("storage size not constant");
}
}
}
static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
if (sym->attr.target)
TREE_ADDRESSABLE (decl) = 1;
TREE_USED (decl) = 1;
if (current_function_decl != NULL_TREE)
{
if (sym->ns->proc_name->backend_decl == current_function_decl)
gfc_add_decl_to_function (decl);
else
gfc_add_decl_to_parent_function (decl);
}
if (sym->attr.use_assoc)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
}
else if (sym->module && !sym->attr.result && !sym->attr.dummy)
{
gcc_assert (current_function_decl == NULL_TREE);
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
}
if ((sym->attr.save || sym->attr.data || sym->value)
&& !sym->attr.use_assoc)
TREE_STATIC (decl) = 1;
if (!sym->ns->proc_name->attr.recursive
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
TREE_STATIC (decl) = 1;
}
void
gfc_allocate_lang_decl (tree decl)
{
DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
ggc_alloc_cleared (sizeof (struct lang_decl));
}
static void
gfc_defer_symbol_init (gfc_symbol * sym)
{
gfc_symbol *p;
gfc_symbol *last;
gfc_symbol *head;
if (sym->tlink)
return;
last = head = sym->ns->proc_name;
p = last->tlink;
if (sym->attr.dummy)
{
while (p != head
&& (!p->attr.dummy || p->dummy_order > sym->dummy_order))
{
last = p;
p = p->tlink;
}
}
last->tlink = sym;
sym->tlink = p;
}
static tree
create_index_var (const char * pfx, int nest)
{
tree decl;
decl = gfc_create_var_np (gfc_array_index_type, pfx);
if (nest)
gfc_add_decl_to_parent_function (decl);
else
gfc_add_decl_to_function (decl);
return decl;
}
static void
gfc_build_qualified_array (tree decl, gfc_symbol * sym)
{
tree type;
int dim;
int nest;
type = TREE_TYPE (decl);
if (GFC_DESCRIPTOR_TYPE_P (type))
return;
gcc_assert (GFC_ARRAY_TYPE_P (type));
nest = (sym->ns->proc_name->backend_decl != current_function_decl)
&& !sym->attr.contained;
for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
{
if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
&& (sym->as->type != AS_ASSUMED_SIZE
|| dim < GFC_TYPE_ARRAY_RANK (type) - 1))
GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
}
if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
{
GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
"offset");
if (nest)
gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
else
gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
}
}
static tree
gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
{
tree decl;
tree type;
gfc_array_spec *as;
char *name;
int packed;
int n;
bool known_size;
if (sym->attr.pointer || sym->attr.allocatable)
return dummy;
if (sym->attr.result || sym->attr.dummy)
gfc_defer_symbol_init (sym);
type = TREE_TYPE (dummy);
gcc_assert (TREE_CODE (dummy) == PARM_DECL
&& POINTER_TYPE_P (type));
known_size = sym->ts.type != BT_CHARACTER
|| INTEGER_CST_P (sym->ts.cl->backend_decl);
if (known_size && !GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (type)))
{
gcc_assert (GFC_ARRAY_TYPE_P (type));
gfc_build_qualified_array (dummy, sym);
return dummy;
}
type = TREE_TYPE (type);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
as = sym->as;
packed = 0;
if (!gfc_option.flag_repack_arrays)
{
if (as->type == AS_ASSUMED_SIZE)
packed = 2;
}
else
{
if (as->type == AS_EXPLICIT)
{
packed = 2;
for (n = 0; n < as->rank; n++)
{
if (!(as->upper[n]
&& as->lower[n]
&& as->upper[n]->expr_type == EXPR_CONSTANT
&& as->lower[n]->expr_type == EXPR_CONSTANT))
packed = 1;
}
}
else
packed = 1;
}
type = gfc_typenode_for_spec (&sym->ts);
type = gfc_get_nodesc_array_type (type, sym->as, packed);
}
else
{
sym->backend_decl = NULL_TREE;
type = gfc_sym_type (sym);
packed = 2;
}
ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
decl = build_decl (VAR_DECL, get_identifier (name), type);
DECL_ARTIFICIAL (decl) = 1;
TREE_PUBLIC (decl) = 0;
TREE_STATIC (decl) = 0;
DECL_EXTERNAL (decl) = 0;
gcc_assert (sym->as->type != AS_DEFERRED);
switch (packed)
{
case 1:
GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
break;
case 2:
GFC_DECL_PACKED_ARRAY (decl) = 1;
break;
}
gfc_build_qualified_array (decl, sym);
if (DECL_LANG_SPECIFIC (dummy))
DECL_LANG_SPECIFIC (decl) = DECL_LANG_SPECIFIC (dummy);
else
gfc_allocate_lang_decl (decl);
GFC_DECL_SAVED_DESCRIPTOR (decl) = dummy;
if (sym->ns->proc_name->backend_decl == current_function_decl
|| sym->attr.contained)
gfc_add_decl_to_function (decl);
else
gfc_add_decl_to_parent_function (decl);
return decl;
}
static tree
gfc_create_string_length (gfc_symbol * sym)
{
tree length;
gcc_assert (sym->ts.cl);
gfc_conv_const_charlen (sym->ts.cl);
if (sym->ts.cl->backend_decl == NULL_TREE)
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
strcpy (&name[1], sym->name);
name[0] = '.';
length = build_decl (VAR_DECL, get_identifier (name),
gfc_charlen_type_node);
DECL_ARTIFICIAL (length) = 1;
TREE_USED (length) = 1;
gfc_defer_symbol_init (sym);
sym->ts.cl->backend_decl = length;
}
return sym->ts.cl->backend_decl;
}
tree
gfc_get_symbol_decl (gfc_symbol * sym)
{
tree decl;
tree length = NULL_TREE;
int byref;
gcc_assert (sym->attr.referenced);
if (sym->ns && sym->ns->proc_name->attr.function)
byref = gfc_return_by_reference (sym->ns->proc_name);
else
byref = 0;
if ((sym->attr.dummy && ! sym->attr.function) || (sym->attr.result && byref))
{
if (sym->attr.result && byref
&& !sym->backend_decl)
{
sym->backend_decl =
DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
}
gcc_assert (sym->backend_decl);
if (sym->ts.type == BT_CHARACTER)
{
if (sym->ts.cl->backend_decl == NULL_TREE)
{
length = gfc_create_string_length (sym);
if (TREE_CODE (length) != INTEGER_CST)
{
gfc_finish_var_decl (length, sym);
gfc_defer_symbol_init (sym);
}
}
}
if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
{
sym->backend_decl =
gfc_build_dummy_array_decl (sym, sym->backend_decl);
}
TREE_USED (sym->backend_decl) = 1;
return sym->backend_decl;
}
if (sym->backend_decl)
return sym->backend_decl;
if (sym->attr.flavor == FL_PROCEDURE)
{
decl = gfc_get_extern_function_decl (sym);
return decl;
}
if (sym->attr.intrinsic)
internal_error ("intrinsic variable which isn't a procedure");
if (sym->ts.type == BT_CHARACTER)
length = gfc_create_string_length (sym);
decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
gfc_set_decl_location (decl, &sym->declared_at);
if (sym->module)
SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
if (sym->attr.dimension)
{
gfc_build_qualified_array (decl, sym);
gfc_defer_symbol_init (sym);
if ((sym->attr.allocatable || !sym->attr.dummy) && !sym->attr.pointer)
GFC_DECL_PACKED_ARRAY (decl) = 1;
}
gfc_finish_var_decl (decl, sym);
if (sym->attr.assign)
{
gfc_allocate_lang_decl (decl);
GFC_DECL_ASSIGN (decl) = 1;
length = gfc_create_var (gfc_charlen_type_node, sym->name);
GFC_DECL_STRING_LEN (decl) = length;
GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
TREE_STATIC (length) = TREE_STATIC (decl);
DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
}
if (sym->ts.type == BT_CHARACTER)
{
gfc_allocate_lang_decl (decl);
if (TREE_CODE (length) != INTEGER_CST)
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
if (sym->module)
{
strcpy (&name[1], sym->name);
name[0] = '.';
strcpy (&name[1],
IDENTIFIER_POINTER (DECL_ASSEMBLER_NAME (length)));
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
}
gfc_finish_var_decl (length, sym);
gcc_assert (!sym->value);
}
}
sym->backend_decl = decl;
if (TREE_STATIC (decl) && !sym->attr.use_assoc)
{
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
TREE_TYPE (decl), sym->attr.dimension,
sym->attr.pointer || sym->attr.allocatable);
}
return decl;
}
void
gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
{
save->attr = sym->attr;
save->decl = sym->backend_decl;
gfc_clear_attr (&sym->attr);
sym->attr.referenced = 1;
sym->attr.flavor = FL_VARIABLE;
sym->backend_decl = decl;
}
void
gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
{
sym->attr = save->attr;
sym->backend_decl = save->decl;
}
tree
gfc_get_extern_function_decl (gfc_symbol * sym)
{
tree type;
tree fndecl;
gfc_expr e;
gfc_intrinsic_sym *isym;
gfc_expr argexpr;
char s[GFC_MAX_SYMBOL_LEN];
tree name;
tree mangled_name;
if (sym->backend_decl)
return sym->backend_decl;
gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
if (sym->attr.intrinsic)
{
isym = gfc_find_function (sym->name);
gcc_assert (isym->resolve.f0 != NULL);
memset (&e, 0, sizeof (e));
e.expr_type = EXPR_FUNCTION;
memset (&argexpr, 0, sizeof (argexpr));
gcc_assert (isym->formal);
argexpr.ts = isym->formal->ts;
if (isym->formal->next == NULL)
isym->resolve.f1 (&e, &argexpr);
else
{
gcc_assert (isym->formal->next->next == NULL);
isym->resolve.f2 (&e, &argexpr, NULL);
}
sprintf (s, "specific%s", e.value.function.name);
name = get_identifier (s);
mangled_name = name;
}
else
{
name = gfc_sym_identifier (sym);
mangled_name = gfc_sym_mangled_function_id (sym);
}
type = gfc_get_function_type (sym);
fndecl = build_decl (FUNCTION_DECL, name, type);
SET_DECL_ASSEMBLER_NAME (fndecl, mangled_name);
if (POINTER_TYPE_P (type))
DECL_IS_MALLOC (fndecl) = 1;
if (0 && sym->ns && sym->ns->proc_name)
{
DECL_CONTEXT (fndecl) = sym->ns->proc_name->backend_decl;
}
else
{
DECL_CONTEXT (fndecl) = NULL_TREE;
}
DECL_EXTERNAL (fndecl) = 1;
TREE_PUBLIC (fndecl) = 1;
if (sym->attr.pure || sym->attr.elemental)
{
if (sym->attr.function)
DECL_IS_PURE (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
sym->backend_decl = fndecl;
if (DECL_CONTEXT (fndecl) == NULL_TREE)
pushdecl_top_level (fndecl);
return fndecl;
}
static void
build_function_decl (gfc_symbol * sym)
{
tree fndecl, type;
symbol_attribute attr;
tree result_decl;
gfc_formal_arglist *f;
gcc_assert (!sym->backend_decl);
gcc_assert (!sym->attr.external);
gfc_set_backend_locus (&sym->declared_at);
gcc_assert (current_function_decl == NULL_TREE
|| DECL_CONTEXT (current_function_decl) == NULL_TREE);
type = gfc_get_function_type (sym);
fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
if (current_function_decl == NULL_TREE)
SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
attr = sym->attr;
result_decl = NULL_TREE;
if (attr.function)
{
if (gfc_return_by_reference (sym))
type = void_type_node;
else
{
if (sym->result != sym)
result_decl = gfc_sym_identifier (sym->result);
type = TREE_TYPE (TREE_TYPE (fndecl));
}
}
else
{
int has_alternate_returns = 0;
for (f = sym->formal; f; f = f->next)
{
if (f->sym == NULL)
{
has_alternate_returns = 1;
break;
}
}
if (has_alternate_returns)
type = integer_type_node;
else
type = void_type_node;
}
result_decl = build_decl (RESULT_DECL, result_decl, type);
DECL_ARTIFICIAL (result_decl) = 1;
DECL_IGNORED_P (result_decl) = 1;
DECL_CONTEXT (result_decl) = fndecl;
DECL_RESULT (fndecl) = result_decl;
if (POINTER_TYPE_P (type))
DECL_IS_MALLOC (fndecl) = 1;
DECL_CONTEXT (fndecl) = current_function_decl;
DECL_EXTERNAL (fndecl) = 0;
if (DECL_CONTEXT (fndecl) == NULL_TREE
&& !sym->attr.entry_master)
TREE_PUBLIC (fndecl) = 1;
TREE_STATIC (fndecl) = 1;
if (attr.pure || attr.elemental)
{
if (attr.function)
DECL_IS_PURE (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
pushdecl (fndecl);
sym->backend_decl = fndecl;
}
static void
create_function_arglist (gfc_symbol * sym)
{
tree fndecl;
gfc_formal_arglist *f;
tree typelist;
tree arglist;
tree length;
tree type;
tree parm;
fndecl = sym->backend_decl;
arglist = NULL_TREE;
typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
if (sym->attr.entry_master)
{
type = TREE_VALUE (typelist);
parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
if (gfc_return_by_reference (sym))
{
type = TREE_VALUE (typelist);
parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
DECL_ARTIFICIAL (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
if (sym->ts.type == BT_CHARACTER)
{
gfc_allocate_lang_decl (parm);
type = TREE_VALUE (typelist);
gcc_assert (type == gfc_charlen_type_node);
length = build_decl (PARM_DECL,
get_identifier (".__result"),
type);
if (!sym->ts.cl->length)
{
sym->ts.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
arglist = chainon (arglist, length);
typelist = TREE_CHAIN (typelist);
DECL_CONTEXT (length) = fndecl;
DECL_ARG_TYPE (length) = type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length, NULL_TREE);
}
}
for (f = sym->formal; f; f = f->next)
{
if (f->sym != NULL)
{
length = NULL_TREE;
type = TREE_VALUE (typelist);
parm = build_decl (PARM_DECL,
gfc_sym_identifier (f->sym), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
TREE_READONLY (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
f->sym->backend_decl = parm;
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
}
parm = arglist;
for (f = sym->formal; f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
if (f->sym == NULL)
continue;
if (f->sym->ts.type != BT_CHARACTER)
continue;
parm = f->sym->backend_decl;
type = TREE_VALUE (typelist);
gcc_assert (type == gfc_charlen_type_node);
strcpy (&name[1], f->sym->name);
name[0] = '_';
length = build_decl (PARM_DECL, get_identifier (name), type);
arglist = chainon (arglist, length);
DECL_CONTEXT (length) = fndecl;
DECL_ARTIFICIAL (length) = 1;
DECL_ARG_TYPE (length) = type;
TREE_READONLY (length) = 1;
gfc_finish_decl (length, NULL_TREE);
if (!f->sym->ts.cl->length)
{
TREE_USED (length) = 1;
if (!f->sym->ts.cl->backend_decl)
f->sym->ts.cl->backend_decl = length;
else
{
gfc_charlen *cl;
cl = gfc_get_charlen ();
cl->backend_decl = length;
cl->next = f->sym->ts.cl->next;
f->sym->ts.cl->next = cl;
f->sym->ts.cl = cl;
}
}
parm = TREE_CHAIN (parm);
typelist = TREE_CHAIN (typelist);
}
gcc_assert (TREE_VALUE (typelist) == void_type_node);
DECL_ARGUMENTS (fndecl) = arglist;
}
static void
gfc_gimplify_function (tree fndecl)
{
struct cgraph_node *cgn;
gimplify_function_tree (fndecl);
dump_function (TDI_generic, fndecl);
cgn = cgraph_node (fndecl);
for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
gfc_gimplify_function (cgn->decl);
}
static void
trans_function_start (gfc_symbol * sym)
{
tree fndecl;
fndecl = sym->backend_decl;
current_function_decl = fndecl;
announce_function (fndecl);
if (DECL_CONTEXT (fndecl) == NULL_TREE)
{
rest_of_decl_compilation (fndecl, 1, 0);
}
make_decl_rtl (fndecl);
init_function_start (fndecl);
cfun->x_dont_save_pending_sizes_p = 1;
pushlevel (0);
}
static void
build_entry_thunks (gfc_namespace * ns)
{
gfc_formal_arglist *formal;
gfc_formal_arglist *thunk_formal;
gfc_entry_list *el;
gfc_symbol *thunk_sym;
stmtblock_t body;
tree thunk_fndecl;
tree args;
tree string_args;
tree tmp;
locus old_loc;
gcc_assert (current_function_decl == NULL_TREE);
gfc_get_backend_locus (&old_loc);
for (el = ns->entries; el; el = el->next)
{
thunk_sym = el->sym;
build_function_decl (thunk_sym);
create_function_arglist (thunk_sym);
trans_function_start (thunk_sym);
thunk_fndecl = thunk_sym->backend_decl;
gfc_start_block (&body);
tmp = build_int_cst (gfc_array_index_type, el->id);
args = tree_cons (NULL_TREE, tmp, NULL_TREE);
string_args = NULL_TREE;
if (ns->proc_name->attr.function)
gfc_todo_error ("Functons with multiple entry points");
for (formal = ns->proc_name->formal; formal; formal = formal->next)
{
for (thunk_formal = thunk_sym->formal;
thunk_formal;
thunk_formal = thunk_formal->next)
{
if (thunk_formal->sym == formal->sym)
break;
}
if (thunk_formal)
{
args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
args);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = thunk_formal->sym->ts.cl->backend_decl;
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
else
{
args = tree_cons (NULL_TREE, null_pointer_node, args);
if (formal->sym->ts.type == BT_CHARACTER)
{
tmp = convert (gfc_charlen_type_node, integer_zero_node);
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
}
args = nreverse (args);
args = chainon (args, nreverse (string_args));
tmp = ns->proc_name->backend_decl;
tmp = gfc_build_function_call (tmp, args);
gfc_add_expr_to_block (&body, tmp);
DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
dump_function (TDI_original, thunk_fndecl);
cfun->function_end_locus = input_location;
cfun = NULL;
current_function_decl = NULL_TREE;
gfc_gimplify_function (thunk_fndecl);
cgraph_finalize_function (thunk_fndecl, false);
for (formal = thunk_sym->formal; formal; formal = formal->next)
{
formal->sym->backend_decl = NULL_TREE;
if (formal->sym->ts.type == BT_CHARACTER)
formal->sym->ts.cl->backend_decl = NULL_TREE;
}
}
gfc_set_backend_locus (&old_loc);
}
void
gfc_create_function_decl (gfc_namespace * ns)
{
build_function_decl (ns->proc_name);
if (ns->entries)
build_entry_thunks (ns);
create_function_arglist (ns->proc_name);
}
tree
gfc_get_fake_result_decl (gfc_symbol * sym)
{
tree decl;
tree length;
char name[GFC_MAX_SYMBOL_LEN + 10];
if (current_fake_result_decl != NULL_TREE)
return current_fake_result_decl;
if (!sym)
return NULL_TREE;
if (sym->ts.type == BT_CHARACTER
&& !sym->ts.cl->backend_decl)
{
length = gfc_create_string_length (sym);
gfc_finish_var_decl (length, sym);
}
if (gfc_return_by_reference (sym))
{
decl = DECL_ARGUMENTS (sym->backend_decl);
TREE_USED (decl) = 1;
if (sym->as)
decl = gfc_build_dummy_array_decl (sym, decl);
}
else
{
sprintf (name, "__result_%.20s",
IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
decl = build_decl (VAR_DECL, get_identifier (name),
TREE_TYPE (TREE_TYPE (current_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
DECL_EXTERNAL (decl) = 0;
TREE_PUBLIC (decl) = 0;
TREE_USED (decl) = 1;
layout_decl (decl, 0);
gfc_add_decl_to_function (decl);
}
current_fake_result_decl = decl;
return decl;
}
tree
gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
{
tree arglist;
tree argtype;
tree fntype;
tree fndecl;
va_list p;
int n;
gcc_assert (current_function_decl == NULL_TREE);
va_start (p, nargs);
for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
{
argtype = va_arg (p, tree);
arglist = gfc_chainon_list (arglist, argtype);
}
if (nargs >= 0)
{
arglist = gfc_chainon_list (arglist, void_type_node);
}
fntype = build_function_type (rettype, arglist);
fndecl = build_decl (FUNCTION_DECL, name, fntype);
DECL_EXTERNAL (fndecl) = 1;
TREE_PUBLIC (fndecl) = 1;
va_end (p);
pushdecl (fndecl);
rest_of_decl_compilation (fndecl, 1, 0);
return fndecl;
}
static void
gfc_build_intrinsic_function_decls (void)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
tree gfc_int8_type_node = gfc_get_int_type (8);
tree gfc_logical4_type_node = gfc_get_logical_type (4);
tree gfc_real4_type_node = gfc_get_real_type (4);
tree gfc_real8_type_node = gfc_get_real_type (8);
tree gfc_complex4_type_node = gfc_get_complex_type (4);
tree gfc_complex8_type_node = gfc_get_complex_type (8);
gfor_fndecl_copy_string =
gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
void_type_node,
4,
gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_compare_string =
gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
gfc_int4_type_node,
4,
gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_concat_string =
gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
void_type_node,
6,
gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_string_len_trim =
gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
gfc_int4_type_node,
2, gfc_charlen_type_node,
pchar_type_node);
gfor_fndecl_string_index =
gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
gfc_int4_type_node,
5, gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node,
gfc_logical4_type_node);
gfor_fndecl_string_scan =
gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
gfc_int4_type_node,
5, gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node,
gfc_logical4_type_node);
gfor_fndecl_string_verify =
gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
gfc_int4_type_node,
5, gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node,
gfc_logical4_type_node);
gfor_fndecl_string_trim =
gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
void_type_node,
4,
build_pointer_type (gfc_charlen_type_node),
ppvoid_type_node,
gfc_charlen_type_node,
pchar_type_node);
gfor_fndecl_string_repeat =
gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
void_type_node,
4,
pchar_type_node,
gfc_charlen_type_node,
pchar_type_node,
gfc_int4_type_node);
gfor_fndecl_adjustl =
gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
void_type_node,
3,
pchar_type_node,
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_adjustr =
gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
void_type_node,
3,
pchar_type_node,
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_si_kind =
gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
gfc_int4_type_node,
1,
pvoid_type_node);
gfor_fndecl_sr_kind =
gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
gfc_int4_type_node,
2, pvoid_type_node,
pvoid_type_node);
{
tree type;
tree itype;
int kind;
int ikind;
static int kinds[2] = {4, 8};
char name[PREFIX_LEN + 10];
for (ikind=0; ikind < 2; ikind++)
{
itype = gfc_get_int_type (kinds[ikind]);
for (kind = 0; kind < 2; kind ++)
{
type = gfc_get_int_type (kinds[kind]);
sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
gfor_fndecl_math_powi[kind][ikind].integer =
gfc_build_library_function_decl (get_identifier (name),
type, 2, type, itype);
type = gfc_get_real_type (kinds[kind]);
sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
gfor_fndecl_math_powi[kind][ikind].real =
gfc_build_library_function_decl (get_identifier (name),
type, 2, type, itype);
type = gfc_get_complex_type (kinds[kind]);
sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
gfor_fndecl_math_powi[kind][ikind].cmplx =
gfc_build_library_function_decl (get_identifier (name),
type, 2, type, itype);
}
}
}
gfor_fndecl_math_cpowf =
gfc_build_library_function_decl (get_identifier ("cpowf"),
gfc_complex4_type_node,
1, gfc_complex4_type_node);
gfor_fndecl_math_cpow =
gfc_build_library_function_decl (get_identifier ("cpow"),
gfc_complex8_type_node,
1, gfc_complex8_type_node);
gfor_fndecl_math_ishftc4 =
gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
gfc_int4_type_node,
3, gfc_int4_type_node,
gfc_int4_type_node, gfc_int4_type_node);
gfor_fndecl_math_ishftc8 =
gfc_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
gfc_int8_type_node,
3, gfc_int8_type_node,
gfc_int8_type_node, gfc_int8_type_node);
gfor_fndecl_math_exponent4 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
gfc_int4_type_node,
1, gfc_real4_type_node);
gfor_fndecl_math_exponent8 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
gfc_int4_type_node,
1, gfc_real8_type_node);
gfor_fndecl_size0 =
gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
gfc_array_index_type,
1, pvoid_type_node);
gfor_fndecl_size1 =
gfc_build_library_function_decl (get_identifier (PREFIX("size1")),
gfc_array_index_type,
2, pvoid_type_node,
gfc_array_index_type);
gfor_fndecl_iargc =
gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
gfc_int4_type_node,
0);
}
void
gfc_build_builtin_function_decls (void)
{
tree gfc_int4_type_node = gfc_get_int_type (4);
tree gfc_int8_type_node = gfc_get_int_type (8);
tree gfc_logical4_type_node = gfc_get_logical_type (4);
gfor_fndecl_internal_malloc =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
pvoid_type_node, 1, gfc_int4_type_node);
gfor_fndecl_internal_malloc64 =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_malloc64")),
pvoid_type_node, 1, gfc_int8_type_node);
gfor_fndecl_internal_free =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
void_type_node, 1, pvoid_type_node);
gfor_fndecl_allocate =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
void_type_node, 2, ppvoid_type_node,
gfc_int4_type_node);
gfor_fndecl_allocate64 =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
void_type_node, 2, ppvoid_type_node,
gfc_int8_type_node);
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
void_type_node, 1, ppvoid_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
void_type_node, 1, gfc_int4_type_node);
gfor_fndecl_stop_string =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
void_type_node, 2, pchar_type_node,
gfc_int4_type_node);
gfor_fndecl_pause_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
void_type_node, 1, gfc_int4_type_node);
gfor_fndecl_pause_string =
gfc_build_library_function_decl (get_identifier (PREFIX("pause_string")),
void_type_node, 2, pchar_type_node,
gfc_int4_type_node);
gfor_fndecl_select_string =
gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
pvoid_type_node, 0);
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
void_type_node,
3,
pchar_type_node, pchar_type_node,
gfc_int4_type_node);
gfor_fndecl_in_pack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_pack")),
pvoid_type_node, 1, pvoid_type_node);
gfor_fndecl_in_unpack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_unpack")),
pvoid_type_node, 1, pvoid_type_node);
gfor_fndecl_associated =
gfc_build_library_function_decl (
get_identifier (PREFIX("associated")),
gfc_logical4_type_node,
2,
ppvoid_type_node,
ppvoid_type_node);
gfc_build_intrinsic_function_decls ();
gfc_build_intrinsic_lib_fndecls ();
gfc_build_io_library_fndecls ();
}
static tree
gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
{
stmtblock_t body;
gfc_finish_decl (cl->backend_decl, NULL_TREE);
gfc_start_block (&body);
gfc_trans_init_string_length (cl, &body);
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
static tree
gfc_trans_auto_character_variable (gfc_symbol * sym, tree fnbody)
{
stmtblock_t body;
tree decl;
tree tmp;
gcc_assert (sym->backend_decl);
gcc_assert (sym->ts.cl && sym->ts.cl->length);
gfc_start_block (&body);
gfc_trans_init_string_length (sym->ts.cl, &body);
decl = sym->backend_decl;
tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&body, tmp);
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
static tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
locus loc;
gfc_symbol *sym;
if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
{
if (!current_fake_result_decl)
{
warning ("Function does not return a value");
return fnbody;
}
if (proc_sym->as)
{
fnbody = gfc_trans_dummy_array_bias (proc_sym,
current_fake_result_decl,
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->ts.cl, fnbody);
}
else
gfc_todo_error ("Deferred non-array return by reference");
}
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
if (sym->attr.dimension)
{
switch (sym->as->type)
{
case AS_EXPLICIT:
if (sym->attr.dummy || sym->attr.result)
fnbody =
gfc_trans_dummy_array_bias (sym, sym->backend_decl, fnbody);
else if (sym->attr.pointer || sym->attr.allocatable)
{
if (TREE_STATIC (sym->backend_decl))
gfc_trans_static_array_pointer (sym);
else
fnbody = gfc_trans_deferred_array (sym, fnbody);
}
else
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
sym, fnbody);
gfc_set_backend_locus (&loc);
}
break;
case AS_ASSUMED_SIZE:
gcc_assert (sym->attr.dummy);
fnbody = gfc_trans_g77_array (sym, fnbody);
break;
case AS_ASSUMED_SHAPE:
gcc_assert (sym->attr.dummy);
fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
fnbody);
break;
case AS_DEFERRED:
fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
}
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->ts.cl, fnbody);
else
fnbody = gfc_trans_auto_character_variable (sym, fnbody);
gfc_set_backend_locus (&loc);
}
else
gcc_unreachable ();
}
return fnbody;
}
static void
gfc_create_module_variable (gfc_symbol * sym)
{
tree decl;
if (sym->ns != module_namespace)
{
internal_error ("module symbol %s in wrong namespace", sym->name);
}
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
return;
if (sym->attr.use_assoc || sym->attr.in_common)
return;
if (sym->backend_decl)
internal_error ("backend decl for module variable %s already exists",
sym->name);
sym->attr.referenced = 1;
decl = gfc_get_symbol_decl (sym);
pushdecl (decl);
rest_of_decl_compilation (decl, 1, 0);
if (sym->ts.type == BT_CHARACTER)
{
tree length;
length = sym->ts.cl->backend_decl;
if (!INTEGER_CST_P (length))
{
pushdecl (length);
rest_of_decl_compilation (length, 1, 0);
}
}
}
void
gfc_generate_module_vars (gfc_namespace * ns)
{
module_namespace = ns;
gcc_assert (ns->proc_name && !ns->proc_name->tlink);
gfc_trans_common (ns);
gfc_traverse_ns (ns, gfc_create_module_variable);
}
static void
gfc_generate_contained_functions (gfc_namespace * parent)
{
gfc_namespace *ns;
for (ns = parent->contained; ns; ns = ns->sibling)
{
if (ns->parent != parent)
continue;
gfc_create_function_decl (ns);
}
for (ns = parent->contained; ns; ns = ns->sibling)
{
if (ns->parent != parent)
continue;
gfc_generate_function_code (ns);
}
}
static void
generate_local_decl (gfc_symbol * sym)
{
if (sym->attr.flavor == FL_VARIABLE)
{
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
else if (sym->attr.dummy && warn_unused_parameter)
warning ("unused parameter %qs", sym->name);
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->attr.use_assoc))
warning ("unused variable %qs", sym->name);
}
}
static void
generate_local_vars (gfc_namespace * ns)
{
gfc_traverse_ns (ns, generate_local_decl);
}
static tree
gfc_trans_entry_master_switch (gfc_entry_list * el)
{
stmtblock_t block;
tree label;
tree tmp;
tree val;
gfc_init_block (&block);
for (; el; el = el->next)
{
label = gfc_build_label_decl (NULL_TREE);
val = build_int_cst (gfc_array_index_type, el->id);
tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
gfc_add_expr_to_block (&block, tmp);
label = gfc_build_label_decl (NULL_TREE);
tmp = build1_v (GOTO_EXPR, label);
gfc_add_expr_to_block (&block, tmp);
el->label = label;
}
tmp = gfc_finish_block (&block);
val = DECL_ARGUMENTS (current_function_decl);
tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
return tmp;
}
void
gfc_generate_function_code (gfc_namespace * ns)
{
tree fndecl;
tree old_context;
tree decl;
tree tmp;
stmtblock_t block;
stmtblock_t body;
tree result;
gfc_symbol *sym;
sym = ns->proc_name;
gcc_assert (sym->tlink == NULL);
sym->tlink = sym;
if (!sym->backend_decl)
gfc_create_function_decl (ns);
fndecl = sym->backend_decl;
old_context = current_function_decl;
if (old_context)
{
push_function_context ();
saved_parent_function_decls = saved_function_decls;
saved_function_decls = NULL_TREE;
}
trans_function_start (sym);
current_fake_result_decl = NULL_TREE;
gfc_start_block (&block);
gfc_generate_contained_functions (ns);
gfc_trans_common (ns);
generate_local_vars (ns);
current_function_return_label = NULL;
gfc_init_block (&body);
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
&& sym->attr.subroutine)
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym);
gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
}
if (ns->entries)
{
tmp = gfc_trans_entry_master_switch (ns->entries);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
if (current_function_return_label)
{
tmp = build1_v (LABEL_EXPR, current_function_return_label);
gfc_add_expr_to_block (&body, tmp);
}
tmp = gfc_finish_block (&body);
tmp = gfc_trans_deferred_vars (sym, tmp);
gfc_add_expr_to_block (&block, tmp);
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
if (sym->attr.subroutine || sym == sym->result)
{
result = current_fake_result_decl;
current_fake_result_decl = NULL_TREE;
}
else
result = sym->result->backend_decl;
if (result == NULL_TREE)
warning ("Function return value not set");
else
{
tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
DECL_RESULT (fndecl), result);
tmp = build1_v (RETURN_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
decl = saved_function_decls;
while (decl)
{
tree next;
next = TREE_CHAIN (decl);
TREE_CHAIN (decl) = NULL_TREE;
pushdecl (decl);
decl = next;
}
saved_function_decls = NULL_TREE;
DECL_SAVED_TREE (fndecl) = gfc_finish_block (&block);
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
dump_function (TDI_original, fndecl);
cfun->function_end_locus = input_location;
cfun = NULL;
if (old_context)
{
pop_function_context ();
saved_function_decls = saved_parent_function_decls;
}
current_function_decl = old_context;
if (decl_function_context (fndecl))
(void) cgraph_node (fndecl);
else
{
gfc_gimplify_function (fndecl);
cgraph_finalize_function (fndecl, false);
}
}
void
gfc_generate_constructors (void)
{
gcc_assert (gfc_static_ctors == NULL_TREE);
#if 0
tree fnname;
tree type;
tree fndecl;
tree decl;
tree tmp;
if (gfc_static_ctors == NULL_TREE)
return;
fnname = get_file_function_name ('I');
type = build_function_type (void_type_node,
gfc_chainon_list (NULL_TREE, void_type_node));
fndecl = build_decl (FUNCTION_DECL, fnname, type);
TREE_PUBLIC (fndecl) = 1;
decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
DECL_ARTIFICIAL (decl) = 1;
DECL_IGNORED_P (decl) = 1;
DECL_CONTEXT (decl) = fndecl;
DECL_RESULT (fndecl) = decl;
pushdecl (fndecl);
current_function_decl = fndecl;
rest_of_decl_compilation (fndecl, 1, 0);
make_decl_rtl (fndecl);
init_function_start (fndecl);
pushlevel (0);
for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
{
tmp =
gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
}
poplevel (1, 0, 1);
BLOCK_SUPERCONTEXT (DECL_INITIAL (fndecl)) = fndecl;
free_after_parsing (cfun);
free_after_compilation (cfun);
tree_rest_of_compilation (fndecl);
current_function_decl = NULL_TREE;
#endif
}
void
gfc_generate_block_data (gfc_namespace * ns)
{
tree decl;
tree id;
if (ns->proc_name)
gfc_set_backend_locus (&ns->proc_name->declared_at);
else
gfc_set_backend_locus (&gfc_current_locus);
gfc_trans_common (ns);
if (ns->proc_name)
id = gfc_sym_mangled_function_id (ns->proc_name);
else
id = get_identifier ("__BLOCK_DATA__");
decl = build_decl (VAR_DECL, id, gfc_array_index_type);
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
pushdecl (decl);
rest_of_decl_compilation (decl, 1, 0);
}
#include "gt-fortran-trans-decl.h"