/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software
Foundation, Inc.
Contributed by Paul Brook
#include "coretypes.h"
#include "tree.h"
#include "tree-dump.h"
-#include "tree-gimple.h"
+#include "gimple.h"
#include "ggc.h"
#include "toplev.h"
#include "tm.h"
#include "function.h"
#include "flags.h"
#include "cgraph.h"
+#include "debug.h"
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
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_runtime_warning_at;
tree gfor_fndecl_os_error;
tree gfor_fndecl_generate_error;
tree gfor_fndecl_set_fpe;
trans-intrinsic.c. */
gfc_powdecl_list gfor_fndecl_math_powi[4][3];
-tree gfor_fndecl_math_cpowf;
-tree gfor_fndecl_math_cpow;
-tree gfor_fndecl_math_cpowl10;
-tree gfor_fndecl_math_cpowl16;
tree gfor_fndecl_math_ishftc4;
tree gfor_fndecl_math_ishftc8;
tree gfor_fndecl_math_ishftc16;
-tree gfor_fndecl_math_exponent4;
-tree gfor_fndecl_math_exponent8;
-tree gfor_fndecl_math_exponent10;
-tree gfor_fndecl_math_exponent16;
/* String functions. */
tree gfor_fndecl_string_minmax;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
+tree gfor_fndecl_select_string;
+tree gfor_fndecl_compare_string_char4;
+tree gfor_fndecl_concat_string_char4;
+tree gfor_fndecl_string_len_trim_char4;
+tree gfor_fndecl_string_index_char4;
+tree gfor_fndecl_string_scan_char4;
+tree gfor_fndecl_string_verify_char4;
+tree gfor_fndecl_string_trim_char4;
+tree gfor_fndecl_string_minmax_char4;
+tree gfor_fndecl_adjustl_char4;
+tree gfor_fndecl_adjustr_char4;
+tree gfor_fndecl_select_string_char4;
+
+
+/* Conversion between character kinds. */
+tree gfor_fndecl_convert_char1_to_char4;
+tree gfor_fndecl_convert_char4_to_char1;
/* Other misc. runtime library functions. */
tree gfor_fndecl_size1;
tree gfor_fndecl_iargc;
-/* Intrinsic functions implemented in FORTRAN. */
+/* Intrinsic functions implemented in Fortran. */
+tree gfor_fndecl_sc_kind;
tree gfor_fndecl_si_kind;
tree gfor_fndecl_sr_kind;
void
gfc_set_decl_location (tree decl, locus * loc)
{
-#ifdef USE_MAPPED_LOCATION
DECL_SOURCE_LOCATION (decl) = loc->lb->location;
-#else
- DECL_SOURCE_LINE (decl) = loc->lb->linenum;
- DECL_SOURCE_FILE (decl) = loc->lb->file->filename;
-#endif
}
static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
- tree new;
+ tree new_type;
/* 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
TREE_STATIC (decl) = 1;
}
- if ((sym->attr.save || sym->attr.data || sym->value)
- && !sym->attr.use_assoc)
+ /* Derived types are a bit peculiar because of the possibility of
+ a default initializer; this must be applied each time the variable
+ comes into scope it therefore need not be static. These variables
+ are SAVE_NONE but have an initializer. Otherwise explicitly
+ initialized variables are SAVE_IMPLICIT and explicitly saved are
+ SAVE_EXPLICIT. */
+ if (!sym->attr.use_assoc
+ && (sym->attr.save != SAVE_NONE || sym->attr.data
+ || (sym->value && sym->ns->proc_name->attr.is_main_program)))
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;
+ new_type = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
+ TREE_TYPE (decl) = new_type;
}
/* Keep variables larger than max-stack-var-size off stack. */
{
tree size, range;
- size = build2 (MINUS_EXPR, gfc_array_index_type,
- GFC_TYPE_ARRAY_SIZE (type), gfc_index_one_node);
+ size = fold_build2 (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;
layout_type (type);
}
+
+ if (nest || write_symbols == NO_DEBUG)
+ return;
+
+ if (TYPE_NAME (type) != NULL_TREE
+ && GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1) != NULL_TREE
+ && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, sym->as->rank - 1)) == VAR_DECL)
+ {
+ tree gtype = DECL_ORIGINAL_TYPE (TYPE_NAME (type));
+
+ for (dim = 0; dim < sym->as->rank - 1; dim++)
+ {
+ gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
+ gtype = TREE_TYPE (gtype);
+ }
+ gcc_assert (TREE_CODE (gtype) == ARRAY_TYPE);
+ if (TYPE_MAX_VALUE (TYPE_DOMAIN (gtype)) == NULL)
+ TYPE_NAME (type) = NULL_TREE;
+ }
+
+ if (TYPE_NAME (type) == NULL_TREE)
+ {
+ tree gtype = TREE_TYPE (type), rtype, type_decl;
+
+ for (dim = sym->as->rank - 1; dim >= 0; dim--)
+ {
+ rtype = build_range_type (gfc_array_index_type,
+ GFC_TYPE_ARRAY_LBOUND (type, dim),
+ GFC_TYPE_ARRAY_UBOUND (type, dim));
+ gtype = build_array_type (gtype, rtype);
+ /* Ensure the bound variables aren't optimized out at -O0. */
+ if (!optimize)
+ {
+ if (GFC_TYPE_ARRAY_LBOUND (type, dim)
+ && TREE_CODE (GFC_TYPE_ARRAY_LBOUND (type, dim)) == VAR_DECL)
+ DECL_IGNORED_P (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 0;
+ if (GFC_TYPE_ARRAY_UBOUND (type, dim)
+ && TREE_CODE (GFC_TYPE_ARRAY_UBOUND (type, dim)) == VAR_DECL)
+ DECL_IGNORED_P (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 0;
+ }
+ }
+ TYPE_NAME (type) = type_decl = build_decl (TYPE_DECL, NULL, gtype);
+ DECL_ORIGINAL_TYPE (type_decl) = gtype;
+ }
}
/* Create a descriptorless array pointer. */
as = sym->as;
packed = PACKED_NO;
- if (!gfc_option.flag_repack_arrays)
+
+ /* Even when -frepack-arrays is used, symbols with TARGET attribute
+ are not repacked. */
+ if (!gfc_option.flag_repack_arrays || sym->attr.target)
{
if (as->type == AS_ASSUMED_SIZE)
packed = PACKED_FULL;
This is done here rather than in gfc_finish_var_decl because it
is different for string length variables. */
if (sym->module)
- SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
+ {
+ SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
+ if (sym->attr.use_assoc)
+ DECL_IGNORED_P (decl) = 1;
+ }
if (sym->attr.dimension)
{
if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
gfc_defer_symbol_init (sym);
+ /* This applies a derived type default initializer. */
+ else if (sym->ts.type == BT_DERIVED
+ && sym->attr.save == SAVE_NONE
+ && !sym->attr.data
+ && !sym->attr.allocatable
+ && (sym->value && !sym->ns->proc_name->attr.is_main_program)
+ && !sym->attr.use_assoc)
+ gfc_defer_symbol_init (sym);
gfc_finish_var_decl (decl, sym);
span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
gfc_array_index_type);
gfc_finish_var_decl (span, sym);
- TREE_STATIC (span) = 1;
- DECL_INITIAL (span) = build_int_cst (NULL_TREE, 0);
+ TREE_STATIC (span) = TREE_STATIC (decl);
+ DECL_ARTIFICIAL (span) = 1;
+ DECL_INITIAL (span) = build_int_cst (gfc_array_index_type, 0);
GFC_DECL_SPAN (decl) = span;
+ GFC_TYPE_ARRAY_SPAN (TREE_TYPE (decl)) = span;
}
sym->backend_decl = decl;
}
+/* Declare a procedure pointer. */
+
+static tree
+get_proc_pointer_decl (gfc_symbol *sym)
+{
+ tree decl;
+
+ decl = sym->backend_decl;
+ if (decl)
+ return decl;
+
+ decl = build_decl (VAR_DECL, get_identifier (sym->name),
+ build_pointer_type (gfc_get_function_type (sym)));
+
+ if ((sym->ns->proc_name
+ && sym->ns->proc_name->backend_decl == current_function_decl)
+ || sym->attr.contained)
+ gfc_add_decl_to_function (decl);
+ else
+ gfc_add_decl_to_parent_function (decl);
+
+ sym->backend_decl = decl;
+
+ if (!sym->attr.use_assoc
+ && (sym->attr.save != SAVE_NONE || sym->attr.data
+ || (sym->value && sym->ns->proc_name->attr.is_main_program)))
+ TREE_STATIC (decl) = 1;
+
+ if (TREE_STATIC (decl) && sym->value)
+ {
+ /* Add static initializer. */
+ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+ TREE_TYPE (decl), sym->attr.dimension, sym->attr.proc_pointer);
+ }
+
+ return decl;
+}
+
+
/* Get a basic decl for an external function. */
tree
to know that. */
gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
+ if (sym->attr.proc_pointer)
+ return get_proc_pointer_decl (sym);
+
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
if (sym->attr.pure || sym->attr.elemental)
{
if (sym->attr.function && !gfc_return_by_reference (sym))
- DECL_IS_PURE (fndecl) = 1;
+ DECL_PURE_P (fndecl) = 1;
/* TODO: check if pure SUBROUTINEs don't have INTENT(OUT)
parameters and don't use alternate returns (is this
allowed?). In that case, calls to them are meaningless, and
/* Allow only one nesting level. Allow public declarations. */
gcc_assert (current_function_decl == NULL_TREE
- || DECL_CONTEXT (current_function_decl) == NULL_TREE);
+ || DECL_CONTEXT (current_function_decl) == NULL_TREE
+ || TREE_CODE (DECL_CONTEXT (current_function_decl))
+ == NAMESPACE_DECL);
type = gfc_get_function_type (sym);
fndecl = build_decl (FUNCTION_DECL, gfc_sym_identifier (sym), type);
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_PURE_P (fndecl) = 1;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
type = gfc_sym_type (f->sym);
}
- /* Build a the argument declaration. */
+ if (f->sym->attr.proc_pointer)
+ type = build_pointer_type (type);
+
+ /* Build the argument declaration. */
parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
/* Fill in arg stuff. */
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
/* All implementation args are read-only. */
TREE_READONLY (parm) = 1;
+ if (POINTER_TYPE_P (type)
+ && (!f->sym->attr.proc_pointer
+ && f->sym->attr.flavor != FL_PROCEDURE))
+ DECL_BY_REFERENCE (parm) = 1;
gfc_finish_decl (parm);
call expand_expr to calculate the size of a variable-sized array.
We haven't necessarily assigned RTL to all variables yet, so it's
not safe to try to expand expressions involving them. */
- cfun->x_dont_save_pending_sizes_p = 1;
+ cfun->dont_save_pending_sizes_p = 1;
/* function.c requires a push at the start of the function. */
pushlevel (0);
pushdecl (union_decl);
DECL_CONTEXT (union_decl) = current_function_decl;
- tmp = build2 (MODIFY_EXPR,
- TREE_TYPE (union_decl),
- union_decl, tmp);
+ tmp = fold_build2 (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 = build3 (COMPONENT_REF, TREE_TYPE (field), union_decl, field,
- NULL_TREE);
- tmp = build2 (MODIFY_EXPR,
- TREE_TYPE (DECL_RESULT (current_function_decl)),
- DECL_RESULT (current_function_decl), tmp);
+ tmp = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ union_decl, field, NULL_TREE);
+ tmp = fold_build2 (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 = build2 (MODIFY_EXPR,
- TREE_TYPE (DECL_RESULT (current_function_decl)),
- DECL_RESULT (current_function_decl), tmp);
+ tmp = fold_build2 (MODIFY_EXPR,
+ TREE_TYPE (DECL_RESULT (current_function_decl)),
+ DECL_RESULT (current_function_decl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
}
gfc_add_expr_to_block (&body, tmp);
break;
gcc_assert (field != NULL_TREE);
- decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
- NULL_TREE);
+ decl = fold_build3 (COMPONENT_REF, TREE_TYPE (field),
+ decl, field, NULL_TREE);
}
var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
tree gfc_int8_type_node = gfc_get_int_type (8);
tree gfc_int16_type_node = gfc_get_int_type (16);
tree gfc_logical4_type_node = gfc_get_logical_type (4);
- tree gfc_real4_type_node = gfc_get_real_type (4);
- tree gfc_real8_type_node = gfc_get_real_type (8);
- tree gfc_real10_type_node = gfc_get_real_type (10);
- tree gfc_real16_type_node = gfc_get_real_type (16);
- tree gfc_complex4_type_node = gfc_get_complex_type (4);
- 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 pchar1_type_node = gfc_get_pchar_type (1);
+ tree pchar4_type_node = gfc_get_pchar_type (4);
/* String functions. */
gfor_fndecl_compare_string =
gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
integer_type_node, 4,
- gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node);
+ gfc_charlen_type_node, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node);
gfor_fndecl_concat_string =
gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
- void_type_node,
- 6,
- gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node);
+ 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);
gfor_fndecl_string_len_trim =
gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
- gfc_int4_type_node,
- 2, gfc_charlen_type_node,
- pchar_type_node);
+ gfc_int4_type_node, 2,
+ gfc_charlen_type_node, pchar1_type_node);
gfor_fndecl_string_index =
gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
- gfc_int4_type_node,
- 5, gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node,
- gfc_logical4_type_node);
+ gfc_int4_type_node, 5,
+ gfc_charlen_type_node, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node,
+ gfc_logical4_type_node);
gfor_fndecl_string_scan =
gfc_build_library_function_decl (get_identifier (PREFIX("string_scan")),
- gfc_int4_type_node,
- 5, gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node,
- gfc_logical4_type_node);
+ gfc_int4_type_node, 5,
+ gfc_charlen_type_node, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node,
+ gfc_logical4_type_node);
gfor_fndecl_string_verify =
gfc_build_library_function_decl (get_identifier (PREFIX("string_verify")),
- gfc_int4_type_node,
- 5, gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node,
- gfc_logical4_type_node);
+ gfc_int4_type_node, 5,
+ gfc_charlen_type_node, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node,
+ gfc_logical4_type_node);
- gfor_fndecl_string_trim =
+ gfor_fndecl_string_trim =
gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
- void_type_node,
- 4,
- build_pointer_type (gfc_charlen_type_node),
- ppvoid_type_node,
- gfc_charlen_type_node,
- pchar_type_node);
+ void_type_node, 4,
+ build_pointer_type (gfc_charlen_type_node),
+ build_pointer_type (pchar1_type_node),
+ gfc_charlen_type_node, pchar1_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);
+ void_type_node, -4,
+ build_pointer_type (gfc_charlen_type_node),
+ build_pointer_type (pchar1_type_node),
+ integer_type_node, integer_type_node);
+
+ gfor_fndecl_adjustl =
+ gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
+ void_type_node, 3, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node);
+
+ gfor_fndecl_adjustr =
+ gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
+ void_type_node, 3, pchar1_type_node,
+ gfc_charlen_type_node, pchar1_type_node);
+
+ gfor_fndecl_select_string =
+ gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
+ integer_type_node, 4, pvoid_type_node,
+ integer_type_node, pchar1_type_node,
+ gfc_charlen_type_node);
+
+ gfor_fndecl_compare_string_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("compare_string_char4")),
+ integer_type_node, 4,
+ gfc_charlen_type_node, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node);
+
+ gfor_fndecl_concat_string_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("concat_string_char4")),
+ 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);
+
+ gfor_fndecl_string_len_trim_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("string_len_trim_char4")),
+ gfc_charlen_type_node, 2,
+ gfc_charlen_type_node, pchar4_type_node);
+
+ gfor_fndecl_string_index_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("string_index_char4")),
+ gfc_charlen_type_node, 5,
+ gfc_charlen_type_node, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node,
+ gfc_logical4_type_node);
+
+ gfor_fndecl_string_scan_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("string_scan_char4")),
+ gfc_charlen_type_node, 5,
+ gfc_charlen_type_node, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node,
+ gfc_logical4_type_node);
+
+ gfor_fndecl_string_verify_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("string_verify_char4")),
+ gfc_charlen_type_node, 5,
+ gfc_charlen_type_node, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node,
+ gfc_logical4_type_node);
+
+ gfor_fndecl_string_trim_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("string_trim_char4")),
+ void_type_node, 4,
+ build_pointer_type (gfc_charlen_type_node),
+ build_pointer_type (pchar4_type_node),
+ gfc_charlen_type_node, pchar4_type_node);
+
+ gfor_fndecl_string_minmax_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("string_minmax_char4")),
+ void_type_node, -4,
+ build_pointer_type (gfc_charlen_type_node),
+ build_pointer_type (pchar4_type_node),
+ integer_type_node, integer_type_node);
+
+ gfor_fndecl_adjustl_char4 =
+ gfc_build_library_function_decl (get_identifier (PREFIX("adjustl_char4")),
+ void_type_node, 3, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node);
+
+ gfor_fndecl_adjustr_char4 =
+ gfc_build_library_function_decl (get_identifier (PREFIX("adjustr_char4")),
+ void_type_node, 3, pchar4_type_node,
+ gfc_charlen_type_node, pchar4_type_node);
+
+ gfor_fndecl_select_string_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("select_string_char4")),
+ integer_type_node, 4, pvoid_type_node,
+ integer_type_node, pvoid_type_node,
+ gfc_charlen_type_node);
+
+
+ /* Conversion between character kinds. */
+
+ gfor_fndecl_convert_char1_to_char4 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("convert_char1_to_char4")),
+ void_type_node, 3,
+ build_pointer_type (pchar4_type_node),
+ gfc_charlen_type_node, pchar1_type_node);
+
+ gfor_fndecl_convert_char4_to_char1 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("convert_char4_to_char1")),
+ void_type_node, 3,
+ build_pointer_type (pchar1_type_node),
+ gfc_charlen_type_node, pchar4_type_node);
+
+ /* Misc. functions. */
gfor_fndecl_ttynam =
gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
gfc_charlen_type_node,
gfc_int8_type_node);
- gfor_fndecl_adjustl =
- gfc_build_library_function_decl (get_identifier (PREFIX("adjustl")),
- void_type_node,
- 3,
- pchar_type_node,
- gfc_charlen_type_node, pchar_type_node);
-
- gfor_fndecl_adjustr =
- gfc_build_library_function_decl (get_identifier (PREFIX("adjustr")),
- void_type_node,
- 3,
- pchar_type_node,
+ gfor_fndecl_sc_kind =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("selected_char_kind")),
+ gfc_int4_type_node, 2,
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_si_kind =
gfc_build_library_function_decl (get_identifier
(PREFIX("selected_int_kind")),
- gfc_int4_type_node,
- 1,
- pvoid_type_node);
+ gfc_int4_type_node, 1, pvoid_type_node);
gfor_fndecl_sr_kind =
- gfc_build_library_function_decl (get_identifier
+ gfc_build_library_function_decl (get_identifier
(PREFIX("selected_real_kind")),
- gfc_int4_type_node,
- 2, pvoid_type_node,
- pvoid_type_node);
+ gfc_int4_type_node, 2,
+ pvoid_type_node, pvoid_type_node);
/* Power functions. */
{
#undef NRKINDS
}
- gfor_fndecl_math_cpowf =
- gfc_build_library_function_decl (get_identifier ("cpowf"),
- gfc_complex4_type_node,
- 1, gfc_complex4_type_node);
- gfor_fndecl_math_cpow =
- gfc_build_library_function_decl (get_identifier ("cpow"),
- gfc_complex8_type_node,
- 1, gfc_complex8_type_node);
- if (gfc_complex10_type_node)
- gfor_fndecl_math_cpowl10 =
- gfc_build_library_function_decl (get_identifier ("cpowl"),
- gfc_complex10_type_node, 1,
- gfc_complex10_type_node);
- if (gfc_complex16_type_node)
- gfor_fndecl_math_cpowl16 =
- gfc_build_library_function_decl (get_identifier ("cpowl"),
- gfc_complex16_type_node, 1,
- gfc_complex16_type_node);
-
gfor_fndecl_math_ishftc4 =
gfc_build_library_function_decl (get_identifier (PREFIX("ishftc4")),
gfc_int4_type_node,
gfc_int4_type_node,
gfc_int4_type_node);
- gfor_fndecl_math_exponent4 =
- gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r4")),
- gfc_int4_type_node,
- 1, gfc_real4_type_node);
- gfor_fndecl_math_exponent8 =
- gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r8")),
- gfc_int4_type_node,
- 1, gfc_real8_type_node);
- if (gfc_real10_type_node)
- gfor_fndecl_math_exponent10 =
- gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r10")),
- gfc_int4_type_node, 1,
- gfc_real10_type_node);
- if (gfc_real16_type_node)
- gfor_fndecl_math_exponent16 =
- gfc_build_library_function_decl (get_identifier (PREFIX("exponent_r16")),
- gfc_int4_type_node, 1,
- gfc_real16_type_node);
-
/* BLAS functions. */
{
tree pint = build_pointer_type (integer_type_node);
void_type_node, 2, pchar_type_node,
gfc_int4_type_node);
- gfor_fndecl_select_string =
- gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
- integer_type_node, 0);
-
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
void_type_node, -1, pchar_type_node);
/* The runtime_error_at function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
+ gfor_fndecl_runtime_warning_at =
+ gfc_build_library_function_decl (get_identifier (PREFIX("runtime_warning_at")),
+ void_type_node, -2, pchar_type_node,
+ pchar_type_node);
gfor_fndecl_generate_error =
gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
void_type_node, 3, pvoid_type_node,
gfor_fndecl_in_unpack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_unpack")),
- pvoid_type_node, 1, pvoid_type_node);
+ void_type_node, 2, pvoid_type_node, pvoid_type_node);
gfor_fndecl_associated =
gfc_build_library_function_decl (
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_conv_string_length (cl, &body);
+ gfc_conv_string_length (cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_conv_string_length (sym->ts.cl, &body);
+ gfc_conv_string_length (sym->ts.cl, NULL, &body);
gfc_trans_vla_type_sizes (sym, &body);
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
- tmp = build1 (DECL_EXPR, TREE_TYPE (decl), decl);
+ tmp = fold_build1 (DECL_EXPR, TREE_TYPE (decl), decl);
gfc_add_expr_to_block (&body, tmp);
gfc_add_expr_to_block (&body, fnbody);
/* Set the initial value to length. See the comments in
function gfc_add_assign_aux_vars in this file. */
- gfc_add_modify_expr (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
+ gfc_add_modify (&body, GFC_DECL_STRING_LEN (sym->backend_decl),
build_int_cst (NULL_TREE, -2));
gfc_add_expr_to_block (&body, fnbody);
var = gfc_create_var_np (TREE_TYPE (t), NULL);
gfc_add_decl_to_function (var);
- gfc_add_modify_expr (body, var, val);
+ gfc_add_modify (body, var, val);
if (TREE_CODE (t) == SAVE_EXPR)
TREE_OPERAND (t, 0) = var;
*tp = var;
}
+/* Initialize a derived type by building an lvalue from the symbol
+ and using trans_assignment to do the work. */
+tree
+gfc_init_default_dt (gfc_symbol * sym, tree body)
+{
+ stmtblock_t fnblock;
+ gfc_expr *e;
+ tree tmp;
+ tree present;
+
+ gfc_init_block (&fnblock);
+ gcc_assert (!sym->attr.allocatable);
+ gfc_set_sym_referenced (sym);
+ e = gfc_lval_expr_from_sym (sym);
+ tmp = gfc_trans_assignment (e, sym->value, false);
+ if (sym->attr.dummy)
+ {
+ present = gfc_conv_expr_present (sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt ());
+ }
+ gfc_add_expr_to_block (&fnblock, tmp);
+ gfc_free_expr (e);
+ if (body)
+ gfc_add_expr_to_block (&fnblock, body);
+ return gfc_finish_block (&fnblock);
+}
+
+
/* Initialize INTENT(OUT) derived type dummies. */
static tree
init_intent_out_dt (gfc_symbol * proc_sym, tree body)
{
stmtblock_t fnblock;
gfc_formal_arglist *f;
- gfc_expr *tmpe;
- tree tmp;
- tree present;
gfc_init_block (&fnblock);
-
for (f = proc_sym->formal; f; f = f->next)
- {
- 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)
- {
- 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 (&fnblock, tmp);
- gfc_free_expr (tmpe);
- }
- }
+ 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)
+ body = gfc_init_default_dt (f->sym, body);
gfc_add_expr_to_block (&fnblock, body);
return gfc_finish_block (&fnblock);
}
-
/* Generate function entry and exit code, and add it to the function body.
This includes:
Allocation and initialization of array variables.
if (el->sym != el->sym->result)
break;
}
- if (el == NULL)
- warning (0, "Function does not return a value");
+ /* TODO: move to the appropriate place in resolve.c. */
+ if (warn_return_type && el == NULL)
+ gfc_warning ("Return value of function '%s' at %L not set",
+ proc_sym->name, &proc_sym->declared_at);
}
else if (proc_sym->as)
{
seen_trans_deferred_array = true;
fnbody = gfc_trans_deferred_array (sym, fnbody);
}
+ else if (sym->ts.type == BT_DERIVED
+ && sym->value
+ && !sym->attr.data
+ && sym->attr.save == SAVE_NONE)
+ fnbody = gfc_init_default_dt (sym, fnbody);
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
fnbody = gfc_trans_assign_aux_var (sym, fnbody);
gfc_set_backend_locus (&loc);
}
+ else if (sym->ts.type == BT_DERIVED
+ && sym->value
+ && !sym->attr.data
+ && sym->attr.save == SAVE_NONE)
+ fnbody = gfc_init_default_dt (sym, fnbody);
else
gcc_unreachable ();
}
return gfc_finish_block (&body);
}
+static GTY ((param_is (struct module_htab_entry))) htab_t module_htab;
+
+/* Hash and equality functions for module_htab. */
+
+static hashval_t
+module_htab_do_hash (const void *x)
+{
+ return htab_hash_string (((const struct module_htab_entry *)x)->name);
+}
+
+static int
+module_htab_eq (const void *x1, const void *x2)
+{
+ return strcmp ((((const struct module_htab_entry *)x1)->name),
+ (const char *)x2) == 0;
+}
+
+/* Hash and equality functions for module_htab's decls. */
+
+static hashval_t
+module_htab_decls_hash (const void *x)
+{
+ const_tree t = (const_tree) x;
+ const_tree n = DECL_NAME (t);
+ if (n == NULL_TREE)
+ n = TYPE_NAME (TREE_TYPE (t));
+ return htab_hash_string (IDENTIFIER_POINTER (n));
+}
+
+static int
+module_htab_decls_eq (const void *x1, const void *x2)
+{
+ const_tree t1 = (const_tree) x1;
+ const_tree n1 = DECL_NAME (t1);
+ if (n1 == NULL_TREE)
+ n1 = TYPE_NAME (TREE_TYPE (t1));
+ return strcmp (IDENTIFIER_POINTER (n1), (const char *) x2) == 0;
+}
+
+struct module_htab_entry *
+gfc_find_module (const char *name)
+{
+ void **slot;
+
+ if (! module_htab)
+ module_htab = htab_create_ggc (10, module_htab_do_hash,
+ module_htab_eq, NULL);
+
+ slot = htab_find_slot_with_hash (module_htab, name,
+ htab_hash_string (name), INSERT);
+ if (*slot == NULL)
+ {
+ struct module_htab_entry *entry = GGC_CNEW (struct module_htab_entry);
+
+ entry->name = gfc_get_string (name);
+ entry->decls = htab_create_ggc (10, module_htab_decls_hash,
+ module_htab_decls_eq, NULL);
+ *slot = (void *) entry;
+ }
+ return (struct module_htab_entry *) *slot;
+}
+
+void
+gfc_module_add_decl (struct module_htab_entry *entry, tree decl)
+{
+ void **slot;
+ const char *name;
+
+ if (DECL_NAME (decl))
+ name = IDENTIFIER_POINTER (DECL_NAME (decl));
+ else
+ {
+ gcc_assert (TREE_CODE (decl) == TYPE_DECL);
+ name = IDENTIFIER_POINTER (TYPE_NAME (TREE_TYPE (decl)));
+ }
+ slot = htab_find_slot_with_hash (entry->decls, name,
+ htab_hash_string (name), INSERT);
+ if (*slot == NULL)
+ *slot = (void *) decl;
+}
+
+static struct module_htab_entry *cur_module;
/* Output an initialized decl for a module variable. */
&& sym->ts.type == BT_DERIVED)
sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
+ if (sym->attr.flavor == FL_DERIVED
+ && sym->backend_decl
+ && TREE_CODE (sym->backend_decl) == RECORD_TYPE)
+ {
+ decl = sym->backend_decl;
+ gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+ gcc_assert (TYPE_CONTEXT (decl) == NULL_TREE
+ || TYPE_CONTEXT (decl) == sym->ns->proc_name->backend_decl);
+ gcc_assert (DECL_CONTEXT (TYPE_STUB_DECL (decl)) == NULL_TREE
+ || DECL_CONTEXT (TYPE_STUB_DECL (decl))
+ == sym->ns->proc_name->backend_decl);
+ TYPE_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+ DECL_CONTEXT (TYPE_STUB_DECL (decl)) = sym->ns->proc_name->backend_decl;
+ gfc_module_add_decl (cur_module, TYPE_STUB_DECL (decl));
+ }
+
/* Only output variables and array valued, or derived type,
parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.dimension || sym->ts.type == BT_DERIVED)))
return;
+ if ((sym->attr.in_common || sym->attr.in_equivalence) && sym->backend_decl)
+ {
+ decl = sym->backend_decl;
+ gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
+ gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+ DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+ gfc_module_add_decl (cur_module, decl);
+ }
+
/* Don't generate variables from other modules. Variables from
COMMONs will already have been generated. */
if (sym->attr.use_assoc || sym->attr.in_common)
/* Equivalenced variables arrive here after creation. */
if (sym->backend_decl
- && (sym->equiv_built || sym->attr.in_equivalence))
- return;
+ && (sym->equiv_built || sym->attr.in_equivalence))
+ return;
if (sym->backend_decl)
internal_error ("backend decl for module variable %s already exists",
/* Create the variable. */
pushdecl (decl);
+ gcc_assert (DECL_CONTEXT (decl) == NULL_TREE);
+ gcc_assert (sym->ns->proc_name->attr.flavor == FL_MODULE);
+ DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
rest_of_decl_compilation (decl, 1, 0);
+ gfc_module_add_decl (cur_module, decl);
/* Also add length of strings. */
if (sym->ts.type == BT_CHARACTER)
}
}
+/* Emit debug information for USE statements. */
+
+static void
+gfc_trans_use_stmts (gfc_namespace * ns)
+{
+ gfc_use_list *use_stmt;
+ for (use_stmt = ns->use_stmts; use_stmt; use_stmt = use_stmt->next)
+ {
+ struct module_htab_entry *entry
+ = gfc_find_module (use_stmt->module_name);
+ gfc_use_rename *rent;
+
+ if (entry->namespace_decl == NULL)
+ {
+ entry->namespace_decl
+ = build_decl (NAMESPACE_DECL,
+ get_identifier (use_stmt->module_name),
+ void_type_node);
+ DECL_EXTERNAL (entry->namespace_decl) = 1;
+ }
+ gfc_set_backend_locus (&use_stmt->where);
+ if (!use_stmt->only_flag)
+ (*debug_hooks->imported_module_or_decl) (entry->namespace_decl,
+ NULL_TREE,
+ ns->proc_name->backend_decl,
+ false);
+ for (rent = use_stmt->rename; rent; rent = rent->next)
+ {
+ tree decl, local_name;
+ void **slot;
+
+ if (rent->op != INTRINSIC_NONE)
+ continue;
+
+ slot = htab_find_slot_with_hash (entry->decls, rent->use_name,
+ htab_hash_string (rent->use_name),
+ INSERT);
+ if (*slot == NULL)
+ {
+ gfc_symtree *st;
+
+ st = gfc_find_symtree (ns->sym_root,
+ rent->local_name[0]
+ ? rent->local_name : rent->use_name);
+ gcc_assert (st && st->n.sym->attr.use_assoc);
+ if (st->n.sym->backend_decl
+ && DECL_P (st->n.sym->backend_decl)
+ && st->n.sym->module
+ && strcmp (st->n.sym->module, use_stmt->module_name) == 0)
+ {
+ gcc_assert (DECL_EXTERNAL (entry->namespace_decl)
+ || (TREE_CODE (st->n.sym->backend_decl)
+ != VAR_DECL));
+ decl = copy_node (st->n.sym->backend_decl);
+ DECL_CONTEXT (decl) = entry->namespace_decl;
+ DECL_EXTERNAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 0;
+ DECL_INITIAL (decl) = NULL_TREE;
+ }
+ else
+ {
+ *slot = error_mark_node;
+ htab_clear_slot (entry->decls, slot);
+ continue;
+ }
+ *slot = decl;
+ }
+ decl = (tree) *slot;
+ if (rent->local_name[0])
+ local_name = get_identifier (rent->local_name);
+ else
+ local_name = NULL_TREE;
+ gfc_set_backend_locus (&rent->where);
+ (*debug_hooks->imported_module_or_decl) (decl, local_name,
+ ns->proc_name->backend_decl,
+ !use_stmt->only_flag);
+ }
+ }
+}
+
+
+/* Return true if expr is a constant initializer that gfc_conv_initializer
+ will handle. */
+
+static bool
+check_constant_initializer (gfc_expr *expr, gfc_typespec *ts, bool array,
+ bool pointer)
+{
+ gfc_constructor *c;
+ gfc_component *cm;
+
+ if (pointer)
+ return true;
+ else if (array)
+ {
+ if (expr->expr_type == EXPR_CONSTANT || expr->expr_type == EXPR_NULL)
+ return true;
+ else if (expr->expr_type == EXPR_STRUCTURE)
+ return check_constant_initializer (expr, ts, false, false);
+ else if (expr->expr_type != EXPR_ARRAY)
+ return false;
+ for (c = expr->value.constructor; c; c = c->next)
+ {
+ if (c->iterator)
+ return false;
+ if (c->expr->expr_type == EXPR_STRUCTURE)
+ {
+ if (!check_constant_initializer (c->expr, ts, false, false))
+ return false;
+ }
+ else if (c->expr->expr_type != EXPR_CONSTANT)
+ return false;
+ }
+ return true;
+ }
+ else switch (ts->type)
+ {
+ case BT_DERIVED:
+ if (expr->expr_type != EXPR_STRUCTURE)
+ return false;
+ cm = expr->ts.derived->components;
+ for (c = expr->value.constructor; c; c = c->next, cm = cm->next)
+ {
+ if (!c->expr || cm->attr.allocatable)
+ continue;
+ if (!check_constant_initializer (c->expr, &cm->ts,
+ cm->attr.dimension,
+ cm->attr.pointer))
+ return false;
+ }
+ return true;
+ default:
+ return expr->expr_type == EXPR_CONSTANT;
+ }
+}
+
+/* Emit debug info for parameters and unreferenced variables with
+ initializers. */
+
+static void
+gfc_emit_parameter_debug_info (gfc_symbol *sym)
+{
+ tree decl;
+
+ if (sym->attr.flavor != FL_PARAMETER
+ && (sym->attr.flavor != FL_VARIABLE || sym->attr.referenced))
+ return;
+
+ if (sym->backend_decl != NULL
+ || sym->value == NULL
+ || sym->attr.use_assoc
+ || sym->attr.dummy
+ || sym->attr.result
+ || sym->attr.function
+ || sym->attr.intrinsic
+ || sym->attr.pointer
+ || sym->attr.allocatable
+ || sym->attr.cray_pointee
+ || sym->attr.threadprivate
+ || sym->attr.is_bind_c
+ || sym->attr.subref_array_pointer
+ || sym->attr.assign)
+ return;
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_conv_const_charlen (sym->ts.cl);
+ if (sym->ts.cl->backend_decl == NULL
+ || TREE_CODE (sym->ts.cl->backend_decl) != INTEGER_CST)
+ return;
+ }
+ else if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ return;
+
+ if (sym->as)
+ {
+ int n;
+
+ if (sym->as->type != AS_EXPLICIT)
+ return;
+ for (n = 0; n < sym->as->rank; n++)
+ if (sym->as->lower[n]->expr_type != EXPR_CONSTANT
+ || sym->as->upper[n] == NULL
+ || sym->as->upper[n]->expr_type != EXPR_CONSTANT)
+ return;
+ }
+
+ if (!check_constant_initializer (sym->value, &sym->ts,
+ sym->attr.dimension, false))
+ return;
+
+ /* Create the decl for the variable or constant. */
+ decl = build_decl (sym->attr.flavor == FL_PARAMETER ? CONST_DECL : VAR_DECL,
+ gfc_sym_identifier (sym), gfc_sym_type (sym));
+ if (sym->attr.flavor == FL_PARAMETER)
+ TREE_READONLY (decl) = 1;
+ gfc_set_decl_location (decl, &sym->declared_at);
+ if (sym->attr.dimension)
+ GFC_DECL_PACKED_ARRAY (decl) = 1;
+ DECL_CONTEXT (decl) = sym->ns->proc_name->backend_decl;
+ TREE_STATIC (decl) = 1;
+ 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);
+ debug_hooks->global_decl (decl);
+}
/* Generate all the required code for module variables. */
gfc_generate_module_vars (gfc_namespace * ns)
{
module_namespace = ns;
+ cur_module = gfc_find_module (ns->proc_name->name);
/* Check if the frontend left the namespace in a reasonable state. */
gcc_assert (ns->proc_name && !ns->proc_name->tlink);
/* Create decls for all the module variables. */
gfc_traverse_ns (ns, gfc_create_module_variable);
+
+ cur_module = NULL;
+
+ gfc_trans_use_stmts (ns);
+ gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
}
+
static void
gfc_generate_contained_functions (gfc_namespace * parent)
{
{
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);
/* 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))
+ && !(sym->attr.in_common || sym->attr.use_assoc || sym->mark))
gfc_warning ("Unused variable '%s' declared at %L", sym->name,
&sym->declared_at);
/* For variable length CHARACTER parameters, the PARM_DECL already
gfc_get_symbol_decl (sym);
}
+ /* 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;
+
/* 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)
gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
&sym->declared_at);
}
+ else if (sym->attr.flavor == FL_PROCEDURE)
+ {
+ /* TODO: move to the appropriate place in resolve.c. */
+ if (warn_return_type
+ && sym->attr.function
+ && sym->result
+ && sym != sym->result
+ && !sym->result->attr.referenced
+ && !sym->attr.use_assoc
+ && sym->attr.if_source != IFSRC_IFBODY)
+ {
+ gfc_warning ("Return value '%s' of function '%s' declared at "
+ "%L not set", sym->result->name, sym->name,
+ &sym->result->declared_at);
+
+ /* Prevents "Unused variable" warning for RESULT variables. */
+ sym->result->mark = 1;
+ }
+ }
if (sym->attr.dummy == 1)
{
val = build_int_cst (gfc_array_index_type, el->id);
tmp = build3_v (CASE_LABEL_EXPR, val, NULL_TREE, label);
gfc_add_expr_to_block (&block, tmp);
-
+
/* And jump to the actual entry point. */
label = gfc_build_label_decl (NULL_TREE);
tmp = build1_v (GOTO_EXPR, label);
gfc_generate_contained_functions (ns);
generate_local_vars (ns);
-
+
/* Keep the parent fake result declaration in module functions
or external procedures. */
if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
build_int_cst (integer_type_node,
flag_bounds_check), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.flag_range_check), array);
+
array_type = build_array_type (integer_type_node,
build_index_type (build_int_cst (NULL_TREE,
- 6)));
+ 7)));
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);
+ build_int_cst (integer_type_node, 8), var);
gfc_add_expr_to_block (&body, tmp);
}
{
tree alternate_return;
alternate_return = gfc_get_fake_result_decl (sym, 0);
- gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
+ gfc_add_modify (&body, alternate_return, integer_zero_node);
}
if (ns->entries)
gfc_add_expr_to_block (&block, tmp2);
}
- gfc_add_expr_to_block (&block, tmp);
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (result == NULL_TREE)
+ {
+ /* TODO: move to the appropriate place in resolve.c. */
+ if (warn_return_type && !sym->attr.referenced && sym == sym->result)
+ gfc_warning ("Return value of function '%s' at %L not set",
+ sym->name, &sym->declared_at);
- if (result == NULL_TREE)
- warning (0, "Function return value not set");
+ TREE_NO_WARNING(sym->backend_decl) = 1;
+ }
else
{
/* 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 = fold_build2 (MODIFY_EXPR, TREE_TYPE (tmp),
+ DECL_RESULT (fndecl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
}
gfc_gimplify_function (fndecl);
cgraph_finalize_function (fndecl, false);
}
+
+ gfc_trans_use_stmts (ns);
+ gfc_traverse_ns (ns, gfc_emit_parameter_debug_info);
}
void
decl = build_decl (VAR_DECL, id, gfc_array_index_type);
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
+ DECL_IGNORED_P (decl) = 1;
pushdecl (decl);
rest_of_decl_compilation (decl, 1, 0);
OSDN Git Service
