#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 <assert.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_cabsf;
tree gfor_fndecl_math_cabs;
tree gfor_fndecl_math_sign4;
tree gfor_fndecl_math_sign8;
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_si_kind;
tree gfor_fndecl_sr_kind;
static void
gfc_add_decl_to_parent_function (tree decl)
{
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)
{
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;
if (label_name)
{
DECL_ARTIFICIAL (label_decl) = 1;
}
else
{
TREE_USED (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;
}
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;
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)
{
DECL_SOURCE_LINE (label_decl) = lp->where.lb->linenum;
DECL_SOURCE_FILE (label_decl) = lp->where.lb->file->filename;
}
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[0] == 0)
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[0] == 0 || sym->attr.proc == PROC_EXTERNAL
|| (sym->module[0] != 0 && 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);
}
}
static void
gfc_finish_decl (tree decl, tree init)
{
if (TREE_CODE (decl) == PARM_DECL)
assert (init == NULL_TREE);
else if (init == NULL_TREE)
assert (DECL_INITIAL (decl) == NULL_TREE);
else
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[0] && !sym->attr.result)
{
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;
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);
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)))
{
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;
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;
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_strlen_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;
gfc_se se;
int byref;
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);
}
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.entry)
gfc_todo_error ("alternate entry");
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));
if (sym->module[0])
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_strlen_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_2 (-2, -1);
}
switch (sym->ts.type)
{
case BT_CHARACTER:
gfc_allocate_lang_decl (decl);
if (TREE_CODE (length) == INTEGER_CST)
{
if (sym->value && sym->attr.dimension == 0)
{
assert (TREE_STATIC (decl));
if (sym->attr.pointer)
gfc_todo_error ("initialization of character pointers");
DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value);
}
}
else
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
if (sym->module[0])
{
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);
assert (!sym->value);
}
break;
case BT_DERIVED:
if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
{
gfc_init_se (&se, NULL);
gfc_conv_structure (&se, sym->value, 1);
DECL_INITIAL (decl) = se.expr;
}
break;
default:
if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
{
assert (TREE_STATIC (decl));
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, sym->value);
DECL_INITIAL (decl) = se.expr;
}
break;
}
sym->backend_decl = decl;
return 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;
if (sym->attr.intrinsic)
{
isym = gfc_find_function (sym->name);
assert (isym->resolve.f0 != NULL);
memset (&e, 0, sizeof (e));
e.expr_type = EXPR_FUNCTION;
memset (&argexpr, 0, sizeof (argexpr));
assert (isym->formal);
argexpr.ts = isym->formal->ts;
if (isym->formal->next == NULL)
isym->resolve.f1 (&e, &argexpr);
else
{
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;
}
void
gfc_build_function_decl (gfc_symbol * sym)
{
tree fndecl, type, result_decl, typelist, arglist;
tree length;
symbol_attribute attr;
gfc_formal_arglist *f;
assert (!sym->backend_decl);
assert (!sym->attr.external);
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_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 || attr.external)
TREE_PUBLIC (fndecl) = 1;
if (!attr.external)
TREE_STATIC (fndecl) = 1;
if (attr.pure || attr.elemental)
{
if (attr.function)
DECL_IS_PURE (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
if (!attr.external)
{
tree parm;
pushdecl (fndecl);
current_function_decl = fndecl;
arglist = NULL_TREE;
typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
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;
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);
assert (type == gfc_strlen_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;
}
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;
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);
assert (type == gfc_strlen_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_ARG_TYPE (length) = type;
TREE_READONLY (length) = 1;
gfc_finish_decl (length, NULL_TREE);
if (!f->sym->ts.cl->length)
{
TREE_USED (length) = 1;
f->sym->ts.cl->backend_decl = length;
}
parm = TREE_CHAIN (parm);
typelist = TREE_CHAIN (typelist);
}
assert (TREE_VALUE (typelist) == void_type_node);
DECL_ARGUMENTS (fndecl) = arglist;
current_function_decl = DECL_CONTEXT (fndecl);
}
sym->backend_decl = fndecl;
}
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;
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, NULL, 1, 0);
return fndecl;
}
static void
gfc_build_intrinsic_function_decls (void)
{
gfor_fndecl_copy_string =
gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
void_type_node,
4,
gfc_strlen_type_node, pchar_type_node,
gfc_strlen_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_strlen_type_node, pchar_type_node,
gfc_strlen_type_node, pchar_type_node);
gfor_fndecl_concat_string =
gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
void_type_node,
6,
gfc_strlen_type_node, pchar_type_node,
gfc_strlen_type_node, pchar_type_node,
gfc_strlen_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_strlen_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_strlen_type_node, pchar_type_node,
gfc_strlen_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_strlen_type_node, pchar_type_node,
gfc_strlen_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_strlen_type_node, pchar_type_node,
gfc_strlen_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_strlen_type_node),
ppvoid_type_node,
gfc_strlen_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_strlen_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_strlen_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_strlen_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_cabsf =
gfc_build_library_function_decl (get_identifier ("cabsf"),
gfc_real4_type_node,
1, gfc_complex4_type_node);
gfor_fndecl_math_cabs =
gfc_build_library_function_decl (get_identifier ("cabs"),
gfc_real8_type_node,
1, gfc_complex8_type_node);
gfor_fndecl_math_sign4 =
gfc_build_library_function_decl (get_identifier ("copysignf"),
gfc_real4_type_node,
1, gfc_real4_type_node);
gfor_fndecl_math_sign8 =
gfc_build_library_function_decl (get_identifier ("copysign"),
gfc_real8_type_node,
1, gfc_real8_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);
}
void
gfc_build_builtin_function_decls (void)
{
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 args;
tree tmp;
assert (sym->backend_decl);
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;
DECL_DEFER_OUTPUT (decl) = 1;
tmp = gfc_build_addr_expr (NULL, decl);
args = gfc_chainon_list (NULL_TREE, tmp);
args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args);
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:
assert (sym->attr.dummy);
assert (TREE_CODE (sym->backend_decl) == PARM_DECL);
fnbody = gfc_trans_g77_array (sym, fnbody);
break;
case AS_ASSUMED_SHAPE:
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:
abort ();
}
}
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
abort ();
}
return fnbody;
}
static void
gfc_create_module_variable (gfc_symbol * sym)
{
tree decl;
gfc_se se;
if (sym->ns != module_namespace)
{
internal_error ("module symbol %s in wrong namespace", sym->name);
}
if (sym->attr.common)
return;
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
return;
if (sym->attr.use_assoc)
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);
TREE_STATIC (decl) = 1;
if (sym->attr.dimension)
{
assert (sym->attr.pointer || sym->attr.allocatable
|| GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl)));
if (sym->attr.pointer || sym->attr.allocatable)
gfc_trans_static_array_pointer (sym);
else
gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE);
}
else if (sym->ts.type == BT_DERIVED)
{
if (sym->value)
gfc_todo_error ("Initialization of derived type module variables");
}
else
{
if (sym->value)
{
gfc_init_se (&se, NULL);
gfc_conv_constant (&se, sym->value);
DECL_INITIAL (decl) = se.expr;
}
}
pushdecl (decl);
rest_of_decl_compilation (decl, NULL, 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, NULL, 1, 0);
}
}
}
void
gfc_generate_module_vars (gfc_namespace * ns)
{
module_namespace = ns;
assert (ns->proc_name && !ns->proc_name->tlink);
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_build_function_decl (ns->proc_name);
}
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->ts.type == BT_UNKNOWN)
return;
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
else if (sym->attr.dummy)
{
if (warn_unused_parameter)
warning ("unused parameter `%s'", sym->name);
}
else if (warn_unused_variable && !sym->attr.in_common)
warning ("unused variable `%s'", sym->name);
}
}
static void
generate_local_vars (gfc_namespace * ns)
{
gfc_traverse_ns (ns, generate_local_decl);
}
static void
gfc_finalize (tree decl)
{
struct cgraph_node *cgn;
cgn = cgraph_node (decl);
for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
gfc_finalize (cgn->decl);
cgraph_finalize_function (decl, false);
}
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;
assert (sym->tlink == NULL);
sym->tlink = sym;
if (!sym->backend_decl)
gfc_build_function_decl (ns->proc_name);
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;
}
current_function_decl = fndecl;
announce_function (fndecl);
if (DECL_CONTEXT (fndecl) == NULL_TREE)
{
rest_of_decl_compilation (fndecl, NULL, 1, 0);
}
make_decl_rtl (fndecl, NULL);
gfc_set_backend_locus (&sym->declared_at);
init_function_start (fndecl);
cfun->x_whole_function_mode_p = 1;
immediate_size_expand = 0;
cfun->x_dont_save_pending_sizes_p = 1;
current_fake_result_decl = NULL_TREE;
pushlevel (0);
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);
}
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 = build (MODIFY_EXPR, TREE_TYPE (result),
DECL_RESULT (fndecl), result);
tmp = build_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);
gimplify_function_tree (fndecl);
}
else
{
if (cgraph_node (fndecl)->nested)
{
gimplify_function_tree (fndecl);
lower_nested_functions (fndecl);
}
gfc_finalize (fndecl);
}
}
void
gfc_generate_constructors (void)
{
if (gfc_static_ctors != NULL_TREE)
abort ();
#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_CONTEXT (decl) = fndecl;
DECL_RESULT (fndecl) = decl;
pushdecl (fndecl);
current_function_decl = fndecl;
rest_of_decl_compilation (fndecl, NULL, 1, 0);
make_decl_rtl (fndecl, NULL);
init_function_start (fndecl, input_filename, input_line);
cfun->x_whole_function_mode_p = 1;
immediate_size_expand = 0;
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, 0);
current_function_decl = NULL_TREE;
#endif
}
#include "gt-fortran-trans-decl.h"