#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 "rtl.h"
#include "target.h"
#include "function.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 parent_fake_result_decl;
static GTY(()) tree current_function_return_label;
static GTY(()) tree saved_function_decls;
static GTY(()) tree saved_parent_function_decls;
static gfc_namespace *module_namespace;
tree gfc_static_ctors;
tree gfor_fndecl_internal_malloc;
tree gfor_fndecl_internal_malloc64;
tree gfor_fndecl_internal_realloc;
tree gfor_fndecl_internal_realloc64;
tree gfor_fndecl_internal_free;
tree gfor_fndecl_allocate;
tree gfor_fndecl_allocate64;
tree gfor_fndecl_allocate_array;
tree gfor_fndecl_allocate64_array;
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_set_fpe;
tree gfor_fndecl_set_std;
tree gfor_fndecl_set_convert;
tree gfor_fndecl_set_record_marker;
tree gfor_fndecl_set_max_subrecord_length;
tree gfor_fndecl_ctime;
tree gfor_fndecl_fdate;
tree gfor_fndecl_ttynam;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
tree gfor_fndecl_associated;
gfc_powdecl_list gfor_fndecl_math_powi[4][3];
tree gfor_fndecl_math_cpowf;
tree gfor_fndecl_math_cpow;
tree gfor_fndecl_math_cpowl10;
tree gfor_fndecl_math_cpowl16;
tree gfor_fndecl_math_ishftc4;
tree gfor_fndecl_math_ishftc8;
tree gfor_fndecl_math_ishftc16;
tree gfor_fndecl_math_exponent4;
tree gfor_fndecl_math_exponent8;
tree gfor_fndecl_math_exponent10;
tree gfor_fndecl_math_exponent16;
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.external
|| 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_cray_pointee (tree decl, gfc_symbol *sym)
{
tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
tree value;
if (sym->cp_pointer->attr.dummy)
ptr_decl = build_fold_indirect_ref (ptr_decl);
if (sym->attr.dimension
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
{
value = convert (TREE_TYPE (decl), ptr_decl);
}
else
{
ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
ptr_decl);
value = build_fold_indirect_ref (ptr_decl);
}
SET_DECL_VALUE_EXPR (decl, value);
DECL_HAS_VALUE_EXPR_P (decl) = 1;
GFC_DECL_CRAY_POINTEE (decl) = 1;
TREE_ASM_WRITTEN (decl) = 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.cray_pointee)
gfc_finish_cray_pointee (decl, 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
|| sym->result == sym)
gfc_add_decl_to_function (decl);
else
gfc_add_decl_to_parent_function (decl);
}
if (sym->attr.cray_pointee)
return;
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 || sym->result == sym);
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_CODE (TREE_TYPE (decl)) != POINTER_TYPE
|| sym->attr.dimension == 0
|| sym->as->type != AS_EXPLICIT
|| sym->attr.pointer
|| sym->attr.allocatable)
&& !DECL_ARTIFICIAL (decl))
TREE_STATIC (decl) = 1;
if (sym->attr.threadprivate && targetm.have_tls
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
}
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));
}
if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
&& sym->as->type != AS_ASSUMED_SIZE)
GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
if (POINTER_TYPE_P (type))
{
gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
gcc_assert (TYPE_LANG_SPECIFIC (type)
== TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
type = TREE_TYPE (type);
}
if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
{
tree size, range;
size = build2 (MINUS_EXPR, gfc_array_index_type,
GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
range = build_range_type (gfc_array_index_type, gfc_index_zero_node,
size);
TYPE_DOMAIN (type) = range;
layout_type (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
{
DECL_ARTIFICIAL (sym->backend_decl) = 1;
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;
if (sym->ns->proc_name->tlink != NULL)
gfc_defer_symbol_init (sym);
sym->ts.cl->backend_decl = length;
}
return sym->ts.cl->backend_decl;
}
static void
gfc_add_assign_aux_vars (gfc_symbol * sym)
{
tree addr;
tree length;
tree decl;
gcc_assert (sym->backend_decl);
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),
gfc_charlen_type_node);
addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
pvoid_type_node);
gfc_finish_var_decl (length, sym);
gfc_finish_var_decl (addr, sym);
if (TREE_STATIC (length))
DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
else
gfc_defer_symbol_init (sym);
GFC_DECL_STRING_LEN (decl) = length;
GFC_DECL_ASSIGN_ADDR (decl) = addr;
}
tree
gfc_get_symbol_decl (gfc_symbol * sym)
{
tree decl;
tree length = NULL_TREE;
int byref;
gcc_assert (sym->attr.referenced
|| sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
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);
if (sym->ns->proc_name->attr.entry_master)
sym->backend_decl = TREE_CHAIN (sym->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);
else
length = sym->ts.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
{
if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
gfc_add_decl_to_function (length);
else
gfc_add_decl_to_parent_function (length);
gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
DECL_CONTEXT (length));
gfc_defer_symbol_init (sym);
}
}
if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
{
decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
if (sym->backend_decl != NULL && decl != sym->backend_decl)
DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = decl;
}
TREE_USED (sym->backend_decl) = 1;
if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
{
gfc_add_assign_aux_vars (sym);
}
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;
}
if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
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 (sym->attr.assign)
{
gfc_add_assign_aux_vars (sym);
}
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 + 13];
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
{
if (isym->formal->next->next == NULL)
isym->resolve.f2 (&e, &argexpr, NULL);
else
{
gcc_assert (isym->formal->next->next->next == NULL);
isym->resolve.f3 (&e, &argexpr, NULL, NULL);
}
}
if (gfc_option.flag_f2c
&& ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
|| e.ts.type == BT_COMPLEX))
{
sprintf (s, "f2c_specific%s", e.value.function.name);
}
else
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 && !gfc_return_by_reference (sym))
DECL_IS_PURE (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
if (sym->attr.noreturn)
TREE_THIS_VOLATILE(fndecl) = 1;
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 && !gfc_return_by_reference (sym))
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, hidden_typelist;
tree arglist, hidden_arglist;
tree type;
tree parm;
fndecl = sym->backend_decl;
arglist = NULL_TREE;
hidden_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);
DECL_ARTIFICIAL (parm) = 1;
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
if (gfc_return_by_reference (sym))
{
tree type = TREE_VALUE (typelist), length = NULL;
if (sym->ts.type == BT_CHARACTER)
{
tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
gcc_assert (len_type == gfc_charlen_type_node);
length = build_decl (PARM_DECL,
get_identifier (".__result"),
len_type);
if (!sym->ts.cl->length)
{
sym->ts.cl->backend_decl = length;
TREE_USED (length) = 1;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
DECL_CONTEXT (length) = fndecl;
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length, NULL_TREE);
if (sym->ts.cl->backend_decl == NULL
|| sym->ts.cl->backend_decl == length)
{
gfc_symbol *arg;
tree backend_decl;
if (sym->ts.cl->backend_decl == NULL)
{
tree len = build_decl (VAR_DECL,
get_identifier ("..__result"),
gfc_charlen_type_node);
DECL_ARTIFICIAL (len) = 1;
TREE_USED (len) = 1;
sym->ts.cl->backend_decl = len;
}
arg = sym->result ? sym->result : sym;
backend_decl = arg->backend_decl;
arg->backend_decl = NULL;
type = gfc_sym_type (arg);
arg->backend_decl = backend_decl;
type = build_reference_type (type);
}
}
parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
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);
arglist = chainon (arglist, length);
typelist = TREE_CHAIN (typelist);
}
}
hidden_typelist = typelist;
for (f = sym->formal; f; f = f->next)
if (f->sym != NULL)
hidden_typelist = TREE_CHAIN (hidden_typelist);
for (f = sym->formal; f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
if (f->sym == NULL)
continue;
type = TREE_VALUE (typelist);
if (f->sym->ts.type == BT_CHARACTER)
{
tree len_type = TREE_VALUE (hidden_typelist);
tree length = NULL_TREE;
gcc_assert (len_type == gfc_charlen_type_node);
strcpy (&name[1], f->sym->name);
name[0] = '_';
length = build_decl (PARM_DECL, get_identifier (name), len_type);
hidden_arglist = chainon (hidden_arglist, length);
DECL_CONTEXT (length) = fndecl;
DECL_ARTIFICIAL (length) = 1;
DECL_ARG_TYPE (length) = len_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;
}
}
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.cl->backend_decl == NULL)
gfc_create_string_length (f->sym);
if (f->sym->attr.flavor == FL_PROCEDURE)
type = build_pointer_type (gfc_get_function_type (f->sym));
else
type = gfc_sym_type (f->sym);
}
}
if (f->sym->attr.dimension
&& type == TREE_VALUE (typelist)
&& TREE_CODE (type) == POINTER_TYPE
&& GFC_ARRAY_TYPE_P (type)
&& f->sym->as->type != AS_ASSUMED_SIZE
&& ! COMPLETE_TYPE_P (TREE_TYPE (type)))
{
if (f->sym->attr.flavor == FL_PROCEDURE)
type = build_pointer_type (gfc_get_function_type (f->sym));
else
type = gfc_sym_type (f->sym);
}
parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
TREE_READONLY (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
f->sym->backend_decl = parm;
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
arglist = chainon (arglist, hidden_arglist);
gcc_assert (hidden_typelist == NULL_TREE
|| TREE_VALUE (hidden_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);
if (flag_openmp)
diagnose_omp_structured_block_errors (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);
}
#ifndef ENABLE_LLVM
make_decl_rtl (fndecl);
#else
make_decl_llvm (fndecl);
#endif
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 (thunk_sym->attr.function)
{
if (gfc_return_by_reference (ns->proc_name))
{
tree ref = DECL_ARGUMENTS (current_function_decl);
args = tree_cons (NULL_TREE, ref, args);
if (ns->proc_name->ts.type == BT_CHARACTER)
args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
args);
}
}
for (formal = ns->proc_name->formal; formal; formal = formal->next)
{
if (formal->sym == NULL)
continue;
for (thunk_formal = thunk_sym->formal;
thunk_formal;
thunk_formal = thunk_formal->next)
{
if (thunk_formal->sym == formal->sym)
break;
}
if (thunk_formal)
{
DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
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 = build_int_cst (gfc_charlen_type_node, 0);
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 = build_function_call_expr (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"),
TREE_TYPE (master_type));
DECL_ARTIFICIAL (union_decl) = 1;
DECL_EXTERNAL (union_decl) = 0;
TREE_PUBLIC (union_decl) = 0;
TREE_USED (union_decl) = 1;
layout_decl (union_decl, 0);
pushdecl (union_decl);
DECL_CONTEXT (union_decl) = current_function_decl;
tmp = build2 (MODIFY_EXPR,
TREE_TYPE (union_decl),
union_decl, tmp);
gfc_add_expr_to_block (&body, tmp);
for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
field; field = TREE_CHAIN (field))
if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
thunk_sym->result->name) == 0)
break;
gcc_assert (field != NULL_TREE);
tmp = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
NULL_TREE);
tmp = build2 (MODIFY_EXPR,
TREE_TYPE (DECL_RESULT (current_function_decl)),
DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
}
else if (TREE_TYPE (DECL_RESULT (current_function_decl))
!= void_type_node)
{
tmp = build2 (MODIFY_EXPR,
TREE_TYPE (DECL_RESULT (current_function_decl)),
DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
}
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)
if (formal->sym != NULL)
{
formal->sym->backend_decl = NULL_TREE;
if (formal->sym->ts.type == BT_CHARACTER)
formal->sym->ts.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;
if (thunk_sym->result->ts.type == BT_CHARACTER)
thunk_sym->result->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, int parent_flag)
{
tree decl;
tree length;
tree this_fake_result_decl;
tree this_function_decl;
char name[GFC_MAX_SYMBOL_LEN + 10];
if (parent_flag)
{
this_fake_result_decl = parent_fake_result_decl;
this_function_decl = DECL_CONTEXT (current_function_decl);
}
else
{
this_fake_result_decl = current_fake_result_decl;
this_function_decl = current_function_decl;
}
if (sym
&& sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master
&& sym != sym->ns->proc_name)
{
tree t = NULL, var;
if (this_fake_result_decl != NULL)
for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
break;
if (t)
return TREE_VALUE (t);
decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
if (parent_flag)
this_fake_result_decl = parent_fake_result_decl;
else
this_fake_result_decl = current_fake_result_decl;
if (decl && sym->ns->proc_name->attr.mixed_entry_master)
{
tree field;
for (field = TYPE_FIELDS (TREE_TYPE (decl));
field; field = TREE_CHAIN (field))
if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
sym->name) == 0)
break;
gcc_assert (field != NULL_TREE);
decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
NULL_TREE);
}
var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
if (parent_flag)
gfc_add_decl_to_parent_function (var);
else
gfc_add_decl_to_function (var);
SET_DECL_VALUE_EXPR (var, decl);
DECL_HAS_VALUE_EXPR_P (var) = 1;
GFC_DECL_RESULT (var) = 1;
TREE_CHAIN (this_fake_result_decl)
= tree_cons (get_identifier (sym->name), var,
TREE_CHAIN (this_fake_result_decl));
return var;
}
if (this_fake_result_decl != NULL_TREE)
return TREE_VALUE (this_fake_result_decl);
if (!sym)
return NULL_TREE;
if (sym->ts.type == BT_CHARACTER)
{
if (sym->ts.cl->backend_decl == NULL_TREE)
length = gfc_create_string_length (sym);
else
length = sym->ts.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
gfc_add_decl_to_function (length);
}
if (gfc_return_by_reference (sym))
{
decl = DECL_ARGUMENTS (this_function_decl);
if (sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master)
decl = TREE_CHAIN (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 (this_function_decl)));
if (!sym->attr.mixed_entry_master && sym->attr.function)
decl = build_decl (VAR_DECL, get_identifier (name),
gfc_sym_type (sym));
else
decl = build_decl (VAR_DECL, get_identifier (name),
TREE_TYPE (TREE_TYPE (this_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
DECL_EXTERNAL (decl) = 0;
TREE_PUBLIC (decl) = 0;
TREE_USED (decl) = 1;
GFC_DECL_RESULT (decl) = 1;
TREE_ADDRESSABLE (decl) = 1;
layout_decl (decl, 0);
if (parent_flag)
gfc_add_decl_to_parent_function (decl);
else
gfc_add_decl_to_function (decl);
}
if (parent_flag)
parent_fake_result_decl = build_tree_list (NULL, decl);
else
current_fake_result_decl = build_tree_list (NULL, 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 = (nargs >= 0 ? nargs : -nargs - 1); 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_int16_type_node = gfc_get_int_type (16);
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_real10_type_node = gfc_get_real_type (10);
tree gfc_real16_type_node = gfc_get_real_type (16);
tree gfc_complex4_type_node = gfc_get_complex_type (4);
tree gfc_complex8_type_node = gfc_get_complex_type (8);
tree gfc_complex10_type_node = gfc_get_complex_type (10);
tree gfc_complex16_type_node = gfc_get_complex_type (16);
tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
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_ttynam =
gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
void_type_node,
3,
pchar_type_node,
gfc_charlen_type_node,
gfc_c_int_type_node);
gfor_fndecl_fdate =
gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
void_type_node,
2,
pchar_type_node,
gfc_charlen_type_node);
gfor_fndecl_ctime =
gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
void_type_node,
3,
pchar_type_node,
gfc_charlen_type_node,
gfc_int8_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 ctype, rtype, itype, jtype;
int rkind, ikind, jkind;
#define NIKINDS 3
#define NRKINDS 4
static int ikinds[NIKINDS] = {4, 8, 16};
static int rkinds[NRKINDS] = {4, 8, 10, 16};
char name[PREFIX_LEN + 12];
for (ikind=0; ikind < NIKINDS; ikind++)
{
itype = gfc_get_int_type (ikinds[ikind]);
for (jkind=0; jkind < NIKINDS; jkind++)
{
jtype = gfc_get_int_type (ikinds[jkind]);
if (itype && jtype)
{
sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
ikinds[jkind]);
gfor_fndecl_math_powi[jkind][ikind].integer =
gfc_build_library_function_decl (get_identifier (name),
jtype, 2, jtype, itype);
}
}
for (rkind = 0; rkind < NRKINDS; rkind ++)
{
rtype = gfc_get_real_type (rkinds[rkind]);
if (rtype && itype)
{
sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
ikinds[ikind]);
gfor_fndecl_math_powi[rkind][ikind].real =
gfc_build_library_function_decl (get_identifier (name),
rtype, 2, rtype, itype);
}
ctype = gfc_get_complex_type (rkinds[rkind]);
if (ctype && itype)
{
sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
ikinds[ikind]);
gfor_fndecl_math_powi[rkind][ikind].cmplx =
gfc_build_library_function_decl (get_identifier (name),
ctype, 2,ctype, itype);
}
}
}
#undef NIKINDS
#undef NRKINDS
}
gfor_fndecl_math_cpowf =
gfc_build_library_function_decl (get_identifier ("cpowf"),
gfc_complex4_type_node, 2,
gfc_complex4_type_node,
gfc_complex4_type_node);
gfor_fndecl_math_cpow =
gfc_build_library_function_decl (get_identifier ("cpow"),
gfc_complex8_type_node, 2,
gfc_complex8_type_node,
gfc_complex8_type_node);
if (gfc_complex10_type_node)
gfor_fndecl_math_cpowl10 =
gfc_build_library_function_decl (get_identifier ("cpowl"),
gfc_complex10_type_node, 2,
gfc_complex10_type_node,
gfc_complex10_type_node);
if (gfc_complex16_type_node)
gfor_fndecl_math_cpowl16 =
gfc_build_library_function_decl (get_identifier ("cpowl"),
gfc_complex16_type_node, 2,
gfc_complex16_type_node,
gfc_complex16_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_int4_type_node, gfc_int4_type_node);
if (gfc_int16_type_node)
gfor_fndecl_math_ishftc16 =
gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
gfc_int16_type_node, 3,
gfc_int16_type_node,
gfc_int4_type_node,
gfc_int4_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);
if (gfc_real10_type_node)
gfor_fndecl_math_exponent10 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
gfc_int4_type_node, 1,
gfc_real10_type_node);
if (gfc_real16_type_node)
gfor_fndecl_math_exponent16 =
gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
gfc_int4_type_node, 1,
gfc_real16_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_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
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_pint4_type_node = build_pointer_type (gfc_int4_type_node);
gfor_fndecl_internal_malloc =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
pvoid_type_node, 1, gfc_int4_type_node);
DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
gfor_fndecl_internal_malloc64 =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_malloc64")),
pvoid_type_node, 1, gfc_int8_type_node);
DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
gfor_fndecl_internal_realloc =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_realloc")),
pvoid_type_node, 2, pvoid_type_node,
gfc_int4_type_node);
gfor_fndecl_internal_realloc64 =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_realloc64")),
pvoid_type_node, 2, pvoid_type_node,
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")),
pvoid_type_node, 2,
gfc_int4_type_node, gfc_pint4_type_node);
DECL_IS_MALLOC (gfor_fndecl_allocate) = 1;
gfor_fndecl_allocate64 =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
pvoid_type_node, 2,
gfc_int8_type_node, gfc_pint4_type_node);
DECL_IS_MALLOC (gfor_fndecl_allocate64) = 1;
gfor_fndecl_allocate_array =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
pvoid_type_node, 3, pvoid_type_node,
gfc_int4_type_node, gfc_pint4_type_node);
DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1;
gfor_fndecl_allocate64_array =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
pvoid_type_node, 3, pvoid_type_node,
gfc_int8_type_node, gfc_pint4_type_node);
DECL_IS_MALLOC (gfor_fndecl_allocate64_array) = 1;
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
void_type_node, 2, pvoid_type_node,
gfc_pint4_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
void_type_node, 1, gfc_int4_type_node);
TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
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);
TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
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, 5, pvoid_type_node, gfc_c_int_type_node,
pvoid_type_node, pchar_type_node, gfc_c_int_type_node);
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
void_type_node, 1, pchar_type_node);
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
gfor_fndecl_set_fpe =
gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
void_type_node, 1, gfc_c_int_type_node);
gfor_fndecl_set_std =
gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
void_type_node,
3,
gfc_int4_type_node,
gfc_int4_type_node,
gfc_int4_type_node);
gfor_fndecl_set_convert =
gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
void_type_node, 1, gfc_c_int_type_node);
gfor_fndecl_set_record_marker =
gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
void_type_node, 1, gfc_c_int_type_node);
gfor_fndecl_set_max_subrecord_length =
gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
void_type_node, 1, gfc_c_int_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, 2, pvoid_type_node, 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_symbol *sym, 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_trans_vla_type_sizes (sym, &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);
gfc_trans_vla_type_sizes (sym, &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_assign_aux_var (gfc_symbol * sym, tree fnbody)
{
stmtblock_t body;
gcc_assert (sym->backend_decl);
gfc_start_block (&body);
gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
build_int_cst (NULL_TREE, -2));
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
static void
gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
{
tree t = *tp, var, val;
if (t == NULL || t == error_mark_node)
return;
if (TREE_CONSTANT (t) || DECL_P (t))
return;
if (TREE_CODE (t) == SAVE_EXPR)
{
if (SAVE_EXPR_RESOLVED_P (t))
{
*tp = TREE_OPERAND (t, 0);
return;
}
val = TREE_OPERAND (t, 0);
}
else
val = t;
var = gfc_create_var_np (TREE_TYPE (t), NULL);
gfc_add_decl_to_function (var);
gfc_add_modify_expr (body, var, val);
if (TREE_CODE (t) == SAVE_EXPR)
TREE_OPERAND (t, 0) = var;
*tp = var;
}
static void
gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
{
tree t;
if (type == NULL || type == error_mark_node)
return;
type = TYPE_MAIN_VARIANT (type);
if (TREE_CODE (type) == INTEGER_TYPE)
{
gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
{
TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
}
}
else if (TREE_CODE (type) == ARRAY_TYPE)
{
gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
{
TYPE_SIZE (t) = TYPE_SIZE (type);
TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
}
}
}
void
gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
{
tree type = TREE_TYPE (sym->backend_decl);
if (TREE_CODE (type) == FUNCTION_TYPE
&& (sym->attr.function || sym->attr.result || sym->attr.entry))
{
if (! current_fake_result_decl)
return;
type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
}
while (POINTER_TYPE_P (type))
type = TREE_TYPE (type);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
while (POINTER_TYPE_P (etype))
etype = TREE_TYPE (etype);
gfc_trans_vla_type_sizes_1 (etype, body);
}
gfc_trans_vla_type_sizes_1 (type, body);
}
static tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
locus loc;
gfc_symbol *sym;
gfc_formal_arglist *f;
stmtblock_t body;
bool seen_trans_deferred_array = false;
if (gfc_return_by_reference (proc_sym) && proc_sym->result == proc_sym)
{
if (!current_fake_result_decl)
{
gfc_entry_list *el = NULL;
if (proc_sym->attr.entry_master)
{
for (el = proc_sym->ns->entries; el; el = el->next)
if (el->sym != el->sym->result)
break;
}
if (el == NULL)
warning (0, "Function does not return a value");
}
else if (proc_sym->as)
{
tree result = TREE_VALUE (current_fake_result_decl);
fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
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,
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,
fnbody);
}
else
gcc_assert (gfc_option.flag_f2c
&& proc_sym->ts.type == BT_COMPLEX);
}
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;
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
{
seen_trans_deferred_array = true;
fnbody = gfc_trans_deferred_array (sym, fnbody);
}
}
else
{
if (sym_has_alloc_comp)
{
seen_trans_deferred_array = true;
fnbody = gfc_trans_deferred_array (sym, fnbody);
}
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:
seen_trans_deferred_array = true;
fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
if (sym_has_alloc_comp && !seen_trans_deferred_array)
fnbody = gfc_trans_deferred_array (sym, fnbody);
}
else if (sym_has_alloc_comp)
fnbody = gfc_trans_deferred_array (sym, fnbody);
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);
else
fnbody = gfc_trans_auto_character_variable (sym, fnbody);
gfc_set_backend_locus (&loc);
}
else if (sym->attr.assign)
{
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
fnbody = gfc_trans_assign_aux_var (sym, fnbody);
gfc_set_backend_locus (&loc);
}
else
gcc_unreachable ();
}
gfc_init_block (&body);
for (f = proc_sym->formal; f; f = f->next)
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)
gfc_trans_vla_type_sizes (f->sym, &body);
}
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)
gfc_trans_vla_type_sizes (proc_sym, &body);
}
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
static void
gfc_create_module_variable (gfc_symbol * sym)
{
tree decl;
if (sym->attr.entry)
return;
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
&& (sym->equiv_built || sym->attr.in_equivalence))
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 *);
static void
generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
{
gfc_actual_arglist *arg;
gfc_ref *ref;
int i;
if (e == NULL)
return;
switch (e->expr_type)
{
case EXPR_FUNCTION:
for (arg = e->value.function.actual; arg; arg = arg->next)
generate_expr_decls (sym, arg->expr);
break;
case EXPR_VARIABLE:
if (sym == e->symtree->n.sym
|| e->symtree->n.sym->mark
|| e->symtree->n.sym->ns != sym->ns)
return;
generate_local_decl (e->symtree->n.sym);
break;
case EXPR_OP:
generate_expr_decls (sym, e->value.op.op1);
generate_expr_decls (sym, e->value.op.op2);
break;
default:
break;
}
if (e->ref)
{
for (ref = e->ref; ref; ref = ref->next)
{
switch (ref->type)
{
case REF_ARRAY:
for (i = 0; i < ref->u.ar.dimen; i++)
{
generate_expr_decls (sym, ref->u.ar.start[i]);
generate_expr_decls (sym, ref->u.ar.end[i]);
generate_expr_decls (sym, ref->u.ar.stride[i]);
}
break;
case REF_SUBSTRING:
generate_expr_decls (sym, ref->u.ss.start);
generate_expr_decls (sym, ref->u.ss.end);
break;
case REF_COMPONENT:
if (ref->u.c.component->ts.type == BT_CHARACTER
&& ref->u.c.component->ts.cl->length->expr_type
!= EXPR_CONSTANT)
generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
if (ref->u.c.component->as)
for (i = 0; i < ref->u.c.component->as->rank; i++)
{
generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
}
break;
}
}
}
}
static void
generate_dependency_declarations (gfc_symbol *sym)
{
int i;
if (sym->ts.type == BT_CHARACTER
&& sym->ts.cl->length->expr_type != EXPR_CONSTANT)
generate_expr_decls (sym, sym->ts.cl->length);
if (sym->as && sym->as->rank)
{
for (i = 0; i < sym->as->rank; i++)
{
generate_expr_decls (sym, sym->as->lower[i]);
generate_expr_decls (sym, sym->as->upper[i]);
}
}
}
static void
generate_local_decl (gfc_symbol * sym)
{
if (sym->attr.flavor == FL_VARIABLE)
{
sym->mark = 1;
if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
generate_dependency_declarations (sym);
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
else if (sym->attr.dummy && warn_unused_parameter)
gfc_warning ("Unused parameter %s declared at %L", sym->name,
&sym->declared_at);
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->attr.use_assoc))
gfc_warning ("Unused variable %s declared at %L", sym->name,
&sym->declared_at);
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->attr.referenced = 1;
gfc_get_symbol_decl (sym);
}
}
}
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;
tree tmp2;
stmtblock_t block;
stmtblock_t body;
tree result;
gfc_symbol *sym;
int rank;
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);
gfc_start_block (&block);
if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
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;
for (el = ns->entries; el; el = el->next)
el->sym->result->ts.cl->backend_decl = backend_decl;
}
gfc_trans_common (ns);
if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
|| ns->parent == NULL)
parent_fake_result_decl = NULL_TREE;
gfc_generate_contained_functions (ns);
generate_local_vars (ns);
if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
|| ns->parent == NULL)
current_fake_result_decl = parent_fake_result_decl;
else
current_fake_result_decl = NULL_TREE;
current_function_return_label = NULL;
gfc_init_block (&body);
if (sym->attr.is_main_program)
{
tree arglist, gfc_int4_type_node;
gfc_int4_type_node = gfc_get_int_type (4);
arglist = gfc_chainon_list (NULL_TREE,
build_int_cst (gfc_int4_type_node,
gfc_option.warn_std));
arglist = gfc_chainon_list (arglist,
build_int_cst (gfc_int4_type_node,
gfc_option.allow_std));
arglist = gfc_chainon_list (arglist,
build_int_cst (gfc_int4_type_node,
pedantic));
tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.fpe != 0)
{
tree arglist, gfc_c_int_type_node;
gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
arglist = gfc_chainon_list (NULL_TREE,
build_int_cst (gfc_c_int_type_node,
gfc_option.fpe));
tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
{
tree arglist, gfc_c_int_type_node;
gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
arglist = gfc_chainon_list (NULL_TREE,
build_int_cst (gfc_c_int_type_node,
gfc_option.convert));
tmp = build_function_call_expr (gfor_fndecl_set_convert, arglist);
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.record_marker != 0)
{
tree arglist, gfc_c_int_type_node;
gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
arglist = gfc_chainon_list (NULL_TREE,
build_int_cst (gfc_c_int_type_node,
gfc_option.record_marker));
tmp = build_function_call_expr (gfor_fndecl_set_record_marker, arglist);
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
{
tree arglist, gfc_c_int_type_node;
gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
arglist = gfc_chainon_list (NULL_TREE,
build_int_cst (gfc_c_int_type_node,
gfc_option.max_subrecord_length));
tmp = build_function_call_expr (gfor_fndecl_set_max_subrecord_length, arglist);
gfc_add_expr_to_block (&body, tmp);
}
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
&& sym->attr.subroutine)
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym, 0);
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);
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
if (sym->attr.subroutine || sym == sym->result)
{
if (current_fake_result_decl != NULL)
result = TREE_VALUE (current_fake_result_decl);
else
result = NULL_TREE;
current_fake_result_decl = NULL_TREE;
}
else
result = sym->result->backend_decl;
if (result != NULL_TREE && sym->attr.function
&& sym->ts.type == BT_DERIVED
&& sym->ts.derived->attr.alloc_comp
&& !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);
}
gfc_add_expr_to_block (&block, tmp);
if (result == NULL_TREE)
warning (0, "Function return value not set");
else
{
tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
tmp = build2 (MODIFY_EXPR, TREE_TYPE (tmp),
DECL_RESULT (fndecl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
else
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);
#ifndef ENABLE_LLVM
make_decl_rtl (fndecl);
#else
make_decl_llvm (fndecl);
#endif
init_function_start (fndecl);
pushlevel (0);
for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
{
tmp =
build_function_call_expr (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"