/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
+ Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-decl.c -- Handling of backend function and variable decls, etc */
/* Holds the result of the function if no result variable specified. */
static GTY(()) tree current_fake_result_decl;
+static GTY(()) tree parent_fake_result_decl;
static GTY(()) tree current_function_return_label;
/* Function declarations for builtin library functions. */
-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_runtime_error_at;
+tree gfor_fndecl_os_error;
+tree gfor_fndecl_generate_error;
tree gfor_fndecl_set_fpe;
-tree gfor_fndecl_set_std;
+tree gfor_fndecl_set_options;
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;
/* 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_string_scan;
tree gfor_fndecl_string_verify;
tree gfor_fndecl_string_trim;
-tree gfor_fndecl_string_repeat;
+tree gfor_fndecl_string_minmax;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
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];
+ /* Prevent the mangling of identifiers that have an assigned
+ binding label (mainly those that are bind(c)). */
+ if (sym->attr.is_bind_c == 1
+ && sym->binding_label[0] != '\0')
+ return get_identifier(sym->binding_label);
+
if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
{
- snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
+ snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
return get_identifier (name);
}
}
int has_underscore;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ /* It may be possible to simply use the binding label if it's
+ provided, and remove the other checks. Then we could use it
+ for other things if we wished. */
+ if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
+ sym->binding_label[0] != '\0')
+ /* use the binding label rather than the mangled name */
+ return get_identifier (sym->binding_label);
+
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)
}
else
{
- snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
+ snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
return get_identifier (name);
}
}
}
-/* Finish processing of a declaration and install its initial value. */
+/* Finish processing of a declaration without an initial value. */
static void
-gfc_finish_decl (tree decl, tree init)
+gfc_finish_decl (tree decl)
{
- if (TREE_CODE (decl) == PARM_DECL)
- gcc_assert (init == NULL_TREE);
- /* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
- -- it overlaps DECL_ARG_TYPE. */
- 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
- {
- /* typedef foo = bar; store the type of bar as the type of foo. */
- TREE_TYPE (decl) = TREE_TYPE (init);
- DECL_INITIAL (decl) = init = 0;
- }
- }
+ gcc_assert (TREE_CODE (decl) == PARM_DECL
+ || DECL_INITIAL (decl) == NULL_TREE);
- if (TREE_CODE (decl) == VAR_DECL)
- {
- if (DECL_SIZE (decl) == NULL_TREE
- && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
- layout_decl (decl, 0);
-
- /* A static variable with an incomplete type is an error if it is
- initialized. Also if it is not file scope. Otherwise, let it
- through, but if it is not `extern' then it may cause an error
- message later. */
- /* An automatic variable with an incomplete type is an error. */
- 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");
- }
- }
+ if (TREE_CODE (decl) != VAR_DECL)
+ return;
+ if (DECL_SIZE (decl) == NULL_TREE
+ && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
+ layout_decl (decl, 0);
+
+ /* A few consistency checks. */
+ /* A static variable with an incomplete type is an error if it is
+ initialized. Also if it is not file scope. Otherwise, let it
+ through, but if it is not `extern' then it may cause an error
+ message later. */
+ /* An automatic variable with an incomplete type is an error. */
+
+ /* We should know the storage size. */
+ gcc_assert (DECL_SIZE (decl) != NULL_TREE
+ || (TREE_STATIC (decl)
+ ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
+ : DECL_EXTERNAL (decl)));
+
+ /* The storage size should be constant. */
+ gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
+ || !DECL_SIZE (decl)
+ || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
}
static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
+ tree new;
/* TREE_ADDRESSABLE means the address of this variable is actually needed.
This is the equivalent of the TARGET variables.
We also need to set this if the variable is passed by reference in a
if (sym->attr.cray_pointee)
return;
+ if(sym->attr.is_bind_c == 1)
+ {
+ /* We need to put variables that are bind(c) into the common
+ segment of the object file, because this is what C would do.
+ gfortran would typically put them in either the BSS or
+ initialized data segments, and only mark them as common if
+ they were part of common blocks. However, if they are not put
+ into common space, then C cannot initialize global fortran
+ variables that it interoperates with and the draft says that
+ either Fortran or C should be able to initialize it (but not
+ both, of course.) (J3/04-007, section 15.3). */
+ TREE_PUBLIC(decl) = 1;
+ DECL_COMMON(decl) = 1;
+ }
+
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
if ((sym->attr.save || sym->attr.data || sym->value)
&& !sym->attr.use_assoc)
TREE_STATIC (decl) = 1;
-
+
+ if (sym->attr.volatile_)
+ {
+ 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))
- && !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. */
- if (sym->attr.threadprivate && targetm.have_tls
+ if (sym->attr.threadprivate
&& (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
}
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);
+ {
+ GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+ }
/* Don't try to use the unknown bound for assumed shape arrays. */
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);
+ {
+ GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+ }
if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
- GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
+ {
+ GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
+ }
}
if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
{
GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
"offset");
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
+
if (nest)
gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
else
if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
&& sym->as->type != AS_ASSUMED_SIZE)
- GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+ {
+ GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
+ }
if (POINTER_TYPE_P (type))
{
tree type;
gfc_array_spec *as;
char *name;
- int packed;
+ gfc_packed packed;
int n;
bool known_size;
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;
+ packed = PACKED_NO;
if (!gfc_option.flag_repack_arrays)
{
if (as->type == AS_ASSUMED_SIZE)
- packed = 2;
+ packed = PACKED_FULL;
}
else
{
if (as->type == AS_EXPLICIT)
{
- packed = 2;
+ packed = PACKED_FULL;
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;
+ packed = PACKED_PARTIAL;
}
}
else
- packed = 1;
+ packed = PACKED_PARTIAL;
}
type = gfc_typenode_for_spec (&sym->ts);
/* 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;
+ packed = PACKED_FULL;
}
ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
frontend bugs. */
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;
- }
+ if (packed == PACKED_PARTIAL)
+ GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
+ else if (packed == PACKED_FULL)
+ GFC_DECL_PACKED_ARRAY (decl) = 1;
gfc_build_qualified_array (decl, sym);
int byref;
gcc_assert (sym->attr.referenced
- || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
+ || sym->attr.use_assoc
+ || 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);
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)
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;
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
+ {
+ if (isym->formal->next->next->next == NULL)
+ isym->resolve.f3 (&e, &argexpr, NULL, NULL);
+ else
+ {
+ /* All specific intrinsics take less than 5 arguments. */
+ gcc_assert (isym->formal->next->next->next->next == NULL);
+ isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
+ }
+ }
}
if (gfc_option.flag_f2c
{
/* 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;
if (attr.pure || attr.elemental)
{
/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
- including a alternate return. In that case it can also be
+ including an alternate return. In that case it can also be
marked as PURE. See also in gfc_get_extern_function_decl(). */
if (attr.function && !gfc_return_by_reference (sym))
DECL_IS_PURE (fndecl) = 1;
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
+ gfc_finish_decl (parm);
+ DECL_ARTIFICIAL (parm) = 1;
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
+ gfc_finish_decl (length);
if (sym->ts.cl->backend_decl == NULL
|| sym->ts.cl->backend_decl == length)
{
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
TREE_READONLY (parm) = 1;
DECL_ARTIFICIAL (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
+ gfc_finish_decl (parm);
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
DECL_ARTIFICIAL (length) = 1;
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
+ gfc_finish_decl (length);
/* TODO: Check string lengths when -fbounds-check. */
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
- {
- /* there is already another variable using this
- gfc_charlen node, build a new one for this variable
- and chain it into the list of gfc_charlens.
- This happens for e.g. in the case
- CHARACTER(*)::c1,c2
- since CHARACTER declarations on the same line share
- the same gfc_charlen node. */
- 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;
- }
+ gcc_assert (!f->sym->ts.cl->backend_decl);
+ f->sym->ts.cl->backend_decl = length;
}
hidden_typelist = TREE_CHAIN (hidden_typelist);
/* All implementation args are read-only. */
TREE_READONLY (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
+ gfc_finish_decl (parm);
f->sym->backend_decl = parm;
/* 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;
}
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);
}
}
create_function_arglist (ns->proc_name);
}
-/* Return the decl used to hold the function return value. */
+/* Return the decl used to hold the function return value. If
+ parent_flag is set, the context is the parent_scope. */
tree
-gfc_get_fake_result_decl (gfc_symbol * sym)
+gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
{
- tree decl, length;
+ 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 == current_function_decl
+ && 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 (current_fake_result_decl != NULL)
- for (t = TREE_CHAIN (current_fake_result_decl); t; t = TREE_CHAIN (t))
+ 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);
+ 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;
decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
NULL_TREE);
}
- var = gfc_create_var (TREE_TYPE (decl), sym->name);
- GFC_DECL_RESULT (var) = 1;
+
+ 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;
- TREE_CHAIN (current_fake_result_decl)
- = tree_cons (get_identifier (sym->name), var,
- TREE_CHAIN (current_fake_result_decl));
+ 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 (current_fake_result_decl != NULL_TREE)
- return TREE_VALUE (current_fake_result_decl);
+ if (this_fake_result_decl != NULL_TREE)
+ return TREE_VALUE (this_fake_result_decl);
/* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
sym is NULL. */
if (gfc_return_by_reference (sym))
{
- decl = DECL_ARGUMENTS (current_function_decl);
+ decl = DECL_ARGUMENTS (this_function_decl);
- if (sym->ns->proc_name->backend_decl == current_function_decl
+ if (sym->ns->proc_name->backend_decl == this_function_decl
&& sym->ns->proc_name->attr.entry_master)
decl = TREE_CHAIN (decl);
else
{
sprintf (name, "__result_%.20s",
- IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
-
- decl = build_decl (VAR_DECL, get_identifier (name),
- TREE_TYPE (TREE_TYPE (current_function_decl)));
+ 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);
- gfc_add_decl_to_function (decl);
+ if (parent_flag)
+ gfc_add_decl_to_parent_function (decl);
+ else
+ gfc_add_decl_to_function (decl);
}
- current_fake_result_decl = build_tree_list (NULL, 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_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);
/* 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,
- 4,
+ integer_type_node, 4,
gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_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_string_minmax =
+ gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
+ void_type_node, -4,
+ build_pointer_type (gfc_charlen_type_node),
+ ppvoid_type_node, integer_type_node,
+ integer_type_node);
gfor_fndecl_ttynam =
gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
3,
pchar_type_node,
gfc_charlen_type_node,
- gfc_c_int_type_node);
+ integer_type_node);
gfor_fndecl_fdate =
gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
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 (integer_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, integer_type_node,
+ integer_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, integer_type_node,
+ integer_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, integer_type_node,
+ integer_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, integer_type_node,
+ integer_type_node);
+ }
+
/* Other functions. */
gfor_fndecl_size0 =
gfc_build_library_function_decl (get_identifier (PREFIX("size0")),
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);
-
- /* Treat these two internal malloc wrappers as malloc. */
- 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")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int4_type_node);
-
- gfor_fndecl_allocate64 =
- gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int8_type_node);
-
- 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);
-
- 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);
-
- gfor_fndecl_deallocate =
- gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
- void_type_node, 2, ppvoid_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);
-
/* Stop doesn't return. */
TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
gfor_fndecl_select_string =
gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
- pvoid_type_node, 0);
+ integer_type_node, 0);
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;
+ gfor_fndecl_runtime_error_at =
+ gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
+ void_type_node, -2, pchar_type_node,
+ pchar_type_node);
+ /* The runtime_error_at function does not return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
+
+ gfor_fndecl_generate_error =
+ gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
+ void_type_node, 3, pvoid_type_node,
+ integer_type_node, pchar_type_node);
+
+ gfor_fndecl_os_error =
+ gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
+ void_type_node, 1, pchar_type_node);
+ /* The runtime_error function does not return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_os_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);
+ void_type_node, 1, integer_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);
+ /* Keep the array dimension in sync with the call, later in this file. */
+ gfor_fndecl_set_options =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
+ void_type_node, 2, integer_type_node,
+ pvoid_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);
+ void_type_node, 1, integer_type_node);
+
+ gfor_fndecl_set_record_marker =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
+ void_type_node, 1, integer_type_node);
+
+ gfor_fndecl_set_max_subrecord_length =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
+ void_type_node, 1, integer_type_node);
gfor_fndecl_in_pack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_pack")),
gfor_fndecl_associated =
gfc_build_library_function_decl (
get_identifier (PREFIX("associated")),
- gfc_logical4_type_node,
- 2,
- ppvoid_type_node,
+ integer_type_node, 2, ppvoid_type_node,
ppvoid_type_node);
gfc_build_intrinsic_function_decls ();
{
stmtblock_t body;
- gfc_finish_decl (cl->backend_decl, NULL_TREE);
+ gfc_finish_decl (cl->backend_decl);
gfc_start_block (&body);
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. */
{
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)
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:
+ 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_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 (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 an INTENT(OUT) dummy of derived type has a default
+ initializer, it must be initialized here. */
+ if (f->sym && f->sym->attr.intent == INTENT_OUT
+ && f->sym->ts.type == BT_DERIVED
+ && !f->sym->ts.derived->attr.alloc_comp
+ && f->sym->value)
+ {
+ gfc_expr *tmpe;
+ tree tmp, present;
+ gcc_assert (!f->sym->attr.allocatable);
+ gfc_set_sym_referenced (f->sym);
+ tmpe = gfc_lval_expr_from_sym (f->sym);
+ tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
+
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_free_expr (tmpe);
+ }
+ }
if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
&& current_fake_result_decl != NULL)
{
tree decl;
- /* 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);
- }
+ /* Module functions with alternate entries are dealt with later and
+ would get caught by the next condition. */
+ if (sym->attr.entry)
+ return;
+
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
/* Only output variables and array valued parameters. */
if (sym->attr.flavor != FL_VARIABLE
}
+/* 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);
+ /* INTENT(out) dummy arguments are likely meant to be set. */
+ else if (warn_unused_variable
+ && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT)
+ gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
+ sym->name, &sym->declared_at);
+ /* Specific warning for unused dummy arguments. */
+ else if (warn_unused_variable && sym->attr.dummy)
+ gfc_warning ("Unused dummy argument '%s' 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
sym->attr.referenced = 1;
gfc_get_symbol_decl (sym);
}
+
+ /* We do not want the middle-end to warn about unused parameters
+ as this was already done above. */
+ if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
+ TREE_NO_WARNING(sym->backend_decl) = 1;
+ }
+ else if (sym->attr.flavor == FL_PARAMETER)
+ {
+ if (warn_unused_parameter
+ && !sym->attr.referenced
+ && !sym->attr.use_assoc)
+ gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
+ &sym->declared_at);
+ }
+
+ if (sym->attr.dummy == 1)
+ {
+ /* Modify the tree type for scalar character dummy arguments of bind(c)
+ procedures if they are passed by value. The tree type for them will
+ be promoted to INTEGER_TYPE for the middle end, which appears to be
+ what C would do with characters passed by-value. The value attribute
+ implies the dummy is a scalar. */
+ if (sym->attr.value == 1 && sym->backend_decl != NULL
+ && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
+ && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
+ gfc_conv_scalar_char_value (sym, NULL, NULL);
}
+
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
}
static void
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;
/* Translate COMMON blocks. */
gfc_trans_common (ns);
+ /* Null the parent fake result declaration if this namespace is
+ a module function or an external procedures. */
+ 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);
- /* Will be created as needed. */
- current_fake_result_decl = NULL_TREE;
+ /* Keep the parent fake result declaration in module functions
+ or external procedures. */
+ 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;
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
- /* If this is the main program, add a call to set_std to set up the
+ /* If this is the main program, add a call to set_options to set up the
runtime library Fortran language standard parameters. */
-
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);
+ tree array_type, array, var;
+
+ /* Passing a new option to the library requires four modifications:
+ + add it to the tree_cons list below
+ + change the array size in the call to build_array_type
+ + change the first argument to the library call
+ gfor_fndecl_set_options
+ + modify the library (runtime/compile_options.c)! */
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.warn_std), NULL_TREE);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.allow_std), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node, pedantic), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.flag_dump_core), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.flag_backtrace), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.flag_sign_zero), array);
+
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ flag_bounds_check), array);
+
+ array_type = build_array_type (integer_type_node,
+ build_index_type (build_int_cst (NULL_TREE,
+ 6)));
+ array = build_constructor_from_list (array_type, nreverse (array));
+ TREE_CONSTANT (array) = 1;
+ TREE_INVARIANT (array) = 1;
+ TREE_STATIC (array) = 1;
+
+ /* Create a static variable to hold the jump table. */
+ var = gfc_create_var (array_type, "options");
+ TREE_CONSTANT (var) = 1;
+ TREE_INVARIANT (var) = 1;
+ TREE_STATIC (var) = 1;
+ TREE_READONLY (var) = 1;
+ DECL_INITIAL (var) = array;
+ var = gfc_build_addr_expr (pvoid_type_node, var);
+
+ tmp = build_call_expr (gfor_fndecl_set_options, 2,
+ build_int_cst (integer_type_node, 7), var);
gfc_add_expr_to_block (&body, tmp);
}
needed. */
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);
+ tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
+ build_int_cst (integer_type_node,
+ gfc_option.fpe));
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;
+ tmp = build_call_expr (gfor_fndecl_set_convert, 1,
+ build_int_cst (integer_type_node,
+ gfc_option.convert));
+ gfc_add_expr_to_block (&body, tmp);
+ }
- 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);
+ /* 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)
+ {
+ tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
+ build_int_cst (integer_type_node,
+ gfc_option.record_marker));
gfc_add_expr_to_block (&body, tmp);
}
+ if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
+ {
+ tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
+ 1,
+ build_int_cst (integer_type_node,
+ gfc_option.max_subrecord_length));
+ 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);
+ alternate_return = gfc_get_fake_result_decl (sym, 0);
gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
}
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
+ && !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
{
- /* 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);
}
}
+ else
+ gfc_add_expr_to_block (&block, tmp);
+
/* Add all the decls we created during processing. */
decl = saved_function_decls;
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));
for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
{
- tmp =
- build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
+ tmp = build_call_expr (TREE_VALUE (gfc_static_ctors), 0);
DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
}