tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_numeric;
+tree gfor_fndecl_stop_numeric_f08;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_error_stop_numeric;
tree gfor_fndecl_error_stop_string;
/* Other misc. runtime library functions. */
-
tree gfor_fndecl_size0;
tree gfor_fndecl_size1;
tree gfor_fndecl_iargc;
-tree gfor_fndecl_clz128;
-tree gfor_fndecl_ctz128;
/* Intrinsic functions implemented in Fortran. */
tree gfor_fndecl_sc_kind;
if (sym->attr.volatile_)
{
TREE_THIS_VOLATILE (decl) = 1;
+ TREE_SIDE_EFFECTS (decl) = 1;
new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
TREE_TYPE (decl) = new_type;
}
{
tree size, range;
- size = fold_build2 (MINUS_EXPR, gfc_array_index_type,
- GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
+ size = fold_build2_loc (input_location, 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;
tree length = NULL_TREE;
tree attributes;
int byref;
+ bool intrinsic_array_parameter = false;
gcc_assert (sym->attr.referenced
|| sym->attr.use_assoc
else
length = sym->ts.u.cl->backend_decl;
if (TREE_CODE (length) == VAR_DECL
- && DECL_CONTEXT (length) == NULL_TREE)
+ && DECL_FILE_SCOPE_P (length))
{
/* Add the string length to the same context as the symbol. */
if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
if (sym->backend_decl)
return sym->backend_decl;
+ /* Special case for array-valued named constants from intrinsic
+ procedures; those are inlined. */
+ if (sym->attr.use_assoc && sym->from_intmod
+ && sym->attr.flavor == FL_PARAMETER)
+ intrinsic_array_parameter = true;
+
/* If use associated and whole file compilation, use the module
declaration. */
if (gfc_option.flag_whole_file
- && sym->attr.flavor == FL_VARIABLE
- && sym->attr.use_assoc
+ && (sym->attr.flavor == FL_VARIABLE
+ || sym->attr.flavor == FL_PARAMETER)
+ && sym->attr.use_assoc && !intrinsic_array_parameter
&& sym->module)
{
gfc_gsymbol *gsym;
if (sym->module)
{
gfc_set_decl_assembler_name (decl, gfc_sym_mangled_identifier (sym));
- if (sym->attr.use_assoc)
+ if (sym->attr.use_assoc && !intrinsic_array_parameter)
DECL_IGNORED_P (decl) = 1;
}
}
/* Remember this variable for allocation/cleanup. */
- if (sym->attr.dimension || sym->attr.allocatable || sym->assoc
+ if (sym->attr.dimension || sym->attr.allocatable
|| (sym->ts.type == BT_CLASS &&
(CLASS_DATA (sym)->attr.dimension
|| CLASS_DATA (sym)->attr.allocatable))
&& !sym->attr.data
&& !sym->attr.allocatable
&& (sym->value && !sym->ns->proc_name->attr.is_main_program)
- && !sym->attr.use_assoc))
+ && !(sym->attr.use_assoc && !intrinsic_array_parameter)))
gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
if (sym->attr.assign)
gfc_add_assign_aux_vars (sym);
- if (TREE_STATIC (decl) && !sym->attr.use_assoc
+ if (intrinsic_array_parameter)
+ {
+ TREE_STATIC (decl) = 1;
+ DECL_EXTERNAL (decl) = 0;
+ }
+
+ if (TREE_STATIC (decl)
+ && !(sym->attr.use_assoc && !intrinsic_array_parameter)
&& (sym->attr.save || sym->ns->proc_name->attr.is_main_program
|| gfc_option.flag_max_stack_var_size == 0
|| sym->attr.data || sym->ns->proc_name->attr.flavor == FL_MODULE))
tree save_fn_decl = current_function_decl;
current_function_decl = NULL_TREE;
- gfc_get_backend_locus (&old_loc);
+ gfc_save_backend_locus (&old_loc);
push_cfun (cfun);
gfc_create_function_decl (gsym->ns, true);
pop_cfun ();
- gfc_set_backend_locus (&old_loc);
+ gfc_restore_backend_locus (&old_loc);
current_function_decl = save_fn_decl;
}
/* Allow only one nesting level. Allow public declarations. */
gcc_assert (current_function_decl == NULL_TREE
- || DECL_CONTEXT (current_function_decl) == NULL_TREE
- || TREE_CODE (DECL_CONTEXT (current_function_decl))
- == NAMESPACE_DECL);
+ || DECL_FILE_SCOPE_P (current_function_decl)
+ || (TREE_CODE (DECL_CONTEXT (current_function_decl))
+ == NAMESPACE_DECL));
type = gfc_get_function_type (sym);
fndecl = build_decl (input_location,
attributes = add_attributes_to_decl (attr, NULL_TREE);
decl_attributes (&fndecl, attributes, 0);
- /* Perform name mangling if this is a top level or module procedure. */
- if (current_function_decl == NULL_TREE)
- gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
-
/* Figure out the return type of the declared function, and build a
RESULT_DECL for it. If this is a subroutine with alternate
returns, build a RESULT_DECL for it. */
layout_decl (result_decl, 0); */
/* Set up all attributes for the function. */
- DECL_CONTEXT (fndecl) = current_function_decl;
DECL_EXTERNAL (fndecl) = 0;
/* This specifies if a function is globally visible, i.e. it is
the opposite of declaring static in C. */
- if (DECL_CONTEXT (fndecl) == NULL_TREE
+ if (!current_function_decl
&& !sym->attr.entry_master && !sym->attr.is_main_program)
TREE_PUBLIC (fndecl) = 1;
else
pushdecl (fndecl);
+ /* Perform name mangling if this is a top level or module procedure. */
+ if (current_function_decl == NULL_TREE)
+ gfc_set_decl_assembler_name (fndecl, gfc_sym_mangled_function_id (sym));
+
sym->backend_decl = fndecl;
}
if (f->sym->attr.proc_pointer)
type = build_pointer_type (type);
+ if (f->sym->attr.volatile_)
+ type = build_qualified_type (type, TYPE_QUAL_VOLATILE);
+
/* Build the argument declaration. */
parm = build_decl (input_location,
PARM_DECL, gfc_sym_identifier (f->sym), type);
+ if (f->sym->attr.volatile_)
+ {
+ TREE_THIS_VOLATILE (parm) = 1;
+ TREE_SIDE_EFFECTS (parm) = 1;
+ }
+
/* Fill in arg stuff. */
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
/* Let the world know what we're about to do. */
announce_function (fndecl);
- if (DECL_CONTEXT (fndecl) == NULL_TREE)
+ if (DECL_FILE_SCOPE_P (fndecl))
{
/* Create RTL for function declaration. */
rest_of_decl_compilation (fndecl, 1, 0);
/* This should always be a toplevel function. */
gcc_assert (current_function_decl == NULL_TREE);
- gfc_get_backend_locus (&old_loc);
+ gfc_save_backend_locus (&old_loc);
for (el = ns->entries; el; el = el->next)
{
VEC(tree,gc) *args = NULL;
pushdecl (union_decl);
DECL_CONTEXT (union_decl) = current_function_decl;
- tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (union_decl),
- union_decl, tmp);
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (union_decl), union_decl, tmp);
gfc_add_expr_to_block (&body, tmp);
for (field = TYPE_FIELDS (TREE_TYPE (union_decl));
thunk_sym->result->name) == 0)
break;
gcc_assert (field != NULL_TREE);
- tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- union_decl, field, NULL_TREE);
- tmp = fold_build2 (MODIFY_EXPR,
+ tmp = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field), union_decl, field,
+ NULL_TREE);
+ tmp = fold_build2_loc (input_location, 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 = fold_build2 (MODIFY_EXPR,
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR,
TREE_TYPE (DECL_RESULT (current_function_decl)),
DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
}
}
- gfc_set_backend_locus (&old_loc);
+ gfc_restore_backend_locus (&old_loc);
}
break;
gcc_assert (field != NULL_TREE);
- decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
- decl, field, NULL_TREE);
+ decl = fold_build3_loc (input_location, COMPONENT_REF,
+ TREE_TYPE (field), decl, field, NULL_TREE);
}
var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
gfor_fndecl_iargc = gfc_build_library_function_decl (
get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
TREE_NOTHROW (gfor_fndecl_iargc) = 1;
-
- if (gfc_type_for_size (128, true))
- {
- tree uint128 = gfc_type_for_size (128, true);
-
- gfor_fndecl_clz128 = gfc_build_library_function_decl (
- get_identifier (PREFIX ("clz128")), integer_type_node, 1, uint128);
- TREE_READONLY (gfor_fndecl_clz128) = 1;
- TREE_NOTHROW (gfor_fndecl_clz128) = 1;
-
- gfor_fndecl_ctz128 = gfc_build_library_function_decl (
- get_identifier (PREFIX ("ctz128")), integer_type_node, 1, uint128);
- TREE_READONLY (gfor_fndecl_ctz128) = 1;
- TREE_NOTHROW (gfor_fndecl_ctz128) = 1;
- }
}
/* STOP doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
+ gfor_fndecl_stop_numeric_f08 = gfc_build_library_function_decl (
+ get_identifier (PREFIX("stop_numeric_f08")),
+ void_type_node, 1, gfc_int4_type_node);
+ /* STOP doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric_f08) = 1;
+
gfor_fndecl_stop_string = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("stop_string")), ".R.",
void_type_node, 2, pchar_type_node, gfc_int4_type_node);
gcc_assert (sym->backend_decl);
gcc_assert (sym->ts.u.cl && sym->ts.u.cl->length);
- gfc_start_block (&init);
+ gfc_init_block (&init);
/* Evaluate the string length expression. */
gfc_conv_string_length (sym->ts.u.cl, NULL, &init);
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
- tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
+ tmp = fold_build1_loc (input_location, DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&init, tmp);
gfc_add_init_cleanup (block, gfc_finish_block (&init), NULL_TREE);
|| sym->ns->proc_name->attr.entry_master))
{
present = gfc_conv_expr_present (sym);
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
- tmp, build_empty_stmt (input_location));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt (input_location));
}
gfc_add_expr_to_block (block, tmp);
gfc_free_expr (e);
|| f->sym->ns->proc_name->attr.entry_master)
{
present = gfc_conv_expr_present (f->sym);
- tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
- tmp, build_empty_stmt (input_location));
+ tmp = build3_loc (input_location, COND_EXPR, TREE_TYPE (tmp),
+ present, tmp,
+ build_empty_stmt (input_location));
}
gfc_add_expr_to_block (&init, tmp);
}
-/* Do proper initialization for ASSOCIATE names. */
-
-static void
-trans_associate_var (gfc_symbol* sym, gfc_wrapped_block* block)
-{
- gfc_expr* e;
- tree tmp;
-
- gcc_assert (sym->assoc);
- e = sym->assoc->target;
-
- /* Do a `pointer assignment' with updated descriptor (or assign descriptor
- to array temporary) for arrays with either unknown shape or if associating
- to a variable. */
- if (sym->attr.dimension
- && (sym->as->type == AS_DEFERRED || sym->assoc->variable))
- {
- gfc_se se;
- gfc_ss* ss;
- tree desc;
-
- desc = sym->backend_decl;
-
- /* If association is to an expression, evaluate it and create temporary.
- Otherwise, get descriptor of target for pointer assignment. */
- gfc_init_se (&se, NULL);
- ss = gfc_walk_expr (e);
- if (sym->assoc->variable)
- {
- se.direct_byref = 1;
- se.expr = desc;
- }
- gfc_conv_expr_descriptor (&se, e, ss);
-
- /* If we didn't already do the pointer assignment, set associate-name
- descriptor to the one generated for the temporary. */
- if (!sym->assoc->variable)
- {
- int dim;
-
- gfc_add_modify (&se.pre, desc, se.expr);
-
- /* The generated descriptor has lower bound zero (as array
- temporary), shift bounds so we get lower bounds of 1. */
- for (dim = 0; dim < e->rank; ++dim)
- gfc_conv_shift_descriptor_lbound (&se.pre, desc,
- dim, gfc_index_one_node);
- }
-
- /* Done, register stuff as init / cleanup code. */
- gfc_add_init_cleanup (block, gfc_finish_block (&se.pre),
- gfc_finish_block (&se.post));
- }
-
- /* Do a scalar pointer assignment; this is for scalar variable targets. */
- else if (gfc_is_associate_pointer (sym))
- {
- gfc_se se;
-
- gcc_assert (!sym->attr.dimension);
-
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, e);
-
- tmp = TREE_TYPE (sym->backend_decl);
- tmp = gfc_build_addr_expr (tmp, se.expr);
- gfc_add_modify (&se.pre, sym->backend_decl, tmp);
-
- gfc_add_init_cleanup (block, gfc_finish_block( &se.pre),
- gfc_finish_block (&se.post));
- }
-
- /* Do a simple assignment. This is for scalar expressions, where we
- can simply use expression assignment. */
- else
- {
- gfc_expr* lhs;
-
- lhs = gfc_lval_expr_from_sym (sym);
- tmp = gfc_trans_assignment (lhs, e, false, true);
- gfc_add_init_cleanup (block, tmp, NULL_TREE);
- }
-}
-
-
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
&& sym->ts.u.derived->attr.alloc_comp;
if (sym->assoc)
- trans_associate_var (sym, block);
- else if (sym->attr.dimension)
+ continue;
+
+ if (sym->attr.dimension)
{
switch (sym->as->type)
{
NULL_TREE);
}
- gfc_get_backend_locus (&loc);
+ gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_trans_auto_array_allocation (sym->backend_decl,
sym, block);
- gfc_set_backend_locus (&loc);
+ gfc_restore_backend_locus (&loc);
}
break;
e = gfc_lval_expr_from_sym (sym);
if (sym->ts.type == BT_CLASS)
- gfc_add_component_ref (e, "$data");
+ gfc_add_data_component (e);
gfc_init_se (&se, NULL);
se.want_pointer = 1;
/* Deallocate when leaving the scope. Nullifying is not
needed. */
- tmp = NULL;
if (!sym->attr.result)
- tmp = gfc_deallocate_with_status (se.expr, NULL_TREE,
- true, NULL);
+ tmp = gfc_deallocate_scalar_with_status (se.expr, NULL, true,
+ NULL, sym->ts);
+ else
+ tmp = NULL;
gfc_add_init_cleanup (block, gfc_finish_block (&init), tmp);
}
}
+ else if (sym->ts.deferred)
+ gfc_fatal_error ("Deferred type parameter not yet supported");
else if (sym_has_alloc_comp)
gfc_trans_deferred_array (sym, block);
else if (sym->ts.type == BT_CHARACTER)
{
- gfc_get_backend_locus (&loc);
+ gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
gfc_trans_dummy_character (sym, sym->ts.u.cl, block);
else
gfc_trans_auto_character_variable (sym, block);
- gfc_set_backend_locus (&loc);
+ gfc_restore_backend_locus (&loc);
}
else if (sym->attr.assign)
{
- gfc_get_backend_locus (&loc);
+ gfc_save_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
gfc_trans_assign_aux_var (sym, block);
- gfc_set_backend_locus (&loc);
+ gfc_restore_backend_locus (&loc);
}
else if (sym->ts.type == BT_DERIVED
&& sym->value
if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
{
decl = sym->backend_decl;
- gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
+ gcc_assert (DECL_FILE_SCOPE_P (decl));
gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
gfc_module_add_decl (cur_module, decl);
/* Create the variable. */
pushdecl (decl);
- gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
rest_of_decl_compilation (decl, 1, 0);
}
/* Warn for unused variables, but not if they're inside a common
- block or are use-associated. */
+ block, a namelist, or are use-associated. */
else if (warn_unused_variable
- && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
+ && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark
+ || sym->attr.in_namelist))
gfc_warning ("Unused variable '%s' declared at %L", sym->name,
&sym->declared_at);
/* Build the condition. For optional arguments, an actual length
of 0 is also acceptable if the associated string is NULL, which
means the argument was not passed. */
- cond = fold_build2 (comparison, boolean_type_node,
- cl->passed_length, cl->backend_decl);
+ cond = fold_build2_loc (input_location, comparison, boolean_type_node,
+ cl->passed_length, cl->backend_decl);
if (fsym->attr.optional)
{
tree not_absent;
tree not_0length;
tree absent_failed;
- not_0length = fold_build2 (NE_EXPR, boolean_type_node,
- cl->passed_length,
- fold_convert (gfc_charlen_type_node,
- integer_zero_node));
+ not_0length = fold_build2_loc (input_location, NE_EXPR,
+ boolean_type_node,
+ cl->passed_length,
+ build_zero_cst (gfc_charlen_type_node));
/* The symbol needs to be referenced for gfc_get_symbol_decl. */
fsym->attr.referenced = 1;
not_absent = gfc_conv_expr_present (fsym);
- absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
- not_0length, not_absent);
+ absent_failed = fold_build2_loc (input_location, TRUTH_OR_EXPR,
+ boolean_type_node, not_0length,
+ not_absent);
- cond = fold_build2 (TRUTH_AND_EXPR, boolean_type_node,
- cond, absent_failed);
+ cond = fold_build2_loc (input_location, TRUTH_AND_EXPR,
+ boolean_type_node, cond, absent_failed);
}
/* Build the runtime check. */
TREE_USED (fndecl) = 1;
/* "return 0". */
- tmp = fold_build2 (MODIFY_EXPR, integer_type_node, DECL_RESULT (ftn_main),
- build_int_cst (integer_type_node, 0));
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, integer_type_node,
+ DECL_RESULT (ftn_main),
+ build_int_cst (integer_type_node, 0));
tmp = build1_v (RETURN_EXPR, tmp);
gfc_add_expr_to_block (&body, tmp);
if (result != NULL_TREE)
{
result = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
- result = fold_build2 (MODIFY_EXPR, TREE_TYPE (result),
- DECL_RESULT (fndecl), result);
+ result = fold_build2_loc (input_location, MODIFY_EXPR,
+ TREE_TYPE (result), DECL_RESULT (fndecl),
+ result);
}
}
/* Reset recursion-check variable. */
if ((gfc_option.rtcheck & GFC_RTCHECK_RECURSION)
&& !is_recursive
- && !gfc_option.flag_openmp
+ && !gfc_option.gfc_flag_openmp
&& recurcheckvar != NULL_TREE)
{
gfc_add_modify (&cleanup, recurcheckvar, boolean_false_node);
OSDN Git Service
