/* 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;
{
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;
}
+static void build_function_decl (gfc_symbol * sym, bool global);
+
+
/* Return the decl for a gfc_symbol, create it if it doesn't already
exist. */
tree length = NULL_TREE;
tree attributes;
int byref;
+ bool intrinsic_array_parameter = false;
gcc_assert (sym->attr.referenced
|| sym->attr.use_assoc
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;
}
}
- /* Catch function declarations. Only used for actual parameters and
- procedure pointers. */
if (sym->attr.flavor == FL_PROCEDURE)
{
- decl = gfc_get_extern_function_decl (sym);
- gfc_set_decl_location (decl, &sym->declared_at);
+ /* Catch function declarations. Only used for actual parameters,
+ procedure pointers and procptr initialization targets. */
+ if (sym->attr.external || sym->attr.use_assoc || sym->attr.intrinsic)
+ {
+ decl = gfc_get_extern_function_decl (sym);
+ gfc_set_decl_location (decl, &sym->declared_at);
+ }
+ else
+ {
+ if (!sym->backend_decl)
+ build_function_decl (sym, false);
+ decl = sym->backend_decl;
+ }
return decl;
}
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;
}
&& !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))
every time the procedure is entered. The TREE_STATIC is
in this case due to -fmax-stack-var-size=. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl), sym->attr.dimension,
- sym->attr.pointer || sym->attr.allocatable);
+ TREE_TYPE (decl),
+ sym->attr.dimension,
+ sym->attr.pointer
+ || sym->attr.allocatable,
+ sym->attr.proc_pointer);
}
if (!TREE_STATIC (decl)
{
/* Add static initializer. */
DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
- TREE_TYPE (decl),
- sym->attr.proc_pointer ? false : sym->attr.dimension,
- sym->attr.proc_pointer);
+ TREE_TYPE (decl),
+ sym->attr.dimension,
+ false, true);
}
attributes = add_attributes_to_decl (sym->attr, NULL_TREE);
tree result_decl;
gfc_formal_arglist *f;
- gcc_assert (!sym->backend_decl);
gcc_assert (!sym->attr.external);
+ if (sym->backend_decl)
+ return;
+
/* Set the line and filename. sym->declared_at seems to point to the
last statement for subroutines, but it'll do for now. */
gfc_set_backend_locus (&sym->declared_at);
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);
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);
if (nargs >= 0)
{
/* Terminate the list. */
- arglist = gfc_chainon_list (arglist, void_type_node);
+ arglist = chainon (arglist, void_list_node);
}
/* Build the function type and decl. */
integer_type_node, 4, gfc_charlen_type_node, pchar1_type_node,
gfc_charlen_type_node, pchar1_type_node);
DECL_PURE_P (gfor_fndecl_compare_string) = 1;
+ TREE_NOTHROW (gfor_fndecl_compare_string) = 1;
gfor_fndecl_concat_string = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("concat_string")), "..W.R.R",
void_type_node, 6, gfc_charlen_type_node, pchar1_type_node,
gfc_charlen_type_node, pchar1_type_node,
gfc_charlen_type_node, pchar1_type_node);
+ TREE_NOTHROW (gfor_fndecl_concat_string) = 1;
gfor_fndecl_string_len_trim = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_len_trim")), "..R",
gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar1_type_node);
DECL_PURE_P (gfor_fndecl_string_len_trim) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_len_trim) = 1;
gfor_fndecl_string_index = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_index")), "..R.R.",
gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
DECL_PURE_P (gfor_fndecl_string_index) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_index) = 1;
gfor_fndecl_string_scan = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_scan")), "..R.R.",
gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
DECL_PURE_P (gfor_fndecl_string_scan) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_scan) = 1;
gfor_fndecl_string_verify = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_verify")), "..R.R.",
gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar1_type_node,
gfc_charlen_type_node, pchar1_type_node, gfc_logical4_type_node);
DECL_PURE_P (gfor_fndecl_string_verify) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_verify) = 1;
gfor_fndecl_string_trim = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_trim")), ".Ww.R",
get_identifier (PREFIX("adjustl")), ".W.R",
void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
pchar1_type_node);
+ TREE_NOTHROW (gfor_fndecl_adjustl) = 1;
gfor_fndecl_adjustr = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("adjustr")), ".W.R",
void_type_node, 3, pchar1_type_node, gfc_charlen_type_node,
pchar1_type_node);
+ TREE_NOTHROW (gfor_fndecl_adjustr) = 1;
gfor_fndecl_select_string = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("select_string")), ".R.R.",
integer_type_node, 4, pvoid_type_node, integer_type_node,
pchar1_type_node, gfc_charlen_type_node);
DECL_PURE_P (gfor_fndecl_select_string) = 1;
+ TREE_NOTHROW (gfor_fndecl_select_string) = 1;
gfor_fndecl_compare_string_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("compare_string_char4")), "..R.R",
integer_type_node, 4, gfc_charlen_type_node, pchar4_type_node,
gfc_charlen_type_node, pchar4_type_node);
DECL_PURE_P (gfor_fndecl_compare_string_char4) = 1;
+ TREE_NOTHROW (gfor_fndecl_compare_string_char4) = 1;
gfor_fndecl_concat_string_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("concat_string_char4")), "..W.R.R",
void_type_node, 6, gfc_charlen_type_node, pchar4_type_node,
gfc_charlen_type_node, pchar4_type_node, gfc_charlen_type_node,
pchar4_type_node);
+ TREE_NOTHROW (gfor_fndecl_concat_string_char4) = 1;
gfor_fndecl_string_len_trim_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_len_trim_char4")), "..R",
gfc_charlen_type_node, 2, gfc_charlen_type_node, pchar4_type_node);
DECL_PURE_P (gfor_fndecl_string_len_trim_char4) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_len_trim_char4) = 1;
gfor_fndecl_string_index_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_index_char4")), "..R.R.",
gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
DECL_PURE_P (gfor_fndecl_string_index_char4) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_index_char4) = 1;
gfor_fndecl_string_scan_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_scan_char4")), "..R.R.",
gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
DECL_PURE_P (gfor_fndecl_string_scan_char4) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_scan_char4) = 1;
gfor_fndecl_string_verify_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_verify_char4")), "..R.R.",
gfc_charlen_type_node, 5, gfc_charlen_type_node, pchar4_type_node,
gfc_charlen_type_node, pchar4_type_node, gfc_logical4_type_node);
DECL_PURE_P (gfor_fndecl_string_verify_char4) = 1;
+ TREE_NOTHROW (gfor_fndecl_string_verify_char4) = 1;
gfor_fndecl_string_trim_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("string_trim_char4")), ".Ww.R",
get_identifier (PREFIX("adjustl_char4")), ".W.R",
void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
pchar4_type_node);
+ TREE_NOTHROW (gfor_fndecl_adjustl_char4) = 1;
gfor_fndecl_adjustr_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("adjustr_char4")), ".W.R",
void_type_node, 3, pchar4_type_node, gfc_charlen_type_node,
pchar4_type_node);
+ TREE_NOTHROW (gfor_fndecl_adjustr_char4) = 1;
gfor_fndecl_select_string_char4 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("select_string_char4")), ".R.R.",
integer_type_node, 4, pvoid_type_node, integer_type_node,
pvoid_type_node, gfc_charlen_type_node);
DECL_PURE_P (gfor_fndecl_select_string_char4) = 1;
+ TREE_NOTHROW (gfor_fndecl_select_string_char4) = 1;
/* Conversion between character kinds. */
get_identifier (PREFIX("selected_char_kind")), "..R",
gfc_int4_type_node, 2, gfc_charlen_type_node, pchar_type_node);
DECL_PURE_P (gfor_fndecl_sc_kind) = 1;
+ TREE_NOTHROW (gfor_fndecl_sc_kind) = 1;
gfor_fndecl_si_kind = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("selected_int_kind")), ".R",
gfc_int4_type_node, 1, pvoid_type_node);
DECL_PURE_P (gfor_fndecl_si_kind) = 1;
+ TREE_NOTHROW (gfor_fndecl_si_kind) = 1;
gfor_fndecl_sr_kind = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("selected_real_kind2008")), ".RR",
gfc_int4_type_node, 3, pvoid_type_node, pvoid_type_node,
pvoid_type_node);
DECL_PURE_P (gfor_fndecl_sr_kind) = 1;
+ TREE_NOTHROW (gfor_fndecl_sr_kind) = 1;
/* Power functions. */
{
gfc_build_library_function_decl (get_identifier (name),
jtype, 2, jtype, itype);
TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
+ TREE_NOTHROW (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
}
}
gfc_build_library_function_decl (get_identifier (name),
rtype, 2, rtype, itype);
TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
+ TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
}
ctype = gfc_get_complex_type (rkinds[rkind]);
gfc_build_library_function_decl (get_identifier (name),
ctype, 2,ctype, itype);
TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
+ TREE_NOTHROW (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
}
}
}
get_identifier (PREFIX("ishftc4")),
gfc_int4_type_node, 3, gfc_int4_type_node, gfc_int4_type_node,
gfc_int4_type_node);
+ TREE_READONLY (gfor_fndecl_math_ishftc4) = 1;
+ TREE_NOTHROW (gfor_fndecl_math_ishftc4) = 1;
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);
+ TREE_READONLY (gfor_fndecl_math_ishftc8) = 1;
+ TREE_NOTHROW (gfor_fndecl_math_ishftc8) = 1;
if (gfc_int16_type_node)
- gfor_fndecl_math_ishftc16 = gfc_build_library_function_decl (
+ {
+ 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);
+ TREE_READONLY (gfor_fndecl_math_ishftc16) = 1;
+ TREE_NOTHROW (gfor_fndecl_math_ishftc16) = 1;
+ }
/* BLAS functions. */
{
get_identifier (PREFIX("size0")), ".R",
gfc_array_index_type, 1, pvoid_type_node);
DECL_PURE_P (gfor_fndecl_size0) = 1;
+ TREE_NOTHROW (gfor_fndecl_size0) = 1;
gfor_fndecl_size1 = gfc_build_library_function_decl_with_spec (
get_identifier (PREFIX("size1")), ".R",
gfc_array_index_type, 2, pvoid_type_node, gfc_array_index_type);
DECL_PURE_P (gfor_fndecl_size1) = 1;
+ TREE_NOTHROW (gfor_fndecl_size1) = 1;
gfor_fndecl_iargc = gfc_build_library_function_decl (
get_identifier (PREFIX ("iargc")), gfc_int4_type_node, 0);
-
- 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;
-
- 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_iargc) = 1;
}
get_identifier (PREFIX("associated")), ".RR",
integer_type_node, 2, ppvoid_type_node, ppvoid_type_node);
DECL_PURE_P (gfor_fndecl_associated) = 1;
+ TREE_NOTHROW (gfor_fndecl_associated) = 1;
gfc_build_intrinsic_function_decls ();
gfc_build_intrinsic_lib_fndecls ();
/* 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.
Allocation of character string variables.
Initialization and possibly repacking of dummy arrays.
Initialization of ASSIGN statement auxiliary variable.
+ Initialization of ASSOCIATE names.
Automatic deallocation. */
void
{
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
&& sym->ts.u.derived->attr.alloc_comp;
- if (sym->attr.dimension)
+ if (sym->assoc)
+ trans_associate_var (sym, block);
+ else if (sym->attr.dimension)
{
switch (sym->as->type)
{
&& (sym->equiv_built || sym->attr.in_equivalence))
return;
- if (sym->backend_decl && !sym->attr.vtab)
+ if (sym->backend_decl && !sym->attr.vtab && !sym->attr.target)
internal_error ("backend decl for module variable %s already exists",
sym->name);
TREE_USED (decl) = 1;
if (DECL_CONTEXT (decl) && TREE_CODE (DECL_CONTEXT (decl)) == NAMESPACE_DECL)
TREE_PUBLIC (decl) = 1;
- DECL_INITIAL (decl)
- = gfc_conv_initializer (sym->value, &sym->ts, TREE_TYPE (decl),
- sym->attr.dimension, 0);
+ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+ TREE_TYPE (decl),
+ sym->attr.dimension,
+ false, false);
debug_hooks->global_decl (decl);
}
/* 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,
+ fold_convert (gfc_charlen_type_node,
+ integer_zero_node));
/* The symbol needs to be referenced for gfc_get_symbol_decl. */
fsym->attr.referenced = 1;
not_absent = gfc_conv_expr_present (fsym);
- absent_failed = fold_build2 (TRUTH_OR_EXPR, boolean_type_node,
- not_0length, not_absent);
+ 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);
}
}
/* Process the local variables of a BLOCK construct. */
void
-gfc_process_block_locals (gfc_namespace* ns)
+gfc_process_block_locals (gfc_namespace* ns, gfc_association_list* assoc)
{
tree decl;
gcc_assert (saved_local_decls == NULL_TREE);
generate_local_vars (ns);
+ /* Mark associate names to be initialized. The symbol's namespace may not
+ be the BLOCK's, we have to force this so that the deferring
+ works as expected. */
+ for (; assoc; assoc = assoc->next)
+ {
+ assoc->st->n.sym->ns = ns;
+ gfc_defer_symbol_init (assoc->st->n.sym);
+ }
+
decl = saved_local_decls;
while (decl)
{
OSDN Git Service
