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_si_kind;
tree gfor_fndecl_sr_kind;
+/* BLAS gemm functions. */
+tree gfor_fndecl_sgemm;
+tree gfor_fndecl_dgemm;
+tree gfor_fndecl_cgemm;
+tree gfor_fndecl_zgemm;
+
static void
gfc_add_decl_to_parent_function (tree decl)
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
- || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
+ || (sym->module != NULL && (sym->attr.external
+ || sym->attr.if_source == IFSRC_IFBODY)))
{
if (strcmp (sym->name, "MAIN__") == 0
|| sym->attr.proc == PROC_INTRINSIC)
if ((sym->attr.save || sym->attr.data || sym->value)
&& !sym->attr.use_assoc)
TREE_STATIC (decl) = 1;
-
+
+ if (sym->attr.volatile_)
+ {
+ tree new;
+ TREE_THIS_VOLATILE (decl) = 1;
+ new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
+ TREE_TYPE (decl) = new;
+ }
+
/* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
sym->backend_decl = decl;
if (sym->attr.assign)
- {
- gfc_add_assign_aux_vars (sym);
- }
+ gfc_add_assign_aux_vars (sym);
if (TREE_STATIC (decl) && !sym->attr.use_assoc)
{
gfc_expr e;
gfc_intrinsic_sym *isym;
gfc_expr argexpr;
- char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
+ char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
tree name;
tree mangled_name;
{
/* Specific which needs a different implementation if f2c
calling conventions are used. */
- sprintf (s, "f2c_specific%s", e.value.function.name);
+ sprintf (s, "_gfortran_f2c_specific%s", e.value.function.name);
}
else
- sprintf (s, "specific%s", e.value.function.name);
+ sprintf (s, "_gfortran_specific%s", e.value.function.name);
name = get_identifier (s);
mangled_name = name;
/* Add the hidden string length parameters. */
arglist = chainon (arglist, hidden_arglist);
- gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
+ gcc_assert (hidden_typelist == NULL_TREE
+ || TREE_VALUE (hidden_typelist) == void_type_node);
DECL_ARGUMENTS (fndecl) = arglist;
}
}
/* Return the decl used to hold the function return value. If
- parent_flag is set, the context is the parent_scope*/
+ parent_flag is set, the context is the parent_scope. */
tree
gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
sprintf (name, "__result_%.20s",
IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
- decl = build_decl (VAR_DECL, get_identifier (name),
- TREE_TYPE (TREE_TYPE (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;
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_si_kind =
- gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("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_build_library_function_decl (get_identifier
+ (PREFIX("selected_real_kind")),
gfc_int4_type_node,
2, pvoid_type_node,
pvoid_type_node);
gfor_fndecl_math_powi[jkind][ikind].integer =
gfc_build_library_function_decl (get_identifier (name),
jtype, 2, jtype, itype);
+ TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
}
}
gfor_fndecl_math_powi[rkind][ikind].real =
gfc_build_library_function_decl (get_identifier (name),
rtype, 2, rtype, itype);
+ TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
}
ctype = gfc_get_complex_type (rkinds[rkind]);
gfor_fndecl_math_powi[rkind][ikind].cmplx =
gfc_build_library_function_decl (get_identifier (name),
ctype, 2,ctype, itype);
+ TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
}
}
}
gfc_int4_type_node, 1,
gfc_real16_type_node);
+ /* BLAS functions. */
+ {
+ tree pint = build_pointer_type (gfc_c_int_type_node);
+ tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
+ tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
+ tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
+ tree pz = build_pointer_type
+ (gfc_get_complex_type (gfc_default_double_kind));
+
+ gfor_fndecl_sgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "sgemm_"
+ : "sgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, ps, ps, pint,
+ ps, pint, ps, ps, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ gfor_fndecl_dgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "dgemm_"
+ : "dgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, pd, pd, pint,
+ pd, pint, pd, pd, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ gfor_fndecl_cgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "cgemm_"
+ : "cgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, pc, pc, pint,
+ pc, pint, pc, pc, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ gfor_fndecl_zgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "zgemm_"
+ : "zgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, pz, pz, pint,
+ pz, pint, pz, pz, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ }
+
/* Other functions. */
gfor_fndecl_size0 =
gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
gfor_fndecl_allocate =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int4_type_node);
+ 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")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int8_type_node);
+ 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")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int4_type_node);
+ 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")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int8_type_node);
+ 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, ppvoid_type_node,
+ void_type_node, 2, pvoid_type_node,
gfc_pint4_type_node);
gfor_fndecl_stop_numeric =
gfor_fndecl_set_std =
gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
void_type_node,
- 3,
+ 4,
+ gfc_int4_type_node,
gfc_int4_type_node,
gfc_int4_type_node,
gfc_int4_type_node);
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);
gfc_symbol *sym;
gfc_formal_arglist *f;
stmtblock_t body;
+ bool seen_trans_deferred_array = false;
/* Deal with implicit return variables. Explicit return variables will
already have been added. */
if (TREE_STATIC (sym->backend_decl))
gfc_trans_static_array_pointer (sym);
else
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ {
+ 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,
break;
case AS_DEFERRED:
- if (!sym_has_alloc_comp)
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ seen_trans_deferred_array = true;
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
- if (sym_has_alloc_comp)
+ if (sym_has_alloc_comp && !seen_trans_deferred_array)
fnbody = gfc_trans_deferred_array (sym, fnbody);
}
else if (sym_has_alloc_comp)
if (sym->attr.entry)
return;
- /* Only output symbols from this module. */
- if (sym->ns != module_namespace)
- {
- /* I don't think this should ever happen. */
- internal_error ("module symbol %s in wrong namespace", sym->name);
- }
-
/* Only output variables and array valued parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
arglist = gfc_chainon_list (arglist,
build_int_cst (gfc_int4_type_node,
pedantic));
+ arglist = gfc_chainon_list (arglist,
+ build_int_cst (gfc_int4_type_node,
+ gfc_option.flag_dump_core));
+
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.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)
{
warning (0, "Function return value not set");
else
{
- /* Set the return value to the dummy result variable. */
- tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
- DECL_RESULT (fndecl), result);
+ /* Set the return value to the dummy result variable. The
+ types may be different for scalar default REAL functions
+ with -ff2c, therefore we have to convert. */
+ 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);
}
if (gfc_static_ctors == NULL_TREE)
return;
- fnname = get_file_function_name ('I');
+ fnname = get_file_function_name ("I");
type = build_function_type (void_type_node,
gfc_chainon_list (NULL_TREE, void_type_node));
OSDN Git Service
