/* 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
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 */
#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"
/* Function declarations for builtin library functions. */
-tree gfor_fndecl_internal_realloc;
-tree gfor_fndecl_allocate;
-tree gfor_fndecl_allocate_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_runtime_warning_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;
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_scan;
tree gfor_fndecl_string_verify;
tree gfor_fndecl_string_trim;
+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
}
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
{
- if (strcmp (sym->name, "MAIN__") == 0
- || sym->attr.proc == PROC_INTRINSIC)
+ /* Main program is mangled into MAIN__. */
+ if (sym->attr.is_main_program)
+ return get_identifier ("MAIN__");
+
+ /* Intrinsic procedures are never mangled. */
+ if (sym->attr.proc == PROC_INTRINSIC)
return get_identifier (sym->name);
if (gfc_option.flag_underscoring)
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. */
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 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);
gcc_assert (!sym->value);
}
}
+ else if (sym->attr.subref_array_pointer)
+ {
+ /* We need the span for these beasts. */
+ gfc_allocate_lang_decl (decl);
+ }
+
+ if (sym->attr.subref_array_pointer)
+ {
+ tree span;
+ GFC_DECL_SUBREF_ARRAY_P (decl) = 1;
+ span = build_decl (VAR_DECL, create_tmp_var_name ("span"),
+ gfc_array_index_type);
+ gfc_finish_var_decl (span, sym);
+ 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;
if (sym->attr.assign)
}
+/* 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
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 (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 (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;
}
+ /* For -fwhole-program to work well, the main program needs to have the
+ "externally_visible" attribute. */
+ if (attr.is_main_program)
+ DECL_ATTRIBUTES (fndecl)
+ = tree_cons (get_identifier("externally_visible"), NULL_TREE, NULL_TREE);
+
/* Layout the function declaration and put it in the binding level
of the current function. */
pushdecl (fndecl);
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);
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);
typelist = TREE_CHAIN (typelist);
}
- /* Add the hidden string length parameters. */
- arglist = chainon (arglist, hidden_arglist);
+ /* Add the hidden string length parameters, unless the procedure
+ is bind(C). */
+ if (!sym->attr.is_bind_c)
+ arglist = chainon (arglist, hidden_arglist);
gcc_assert (hidden_typelist == NULL_TREE
|| TREE_VALUE (hidden_typelist) == void_type_node);
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);
/* We're leaving the context of this function, so zap cfun.
It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
tree_rest_of_compilation. */
- cfun = NULL;
+ set_cfun (NULL);
current_function_decl = NULL_TREE;
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 gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
+ 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")),
- gfc_int4_type_node,
- 4,
- gfc_charlen_type_node, pchar_type_node,
- gfc_charlen_type_node, pchar_type_node);
+ integer_type_node, 4,
+ 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),
+ 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")),
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,
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 (gfc_c_int_type_node);
+ 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));
: "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);
+ 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, gfc_c_int_type_node,
- gfc_c_int_type_node);
+ 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, gfc_c_int_type_node,
- gfc_c_int_type_node);
+ 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, gfc_c_int_type_node,
- gfc_c_int_type_node);
+ pz, pint, pz, pz, pint, integer_type_node,
+ integer_type_node);
}
/* Other functions. */
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_logical4_type_node = gfc_get_logical_type (4);
- tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
- tree gfc_index_int_type_node = gfc_get_int_type (gfc_index_integer_kind);
-
- gfor_fndecl_internal_realloc =
- gfc_build_library_function_decl (get_identifier
- (PREFIX("internal_realloc")),
- pvoid_type_node, 2, pvoid_type_node,
- gfc_index_int_type_node);
- DECL_IS_MALLOC (gfor_fndecl_internal_realloc) = 1;
-
- gfor_fndecl_allocate =
- gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
- pvoid_type_node, 2,
- gfc_index_int_type_node, gfc_pint4_type_node);
- DECL_IS_MALLOC (gfor_fndecl_allocate) = 1;
-
- gfor_fndecl_allocate_array =
- gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
- pvoid_type_node, 3, pvoid_type_node,
- gfc_index_int_type_node, gfc_pint4_type_node);
- DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1;
-
- gfor_fndecl_deallocate =
- gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
- void_type_node, 2, pvoid_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;
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")),
- pvoid_type_node, 0);
-
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
- void_type_node, 1, pchar_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,
+ 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_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,
- gfc_c_int_type_node, pchar_type_node);
+ integer_type_node, pchar_type_node);
gfor_fndecl_os_error =
gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
gfor_fndecl_set_fpe =
gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
- void_type_node, 1, gfc_c_int_type_node);
-
- gfor_fndecl_set_std =
- gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
- void_type_node,
- 5,
- gfc_int4_type_node,
- gfc_int4_type_node,
- gfc_int4_type_node,
- gfc_int4_type_node,
- gfc_int4_type_node);
+ void_type_node, 1, integer_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, gfc_c_int_type_node);
+ 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, gfc_c_int_type_node);
+ void_type_node, 1, integer_type_node);
gfor_fndecl_in_pack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_pack")),
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 (
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 ();
gfc_start_block (&body);
/* Evaluate the string length expression. */
- gfc_trans_init_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_trans_init_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_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)
+ 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)
{
&& proc_sym->ts.type == BT_COMPLEX);
}
+ /* Initialize the INTENT(OUT) derived type dummy arguments. This
+ should be done here so that the offsets and lbounds of arrays
+ are available. */
+ fnbody = init_intent_out_dt (proc_sym, fnbody);
+
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
{
bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
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 ();
}
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 (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
&& current_fake_result_decl != NULL)
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));
- /* Only output variables and array valued parameters. */
+ 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.flavor != FL_PARAMETER || sym->attr.dimension == 0))
+ && !(sym->attr.flavor == FL_PARAMETER
+ && (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)
{
}
-/* Set up the tree type for the given symbol to allow the dummy
- variable (parameter) to be passed by-value. To do this, the main
- idea is to simply remove the extra layer added by Fortran
- automatically (the POINTER_TYPE node). This pointer type node
- would normally just contain the real type underneath, but we remove
- it here and later we change the way the argument is converted for a
- function call (trans-expr.c:gfc_conv_function_call). This is the
- approach the C compiler takes (or it appears to be this way). When
- the middle-end is given the typed node rather than the POINTER_TYPE
- node, it knows to pass the value. */
-
-static void
-set_tree_decl_type_code (gfc_symbol *sym)
-{
- /* This should not happen. during the gfc_sym_type function,
- when the backend_decl is being built for a dummy arg, if the arg
- is pass-by-value then no reference type is wrapped around the
- true type (e.g., REAL_TYPE). */
- if (TREE_CODE (TREE_TYPE (sym->backend_decl)) == POINTER_TYPE ||
- TREE_CODE (TREE_TYPE (sym->backend_decl)) == REFERENCE_TYPE)
- TREE_TYPE (sym->backend_decl) = gfc_typenode_for_spec (&sym->ts);
- DECL_BY_REFERENCE (sym->backend_decl) = 0;
-
- /* the tree can't be addressable if it's pass-by-value..? x*/
-/* TREE_TYPE(sym->backend_decl)->common.addressable_flag = 0; */
-
- DECL_ARG_TYPE (sym->backend_decl) = TREE_TYPE (sym->backend_decl);
-
- DECL_MODE (sym->backend_decl) =
- TYPE_MODE (TREE_TYPE (sym->backend_decl));
-
- return;
-}
-
-
/* 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;
+/* Traverse expr, marking all EXPR_VARIABLE symbols referenced. */
- 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
+static bool
+expr_decls (gfc_expr *e, gfc_symbol *sym,
+ int *f ATTRIBUTE_UNUSED)
+{
+ if (e->expr_type != EXPR_VARIABLE
+ || 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;
+ return false;
- case REF_SUBSTRING:
- generate_expr_decls (sym, ref->u.ss.start);
- generate_expr_decls (sym, ref->u.ss.end);
- break;
+ generate_local_decl (e->symtree->n.sym);
+ return false;
+}
- 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;
- }
- }
- }
+static void
+generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
+{
+ gfc_traverse_expr (e, sym, expr_decls, 0);
}
int i;
if (sym->ts.type == BT_CHARACTER
- && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
+ && sym->ts.cl
+ && sym->ts.cl->length
+ && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
generate_expr_decls (sym, sym->ts.cl->length);
if (sym->as && sym->as->rank)
{
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);
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",
+ 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,
+ 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))
- gfc_warning ("unused variable '%s' declared at %L", sym->name,
+ && !(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
references the length variable, so force gfc_get_symbol_decl
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)
}
else if (sym->attr.flavor == FL_PARAMETER)
{
- if (warn_unused_variable
+ if (warn_unused_parameter
&& !sym->attr.referenced
&& !sym->attr.use_assoc)
- gfc_warning ("unused parameter '%s' declared at %L", sym->name,
+ 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)
{
- /* The sym->backend_decl can be NULL if this is one of the
- intrinsic types, such as the symbol of type c_ptr for the
- c_f_pointer function, so don't set up the tree code for it. */
- if (sym->attr.value == 1 && sym->backend_decl != NULL)
- set_tree_decl_type_code (sym);
+ /* 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
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)
/* 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 gfc_int4_type_node = gfc_get_int_type (4);
- tmp = build_call_expr (gfor_fndecl_set_std, 5,
- build_int_cst (gfc_int4_type_node,
- gfc_option.warn_std),
- build_int_cst (gfc_int4_type_node,
- gfc_option.allow_std),
- build_int_cst (gfc_int4_type_node,
- pedantic),
- build_int_cst (gfc_int4_type_node,
- gfc_option.flag_dump_core),
- build_int_cst (gfc_int4_type_node,
- gfc_option.flag_backtrace));
+ 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 = 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,
+ 7)));
+ array = build_constructor_from_list (array_type, nreverse (array));
+ TREE_CONSTANT (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_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, 8), var);
gfc_add_expr_to_block (&body, tmp);
}
needed. */
if (sym->attr.is_main_program && gfc_option.fpe != 0)
{
- tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
- build_int_cst (gfc_c_int_type_node,
+ build_int_cst (integer_type_node,
gfc_option.fpe));
gfc_add_expr_to_block (&body, tmp);
}
/* If this is the main program and an -fconvert option was provided,
add a call to set_convert. */
- if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
+ if (sym->attr.is_main_program && gfc_option.convert != GFC_CONVERT_NATIVE)
{
- tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_convert, 1,
- build_int_cst (gfc_c_int_type_node,
+ build_int_cst (integer_type_node,
gfc_option.convert));
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.record_marker != 0)
{
- tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
- build_int_cst (gfc_c_int_type_node,
+ 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)
{
- tree gfc_c_int_type_node;
-
- gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
1,
- build_int_cst (gfc_c_int_type_node,
+ build_int_cst (integer_type_node,
gfc_option.max_subrecord_length));
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);
}
/* We're leaving the context of this function, so zap cfun.
It's still in DECL_STRUCT_FUNCTION, and we'll restore it in
tree_rest_of_compilation. */
- cfun = NULL;
+ set_cfun (NULL);
if (old_context)
{
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
