tree gfor_fndecl_set_fpe;
tree gfor_fndecl_set_std;
tree gfor_fndecl_set_convert;
+tree gfor_fndecl_set_record_marker;
tree gfor_fndecl_ctime;
tree gfor_fndecl_fdate;
tree gfor_fndecl_ttynam;
/* String functions. */
-tree gfor_fndecl_copy_string;
tree gfor_fndecl_compare_string;
tree gfor_fndecl_concat_string;
tree gfor_fndecl_string_len_trim;
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)
/* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
- && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
+ && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
+ /* Put variable length auto array pointers always into stack. */
+ && (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;
/* Handle threadprivate variables. */
type = TREE_TYPE (type);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
- /* Create a decriptorless array pointer. */
+ /* Create a descriptorless array pointer. */
as = sym->as;
packed = 0;
if (!gfc_option.flag_repack_arrays)
/* We now have an expression for the element size, so create a fully
qualified type. Reset sym->backend decl or this will just return the
old type. */
+ DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = NULL_TREE;
type = gfc_sym_type (sym);
packed = 2;
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
{
- gfc_add_decl_to_function (length);
+ /* Add the string length to the same context as the symbol. */
+ 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);
}
}
/* Use a copy of the descriptor for dummy arrays. */
if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
{
- sym->backend_decl =
- gfc_build_dummy_array_decl (sym, sym->backend_decl);
+ decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
+ /* Prevent the dummy from being detected as unused if it is copied. */
+ 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;
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)
isym->resolve.f1 (&e, &argexpr);
else
{
- /* All specific intrinsics take one or two arguments. */
- gcc_assert (isym->formal->next->next == NULL);
- isym->resolve.f2 (&e, &argexpr, NULL);
+ if (isym->formal->next->next == NULL)
+ isym->resolve.f2 (&e, &argexpr, NULL);
+ else
+ {
+ /* All specific intrinsics take less than 4 arguments. */
+ gcc_assert (isym->formal->next->next->next == NULL);
+ isym->resolve.f3 (&e, &argexpr, NULL, NULL);
+ }
}
if (gfc_option.flag_f2c
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 (thunk_formal)
{
/* Pass the argument. */
+ 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)
args = tree_cons (NULL_TREE, null_pointer_node, args);
if (formal->sym->ts.type == BT_CHARACTER)
{
- tmp = convert (gfc_charlen_type_node, integer_zero_node);
+ tmp = build_int_cst (gfc_charlen_type_node, 0);
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
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_PUBLIC (decl) = 0;
TREE_USED (decl) = 1;
GFC_DECL_RESULT (decl) = 1;
+ TREE_ADDRESSABLE (decl) = 1;
layout_decl (decl, 0);
tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
/* String functions. */
- gfor_fndecl_copy_string =
- gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
- void_type_node,
- 4,
- gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node);
-
gfor_fndecl_compare_string =
gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
gfc_int4_type_node,
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_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
- void_type_node,
- 3,
- pchar_type_node, pchar_type_node,
- gfc_int4_type_node);
+ void_type_node, 1, pchar_type_node);
/* The runtime_error function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
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_in_pack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_pack")),
pvoid_type_node, 1, pvoid_type_node);
{
tree result = TREE_VALUE (current_fake_result_decl);
fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
+
+ /* An automatic character length, pointer array result. */
+ 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)
{
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)
break;
case AS_DEFERRED:
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ if (!sym_has_alloc_comp)
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
+ if (sym_has_alloc_comp)
+ 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);
{
tree decl;
+ /* Module functions with alternate entries are dealt with later and
+ would get caught by the next condition. */
+ if (sym->attr.entry)
+ return;
+
/* Only output symbols from this module. */
if (sym->ns != module_namespace)
{
}
+/* Drill down through expressions for the array specification bounds and
+ character length calling generate_local_decl for all those variables
+ that have not already been declared. */
+
+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;
+
+ /* If the variable is not the same as the dependent, 'sym', and
+ it is not marked as being declared and it is in the same
+ namespace as 'sym', add it to the local declarations. */
+ 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;
+ }
+ }
+ }
+}
+
+
+/* Check for dependencies in the character length and array spec. */
+
+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]);
+ }
+ }
+}
+
+
/* Generate decls for all local variables. We do this to ensure correct
handling of expressions which only appear in the specification of
other functions. */
{
if (sym->attr.flavor == FL_VARIABLE)
{
+ /* Check for dependencies in the array specification and string
+ length, adding the necessary declarations to the function. We
+ mark the symbol now, as well as in traverse_ns, to prevent
+ getting stuck in a circular dependency. */
+ 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)
- warning (0, "unused parameter %qs", sym->name);
+ gfc_warning ("Unused parameter %s declared at %L", sym->name,
+ &sym->declared_at);
/* Warn for unused variables, but not if they're inside a common
block or are use-associated. */
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->attr.use_assoc))
- warning (0, "unused variable %qs", sym->name);
+ gfc_warning ("Unused variable %s declared at %L", sym->name,
+ &sym->declared_at);
/* For variable length CHARACTER parameters, the PARM_DECL already
references the length variable, so force gfc_get_symbol_decl
even when not referenced. If optimize > 0, it will be optimized
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;
gfc_add_expr_to_block (&body, tmp);
}
+ /* If this is the main program and an -frecord-marker option was provided,
+ add a call to set_record_marker. */
+
+ 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 (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
&& sym->attr.subroutine)
tmp = gfc_finish_block (&body);
/* Add code to create and cleanup arrays. */
tmp = gfc_trans_deferred_vars (sym, tmp);
- gfc_add_expr_to_block (&block, tmp);
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
else
result = sym->result->backend_decl;
- if (result == NULL_TREE)
+ if (result != NULL_TREE && sym->attr.function
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.alloc_comp)
+ {
+ 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
{
gfc_add_expr_to_block (&block, tmp);
}
}
+ else
+ gfc_add_expr_to_block (&block, tmp);
+
/* Add all the decls we created during processing. */
decl = saved_function_decls;
OSDN Git Service
