/* Backend function setup
- Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
+ Inc.
Contributed by Paul Brook
-This file is part of GNU G95.
+This file is part of GCC.
-GNU G95 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 version.
+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
+version.
-GNU G95 is distributed in the hope that it will be useful,
-but WITHOUT ANY WARRANTY; without even the implied warranty of
-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-GNU General Public License for more details.
+GCC is distributed in the hope that it will be useful, but WITHOUT ANY
+WARRANTY; without even the implied warranty of MERCHANTABILITY or
+FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
+for more details.
You should have received a copy of the GNU General Public License
-along with GNU G95; see the file COPYING. If not, write to
-the Free Software Foundation, 59 Temple Place - Suite 330,
-Boston, MA 02111-1307, USA. */
+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. */
/* trans-decl.c -- Handling of backend function and variable decls, etc */
#include "ggc.h"
#include "toplev.h"
#include "tm.h"
+#include "rtl.h"
#include "target.h"
#include "function.h"
-#include "errors.h"
#include "flags.h"
#include "cgraph.h"
-#include <assert.h>
#include "gfortran.h"
#include "trans.h"
#include "trans-types.h"
/* Holds the result of the function if no result variable specified. */
static GTY(()) tree current_fake_result_decl;
+static GTY(()) tree parent_fake_result_decl;
static GTY(()) tree current_function_return_label;
/* Holds the variable DECLs for the current function. */
-static GTY(()) tree saved_function_decls = NULL_TREE;
-static GTY(()) tree saved_parent_function_decls = NULL_TREE;
+static GTY(()) tree saved_function_decls;
+static GTY(()) tree saved_parent_function_decls;
/* The namespace of the module we're currently generating. Only used while
tree gfor_fndecl_internal_malloc;
tree gfor_fndecl_internal_malloc64;
+tree gfor_fndecl_internal_realloc;
+tree gfor_fndecl_internal_realloc64;
tree gfor_fndecl_internal_free;
tree gfor_fndecl_allocate;
tree gfor_fndecl_allocate64;
+tree gfor_fndecl_allocate_array;
+tree gfor_fndecl_allocate64_array;
tree gfor_fndecl_deallocate;
tree gfor_fndecl_pause_numeric;
tree gfor_fndecl_pause_string;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_select_string;
tree gfor_fndecl_runtime_error;
+tree gfor_fndecl_set_fpe;
+tree gfor_fndecl_set_std;
+tree gfor_fndecl_set_convert;
+tree gfor_fndecl_set_record_marker;
+tree gfor_fndecl_ctime;
+tree gfor_fndecl_fdate;
+tree gfor_fndecl_ttynam;
tree gfor_fndecl_in_pack;
tree gfor_fndecl_in_unpack;
tree gfor_fndecl_associated;
/* Math functions. Many other math functions are handled in
trans-intrinsic.c. */
-tree gfor_fndecl_math_powf;
-tree gfor_fndecl_math_pow;
+gfc_powdecl_list gfor_fndecl_math_powi[4][3];
tree gfor_fndecl_math_cpowf;
tree gfor_fndecl_math_cpow;
-tree gfor_fndecl_math_cabsf;
-tree gfor_fndecl_math_cabs;
-tree gfor_fndecl_math_sign4;
-tree gfor_fndecl_math_sign8;
+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_size0;
tree gfor_fndecl_size1;
+tree gfor_fndecl_iargc;
/* Intrinsic functions implemented in FORTRAN. */
tree gfor_fndecl_si_kind;
static void
gfc_add_decl_to_parent_function (tree decl)
{
- assert (decl);
+ gcc_assert (decl);
DECL_CONTEXT (decl) = DECL_CONTEXT (current_function_decl);
DECL_NONLOCAL (decl) = 1;
TREE_CHAIN (decl) = saved_parent_function_decls;
void
gfc_add_decl_to_function (tree decl)
{
- assert (decl);
+ gcc_assert (decl);
TREE_USED (decl) = 1;
DECL_CONTEXT (decl) = current_function_decl;
TREE_CHAIN (decl) = saved_function_decls;
}
-/* Build a backend label declaration.
- Set TREE_USED for named lables. For artificial labels it's up to the
- caller to mark the label as used. */
+/* Build a backend label declaration. Set TREE_USED for named labels.
+ The context of the label is always the current_function_decl. All
+ labels are marked artificial. */
tree
gfc_build_label_decl (tree label_id)
DECL_CONTEXT (label_decl) = current_function_decl;
DECL_MODE (label_decl) = VOIDmode;
- if (label_name)
- {
- DECL_ARTIFICIAL (label_decl) = 1;
- }
- else
- {
- /* We always define the label as used, even if the original source
- file never references the label. We don't want all kinds of
- spurious warnings for old-style Fortran code with too many
- labels. */
- TREE_USED (label_decl) = 1;
- }
+ /* We always define the label as used, even if the original source
+ file never references the label. We don't want all kinds of
+ spurious warnings for old-style Fortran code with too many
+ labels. */
+ TREE_USED (label_decl) = 1;
+ DECL_ARTIFICIAL (label_decl) = 1;
return label_decl;
}
}
+/* Set the backend source location of a decl. */
+
+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
+}
+
+
/* Return the backend label declaration for a given label structure,
or create it if it doesn't exist yet. */
tree
gfc_get_label_decl (gfc_st_label * lp)
{
-
if (lp->backend_decl)
return lp->backend_decl;
else
tree label_decl;
/* Validate the label declaration from the front end. */
- assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
+ gcc_assert (lp != NULL && lp->value <= MAX_LABEL_VALUE);
/* Build a mangled name for the label. */
sprintf (label_name, "__label_%.6d", lp->value);
label_decl = gfc_build_label_decl (get_identifier (label_name));
/* Tell the debugger where the label came from. */
- if (lp->value <= MAX_LABEL_VALUE) /* An internal label */
- {
- DECL_SOURCE_LINE (label_decl) = lp->where.line;
- DECL_SOURCE_FILE (label_decl) = lp->where.file->filename;
- }
+ if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
+ gfc_set_decl_location (label_decl, &lp->where);
else
DECL_ARTIFICIAL (label_decl) = 1;
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
- if (sym->module[0] == 0)
+ if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
{
int has_underscore;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
- if (sym->module[0] == 0 || sym->attr.proc == PROC_EXTERNAL
- || (sym->module[0] != 0 && sym->attr.if_source == IFSRC_IFBODY))
+ if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
+ || (sym->module != NULL && sym->attr.if_source == IFSRC_IFBODY))
{
if (strcmp (sym->name, "MAIN__") == 0
|| sym->attr.proc == PROC_INTRINSIC)
}
+/* Returns true if a variable of specified size should go on the stack. */
+
+int
+gfc_can_put_var_on_stack (tree size)
+{
+ unsigned HOST_WIDE_INT low;
+
+ if (!INTEGER_CST_P (size))
+ return 0;
+
+ if (gfc_option.flag_max_stack_var_size < 0)
+ return 1;
+
+ if (TREE_INT_CST_HIGH (size) != 0)
+ return 0;
+
+ low = TREE_INT_CST_LOW (size);
+ if (low > (unsigned HOST_WIDE_INT) gfc_option.flag_max_stack_var_size)
+ return 0;
+
+/* TODO: Set a per-function stack size limit. */
+
+ return 1;
+}
+
+
+/* gfc_finish_cray_pointee sets DECL_VALUE_EXPR for a Cray pointee to
+ an expression involving its corresponding pointer. There are
+ 2 cases; one for variable size arrays, and one for everything else,
+ because variable-sized arrays require one fewer level of
+ indirection. */
+
+static void
+gfc_finish_cray_pointee (tree decl, gfc_symbol *sym)
+{
+ tree ptr_decl = gfc_get_symbol_decl (sym->cp_pointer);
+ tree value;
+
+ /* Parameters need to be dereferenced. */
+ if (sym->cp_pointer->attr.dummy)
+ ptr_decl = build_fold_indirect_ref (ptr_decl);
+
+ /* Check to see if we're dealing with a variable-sized array. */
+ if (sym->attr.dimension
+ && TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE)
+ {
+ /* These decls will be dereferenced later, so we don't dereference
+ them here. */
+ value = convert (TREE_TYPE (decl), ptr_decl);
+ }
+ else
+ {
+ ptr_decl = convert (build_pointer_type (TREE_TYPE (decl)),
+ ptr_decl);
+ value = build_fold_indirect_ref (ptr_decl);
+ }
+
+ SET_DECL_VALUE_EXPR (decl, value);
+ DECL_HAS_VALUE_EXPR_P (decl) = 1;
+ GFC_DECL_CRAY_POINTEE (decl) = 1;
+ /* This is a fake variable just for debugging purposes. */
+ TREE_ASM_WRITTEN (decl) = 1;
+}
+
+
/* Finish processing of a declaration and install its initial value. */
static void
gfc_finish_decl (tree decl, tree init)
{
if (TREE_CODE (decl) == PARM_DECL)
- assert (init == NULL_TREE);
+ gcc_assert (init == NULL_TREE);
/* Remember that PARM_DECL doesn't have a DECL_INITIAL field per se
-- it overlaps DECL_ARG_TYPE. */
else if (init == NULL_TREE)
- assert (DECL_INITIAL (decl) == NULL_TREE);
+ gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
else
- assert (DECL_INITIAL (decl) == error_mark_node);
+ gcc_assert (DECL_INITIAL (decl) == error_mark_node);
if (init != NULL_TREE)
{
static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
- /* TREE_ADDRESSABLE means the address of this variable is acualy needed.
+ /* 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
CALL statement. */
+
+ /* Set DECL_VALUE_EXPR for Cray Pointees. */
+ if (sym->attr.cray_pointee)
+ gfc_finish_cray_pointee (decl, sym);
+
if (sym->attr.target)
TREE_ADDRESSABLE (decl) = 1;
/* If it wasn't used we wouldn't be getting it. */
function scope. */
if (current_function_decl != NULL_TREE)
{
- if (sym->ns->proc_name->backend_decl == current_function_decl)
+ if (sym->ns->proc_name->backend_decl == current_function_decl
+ || sym->result == sym)
gfc_add_decl_to_function (decl);
else
gfc_add_decl_to_parent_function (decl);
}
+ if (sym->attr.cray_pointee)
+ return;
+
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
DECL_EXTERNAL (decl) = 1;
TREE_PUBLIC (decl) = 1;
}
- else if (sym->module[0] && !sym->attr.result)
+ else if (sym->module && !sym->attr.result && !sym->attr.dummy)
{
- /* TODO: Don't set sym->module for result variables. */
- assert (current_function_decl == NULL_TREE);
+ /* TODO: Don't set sym->module for result or dummy variables. */
+ gcc_assert (current_function_decl == NULL_TREE || sym->result == sym);
/* This is the declaration of a module variable. */
TREE_PUBLIC (decl) = 1;
TREE_STATIC (decl) = 1;
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
&& !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
TREE_STATIC (decl) = 1;
+
+ /* Handle threadprivate variables. */
+ if (sym->attr.threadprivate && targetm.have_tls
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
}
if (GFC_DESCRIPTOR_TYPE_P (type))
return;
- assert (GFC_ARRAY_TYPE_P (type));
+ gcc_assert (GFC_ARRAY_TYPE_P (type));
nest = (sym->ns->proc_name->backend_decl != current_function_decl)
&& !sym->attr.contained;
{
if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
- /* Don't try to use the unkown bound for assumed shape arrays. */
+ /* 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))
else
gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
}
+
+ if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
+ && sym->as->type != AS_ASSUMED_SIZE)
+ GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+
+ if (POINTER_TYPE_P (type))
+ {
+ gcc_assert (GFC_ARRAY_TYPE_P (TREE_TYPE (type)));
+ gcc_assert (TYPE_LANG_SPECIFIC (type)
+ == TYPE_LANG_SPECIFIC (TREE_TYPE (type)));
+ type = TREE_TYPE (type);
+ }
+
+ if (! COMPLETE_TYPE_P (type) && GFC_TYPE_ARRAY_SIZE (type))
+ {
+ tree size, range;
+
+ size = 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);
+ }
}
/* For some dummy arguments we don't use the actual argument directly.
- Instead we create a local decl and use that. This allows us to preform
+ Instead we create a local decl and use that. This allows us to perform
initialization, and construct full type information. */
static tree
gfc_defer_symbol_init (sym);
type = TREE_TYPE (dummy);
- assert (TREE_CODE (dummy) == PARM_DECL
+ gcc_assert (TREE_CODE (dummy) == PARM_DECL
&& POINTER_TYPE_P (type));
- /* Do we know the element size. */
+ /* Do we know the element size? */
known_size = sym->ts.type != BT_CHARACTER
|| INTEGER_CST_P (sym->ts.cl->backend_decl);
{
/* For descriptorless arrays with known element size the actual
argument is sufficient. */
- assert (GFC_ARRAY_TYPE_P (type));
+ gcc_assert (GFC_ARRAY_TYPE_P (type));
gfc_build_qualified_array (dummy, sym);
return dummy;
}
/* We should never get deferred shape arrays here. We used to because of
frontend bugs. */
- assert (sym->as->type != AS_DEFERRED);
+ gcc_assert (sym->as->type != AS_DEFERRED);
switch (packed)
{
{
tree length;
- assert (sym->ts.cl);
+ gcc_assert (sym->ts.cl);
gfc_conv_const_charlen (sym->ts.cl);
if (sym->ts.cl->backend_decl == NULL_TREE)
strcpy (&name[1], sym->name);
name[0] = '.';
length = build_decl (VAR_DECL, get_identifier (name),
- gfc_strlen_type_node);
+ gfc_charlen_type_node);
DECL_ARTIFICIAL (length) = 1;
TREE_USED (length) = 1;
- gfc_defer_symbol_init (sym);
+ if (sym->ns->proc_name->tlink != NULL)
+ gfc_defer_symbol_init (sym);
sym->ts.cl->backend_decl = length;
}
return sym->ts.cl->backend_decl;
}
+/* If a variable is assigned a label, we add another two auxiliary
+ variables. */
+
+static void
+gfc_add_assign_aux_vars (gfc_symbol * sym)
+{
+ tree addr;
+ tree length;
+ tree decl;
+
+ gcc_assert (sym->backend_decl);
+
+ decl = sym->backend_decl;
+ gfc_allocate_lang_decl (decl);
+ GFC_DECL_ASSIGN (decl) = 1;
+ length = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
+ gfc_charlen_type_node);
+ addr = build_decl (VAR_DECL, create_tmp_var_name (sym->name),
+ pvoid_type_node);
+ gfc_finish_var_decl (length, sym);
+ gfc_finish_var_decl (addr, sym);
+ /* STRING_LENGTH is also used as flag. Less than -1 means that
+ ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
+ target label's address. Otherwise, value is the length of a format string
+ and ASSIGN_ADDR is its address. */
+ if (TREE_STATIC (length))
+ DECL_INITIAL (length) = build_int_cst (NULL_TREE, -2);
+ else
+ gfc_defer_symbol_init (sym);
+
+ GFC_DECL_STRING_LEN (decl) = length;
+ GFC_DECL_ASSIGN_ADDR (decl) = addr;
+}
/* Return the decl for a gfc_symbol, create it if it doesn't already
exist. */
{
tree decl;
tree length = NULL_TREE;
- gfc_se se;
int byref;
- assert (sym->attr.referenced);
+ gcc_assert (sym->attr.referenced
+ || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
if (sym->ns && sym->ns->proc_name->attr.function)
byref = gfc_return_by_reference (sym->ns->proc_name);
{
sym->backend_decl =
DECL_ARGUMENTS (sym->ns->proc_name->backend_decl);
+ /* For entry master function skip over the __entry
+ argument. */
+ if (sym->ns->proc_name->attr.entry_master)
+ sym->backend_decl = TREE_CHAIN (sym->backend_decl);
}
/* Dummy variables should already have been created. */
- assert (sym->backend_decl);
+ gcc_assert (sym->backend_decl);
/* Create a character length variable. */
if (sym->ts.type == BT_CHARACTER)
{
if (sym->ts.cl->backend_decl == NULL_TREE)
+ length = gfc_create_string_length (sym);
+ else
+ length = sym->ts.cl->backend_decl;
+ if (TREE_CODE (length) == VAR_DECL
+ && DECL_CONTEXT (length) == NULL_TREE)
{
- length = gfc_create_string_length (sym);
- if (TREE_CODE (length) != INTEGER_CST)
- {
- gfc_finish_var_decl (length, sym);
- gfc_defer_symbol_init (sym);
- }
+ gfc_add_decl_to_function (length);
+ gfc_defer_symbol_init (sym);
}
}
}
TREE_USED (sym->backend_decl) = 1;
+ if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
+ {
+ gfc_add_assign_aux_vars (sym);
+ }
return sym->backend_decl;
}
if (sym->backend_decl)
return sym->backend_decl;
- if (sym->attr.entry)
- gfc_todo_error ("alternate entry");
-
/* Catch function declarations. Only used for actual parameters. */
if (sym->attr.flavor == FL_PROCEDURE)
{
/* Create the decl for the variable. */
decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
- /* Symbols from modules have its assembler name should be mangled.
+ gfc_set_decl_location (decl, &sym->declared_at);
+
+ /* Symbols from modules should have their assembler names mangled.
This is done here rather than in gfc_finish_var_decl because it
is different for string length variables. */
- if (sym->module[0])
+ if (sym->module)
SET_DECL_ASSEMBLER_NAME (decl, gfc_sym_mangled_identifier (sym));
if (sym->attr.dimension)
gfc_finish_var_decl (decl, sym);
- if (sym->attr.assign)
+ if (sym->ts.type == BT_CHARACTER)
{
- gfc_allocate_lang_decl (decl);
- GFC_DECL_ASSIGN (decl) = 1;
- length = gfc_create_var (gfc_strlen_type_node, sym->name);
- GFC_DECL_STRING_LEN (decl) = length;
- GFC_DECL_ASSIGN_ADDR (decl) = gfc_create_var (pvoid_type_node, sym->name);
- /* TODO: Need to check we don't change TREE_STATIC (decl) later. */
- TREE_STATIC (length) = TREE_STATIC (decl);
- /* STRING_LENGTH is also used as flag. Less than -1 means that
- ASSIGN_ADDR can not be used. Equal -1 means that ASSIGN_ADDR is the
- target label's address. Other value is the length of format string
- and ASSIGN_ADDR is the address of format string. */
- DECL_INITIAL (length) = build_int_2 (-2, -1);
- }
-
- /* TODO: Initialization of pointer variables. */
- switch (sym->ts.type)
- {
- case BT_CHARACTER:
/* Character variables need special handling. */
gfc_allocate_lang_decl (decl);
- if (TREE_CODE (length) == INTEGER_CST)
- {
- /* Static initializer for string scalars.
- Initialization of string arrays is handled elsewhere. */
- if (sym->value && sym->attr.dimension == 0)
- {
- assert (TREE_STATIC (decl));
- if (sym->attr.pointer)
- gfc_todo_error ("initialization of character pointers");
- DECL_INITIAL (decl) = gfc_conv_string_init (length, sym->value);
- }
- }
- else
+ if (TREE_CODE (length) != INTEGER_CST)
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 2];
- if (sym->module[0])
+ if (sym->module)
{
/* Also prefix the mangled name for symbols from modules. */
strcpy (&name[1], sym->name);
SET_DECL_ASSEMBLER_NAME (decl, get_identifier (name));
}
gfc_finish_var_decl (length, sym);
- assert (!sym->value);
+ gcc_assert (!sym->value);
}
- break;
+ }
+ sym->backend_decl = decl;
- case BT_DERIVED:
- if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
- {
- gfc_init_se (&se, NULL);
- gfc_conv_structure (&se, sym->value, 1);
- DECL_INITIAL (decl) = se.expr;
- }
- break;
+ if (sym->attr.assign)
+ {
+ gfc_add_assign_aux_vars (sym);
+ }
- default:
- /* Static initializers for SAVEd variables. Arrays have already been
- remembered. Module variables are initialized when the module is
- loaded. */
- if (sym->value && ! (sym->attr.use_assoc || sym->attr.dimension))
- {
- assert (TREE_STATIC (decl));
- gfc_init_se (&se, NULL);
- gfc_conv_constant (&se, sym->value);
- DECL_INITIAL (decl) = se.expr;
- }
- break;
+ if (TREE_STATIC (decl) && !sym->attr.use_assoc)
+ {
+ /* Add static initializer. */
+ DECL_INITIAL (decl) = gfc_conv_initializer (sym->value, &sym->ts,
+ TREE_TYPE (decl), sym->attr.dimension,
+ sym->attr.pointer || sym->attr.allocatable);
}
- sym->backend_decl = decl;
return decl;
}
+/* Substitute a temporary variable in place of the real one. */
+
+void
+gfc_shadow_sym (gfc_symbol * sym, tree decl, gfc_saved_var * save)
+{
+ save->attr = sym->attr;
+ save->decl = sym->backend_decl;
+
+ gfc_clear_attr (&sym->attr);
+ sym->attr.referenced = 1;
+ sym->attr.flavor = FL_VARIABLE;
+
+ sym->backend_decl = decl;
+}
+
+
+/* Restore the original variable. */
+
+void
+gfc_restore_sym (gfc_symbol * sym, gfc_saved_var * save)
+{
+ sym->attr = save->attr;
+ sym->backend_decl = save->decl;
+}
+
+
/* Get a basic decl for an external function. */
tree
gfc_expr e;
gfc_intrinsic_sym *isym;
gfc_expr argexpr;
- char s[GFC_MAX_SYMBOL_LEN];
+ char s[GFC_MAX_SYMBOL_LEN + 13]; /* "f2c_specific" and '\0'. */
tree name;
tree mangled_name;
if (sym->backend_decl)
return sym->backend_decl;
+ /* We should never be creating external decls for alternate entry points.
+ The procedure may be an alternate entry point, but we don't want/need
+ to know that. */
+ gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
+
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is
at the first argument. We pass NULL for the second argument
otherwise things like AINT get confused. */
isym = gfc_find_function (sym->name);
- assert (isym->resolve.f0 != NULL);
+ gcc_assert (isym->resolve.f0 != NULL);
memset (&e, 0, sizeof (e));
e.expr_type = EXPR_FUNCTION;
memset (&argexpr, 0, sizeof (argexpr));
- assert (isym->formal);
+ gcc_assert (isym->formal);
argexpr.ts = isym->formal->ts;
if (isym->formal->next == NULL)
else
{
/* All specific intrinsics take one or two arguments. */
- assert (isym->formal->next->next == NULL);
+ gcc_assert (isym->formal->next->next == NULL);
isym->resolve.f2 (&e, &argexpr, NULL);
}
- sprintf (s, "specific%s", e.value.function.name);
+
+ if (gfc_option.flag_f2c
+ && ((e.ts.type == BT_REAL && e.ts.kind == gfc_default_real_kind)
+ || e.ts.type == BT_COMPLEX))
+ {
+ /* Specific which needs a different implementation if f2c
+ calling conventions are used. */
+ sprintf (s, "f2c_specific%s", e.value.function.name);
+ }
+ else
+ sprintf (s, "specific%s", e.value.function.name);
+
name = get_identifier (s);
mangled_name = name;
}
}
else
{
- /* Global declaration, eg. intrinsic subroutine. */
+ /* Global declaration, e.g. intrinsic subroutine. */
DECL_CONTEXT (fndecl) = NULL_TREE;
}
DECL_EXTERNAL (fndecl) = 1;
- /* This specifies if a function is globaly addressable, ie. it is
+ /* This specifies if a function is globally addressable, i.e. it is
the opposite of declaring static in C. */
TREE_PUBLIC (fndecl) = 1;
sense. */
if (sym->attr.pure || sym->attr.elemental)
{
- DECL_IS_PURE (fndecl) = 1;
-/* TODO: check if pure/elemental procedures can have INTENT(OUT) parameters.
- TREE_SIDE_EFFECTS (fndecl) = 0;*/
+ if (sym->attr.function && !gfc_return_by_reference (sym))
+ DECL_IS_PURE (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
+ can be optimized away. See also in build_function_decl(). */
+ TREE_SIDE_EFFECTS (fndecl) = 0;
}
+ /* Mark non-returning functions. */
+ if (sym->attr.noreturn)
+ TREE_THIS_VOLATILE(fndecl) = 1;
+
sym->backend_decl = fndecl;
if (DECL_CONTEXT (fndecl) == NULL_TREE)
/* Create a declaration for a procedure. For external functions (in the C
- sense) use gfc_get_extern_function_decl. */
+ sense) use gfc_get_extern_function_decl. HAS_ENTRIES is true if this is
+ a master function with alternate entry points. */
-void
-gfc_build_function_decl (gfc_symbol * sym)
+static void
+build_function_decl (gfc_symbol * sym)
{
- tree fndecl, type, result_decl, typelist, arglist;
- tree length;
+ tree fndecl, type;
symbol_attribute attr;
+ tree result_decl;
gfc_formal_arglist *f;
- assert (!sym->backend_decl);
- assert (!sym->attr.external);
+ gcc_assert (!sym->backend_decl);
+ gcc_assert (!sym->attr.external);
+
+ /* Set the line and filename. sym->declared_at seems to point to the
+ last statement for subroutines, but it'll do for now. */
+ gfc_set_backend_locus (&sym->declared_at);
/* Allow only one nesting level. Allow public declarations. */
- assert (current_function_decl == NULL_TREE
+ gcc_assert (current_function_decl == NULL_TREE
|| DECL_CONTEXT (current_function_decl) == NULL_TREE);
type = gfc_get_function_type (sym);
SET_DECL_ASSEMBLER_NAME (fndecl, gfc_sym_mangled_function_id (sym));
/* Figure out the return type of the declared function, and build a
- RESULT_DECL for it. If this is subroutine with alternate
+ RESULT_DECL for it. If this is a subroutine with alternate
returns, build a RESULT_DECL for it. */
attr = sym->attr;
}
result_decl = build_decl (RESULT_DECL, result_decl, type);
+ DECL_ARTIFICIAL (result_decl) = 1;
+ DECL_IGNORED_P (result_decl) = 1;
DECL_CONTEXT (result_decl) = fndecl;
DECL_RESULT (fndecl) = result_decl;
/* Don't call layout_decl for a RESULT_DECL.
- layout_decl (result_decl, 0); */
+ layout_decl (result_decl, 0); */
/* If the return type is a pointer, avoid alias issues by setting
DECL_IS_MALLOC to nonzero. This means that the function should be
DECL_CONTEXT (fndecl) = current_function_decl;
DECL_EXTERNAL (fndecl) = 0;
- /* This specifies if a function is globaly addressable, ie. it is
- the opposite of decalring static in C. */
- if (DECL_CONTEXT (fndecl) == NULL_TREE || attr.external)
+ /* This specifies if a function is globally visible, i.e. it is
+ the opposite of declaring static in C. */
+ if (DECL_CONTEXT (fndecl) == NULL_TREE
+ && !sym->attr.entry_master)
TREE_PUBLIC (fndecl) = 1;
/* TREE_STATIC means the function body is defined here. */
- if (!attr.external)
- TREE_STATIC (fndecl) = 1;
+ TREE_STATIC (fndecl) = 1;
- /* Set attributes for PURE functions. A call to PURE function in the
+ /* Set attributes for PURE functions. A call to a PURE function in the
Fortran 95 sense is both pure and without side effects in the C
sense. */
if (attr.pure || attr.elemental)
{
- DECL_IS_PURE (fndecl) = 1;
+ /* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
+ including a 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;
TREE_SIDE_EFFECTS (fndecl) = 0;
}
/* Layout the function declaration and put it in the binding level
of the current function. */
- if (!attr.external)
- {
- tree parm;
+ pushdecl (fndecl);
- pushdecl (fndecl);
- /* Build formal argument list. Make sure that their TREE_CONTEXT is
- the new FUNCTION_DECL node. */
- current_function_decl = fndecl;
- arglist = NULL_TREE;
- typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
- if (gfc_return_by_reference (sym))
- {
- type = TREE_VALUE (typelist);
- parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
+ sym->backend_decl = fndecl;
+}
- DECL_CONTEXT (parm) = fndecl;
- DECL_ARG_TYPE (parm) = type;
- TREE_READONLY (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
- arglist = chainon (arglist, parm);
- typelist = TREE_CHAIN (typelist);
+/* Create the DECL_ARGUMENTS for a procedure. */
- if (sym->ts.type == BT_CHARACTER)
- {
- gfc_allocate_lang_decl (parm);
+static void
+create_function_arglist (gfc_symbol * sym)
+{
+ tree fndecl;
+ gfc_formal_arglist *f;
+ tree typelist, hidden_typelist;
+ tree arglist, hidden_arglist;
+ tree type;
+ tree parm;
+
+ fndecl = sym->backend_decl;
+
+ /* Build formal argument list. Make sure that their TREE_CONTEXT is
+ the new FUNCTION_DECL node. */
+ arglist = NULL_TREE;
+ hidden_arglist = NULL_TREE;
+ typelist = TYPE_ARG_TYPES (TREE_TYPE (fndecl));
+
+ if (sym->attr.entry_master)
+ {
+ type = TREE_VALUE (typelist);
+ parm = build_decl (PARM_DECL, get_identifier ("__entry"), type);
+
+ DECL_CONTEXT (parm) = fndecl;
+ DECL_ARG_TYPE (parm) = type;
+ TREE_READONLY (parm) = 1;
+ gfc_finish_decl (parm, NULL_TREE);
+
+ arglist = chainon (arglist, parm);
+ typelist = TREE_CHAIN (typelist);
+ }
+
+ if (gfc_return_by_reference (sym))
+ {
+ tree type = TREE_VALUE (typelist), length = NULL;
- /* Length of character result */
- type = TREE_VALUE (typelist);
- assert (type == gfc_strlen_type_node);
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ /* Length of character result. */
+ tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
+ gcc_assert (len_type == gfc_charlen_type_node);
+
+ length = build_decl (PARM_DECL,
+ get_identifier (".__result"),
+ len_type);
+ if (!sym->ts.cl->length)
+ {
+ sym->ts.cl->backend_decl = length;
+ TREE_USED (length) = 1;
+ }
+ gcc_assert (TREE_CODE (length) == PARM_DECL);
+ DECL_CONTEXT (length) = fndecl;
+ DECL_ARG_TYPE (length) = len_type;
+ TREE_READONLY (length) = 1;
+ DECL_ARTIFICIAL (length) = 1;
+ gfc_finish_decl (length, NULL_TREE);
+ if (sym->ts.cl->backend_decl == NULL
+ || sym->ts.cl->backend_decl == length)
+ {
+ gfc_symbol *arg;
+ tree backend_decl;
- length = build_decl (PARM_DECL,
- get_identifier (".__result"),
- type);
- if (!sym->ts.cl->length)
+ if (sym->ts.cl->backend_decl == NULL)
{
- sym->ts.cl->backend_decl = length;
- TREE_USED (length) = 1;
+ tree len = build_decl (VAR_DECL,
+ get_identifier ("..__result"),
+ gfc_charlen_type_node);
+ DECL_ARTIFICIAL (len) = 1;
+ TREE_USED (len) = 1;
+ sym->ts.cl->backend_decl = len;
}
- assert (TREE_CODE (length) == PARM_DECL);
- arglist = chainon (arglist, length);
- typelist = TREE_CHAIN (typelist);
- DECL_CONTEXT (length) = fndecl;
- DECL_ARG_TYPE (length) = type;
- TREE_READONLY (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
+
+ /* Make sure PARM_DECL type doesn't point to incomplete type. */
+ arg = sym->result ? sym->result : sym;
+ backend_decl = arg->backend_decl;
+ /* Temporary clear it, so that gfc_sym_type creates complete
+ type. */
+ arg->backend_decl = NULL;
+ type = gfc_sym_type (arg);
+ arg->backend_decl = backend_decl;
+ type = build_reference_type (type);
}
}
- for (f = sym->formal; f; f = f->next)
- {
- if (f->sym != NULL) /* ignore alternate returns. */
- {
- length = NULL_TREE;
-
- type = TREE_VALUE (typelist);
+ parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
- /* Build a the argument declaration. */
- parm = build_decl (PARM_DECL,
- gfc_sym_identifier (f->sym), type);
+ DECL_CONTEXT (parm) = fndecl;
+ DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+ TREE_READONLY (parm) = 1;
+ DECL_ARTIFICIAL (parm) = 1;
+ gfc_finish_decl (parm, NULL_TREE);
- /* Fill in arg stuff. */
- DECL_CONTEXT (parm) = fndecl;
- DECL_ARG_TYPE (parm) = type;
- DECL_ARG_TYPE_AS_WRITTEN (parm) = type;
- /* All implementation args are read-only. */
- TREE_READONLY (parm) = 1;
+ arglist = chainon (arglist, parm);
+ typelist = TREE_CHAIN (typelist);
- gfc_finish_decl (parm, NULL_TREE);
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_allocate_lang_decl (parm);
+ arglist = chainon (arglist, length);
+ typelist = TREE_CHAIN (typelist);
+ }
+ }
- f->sym->backend_decl = parm;
+ hidden_typelist = typelist;
+ for (f = sym->formal; f; f = f->next)
+ if (f->sym != NULL) /* Ignore alternate returns. */
+ hidden_typelist = TREE_CHAIN (hidden_typelist);
- arglist = chainon (arglist, parm);
- typelist = TREE_CHAIN (typelist);
- }
- }
+ for (f = sym->formal; f; f = f->next)
+ {
+ char name[GFC_MAX_SYMBOL_LEN + 2];
- /* Add the hidden string length parameters. */
- parm = arglist;
- for (f = sym->formal; f; f = f->next)
- {
- char name[GFC_MAX_SYMBOL_LEN + 2];
- /* Ignore alternate returns. */
- if (f->sym == NULL)
- continue;
+ /* Ignore alternate returns. */
+ if (f->sym == NULL)
+ continue;
- if (f->sym->ts.type != BT_CHARACTER)
- continue;
+ type = TREE_VALUE (typelist);
- parm = f->sym->backend_decl;
- type = TREE_VALUE (typelist);
- assert (type == gfc_strlen_type_node);
+ if (f->sym->ts.type == BT_CHARACTER)
+ {
+ tree len_type = TREE_VALUE (hidden_typelist);
+ tree length = NULL_TREE;
+ gcc_assert (len_type == gfc_charlen_type_node);
- strcpy (&name[1], f->sym->name);
- name[0] = '_';
- length = build_decl (PARM_DECL, get_identifier (name), type);
+ strcpy (&name[1], f->sym->name);
+ name[0] = '_';
+ length = build_decl (PARM_DECL, get_identifier (name), len_type);
- arglist = chainon (arglist, length);
- DECL_CONTEXT (length) = fndecl;
- DECL_ARG_TYPE (length) = type;
- TREE_READONLY (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
+ hidden_arglist = chainon (hidden_arglist, length);
+ DECL_CONTEXT (length) = fndecl;
+ DECL_ARTIFICIAL (length) = 1;
+ DECL_ARG_TYPE (length) = len_type;
+ TREE_READONLY (length) = 1;
+ gfc_finish_decl (length, NULL_TREE);
/* TODO: Check string lengths when -fbounds-check. */
/* Use the passed value for assumed length variables. */
- if (!f->sym->ts.cl->length)
+ if (!f->sym->ts.cl->length)
{
TREE_USED (length) = 1;
- f->sym->ts.cl->backend_decl = length;
+ 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;
+ }
}
- parm = TREE_CHAIN (parm);
- typelist = TREE_CHAIN (typelist);
- }
-
- assert (TREE_VALUE (typelist) == void_type_node);
- DECL_ARGUMENTS (fndecl) = arglist;
+ hidden_typelist = TREE_CHAIN (hidden_typelist);
- /* Restore the old context. */
- current_function_decl = DECL_CONTEXT (fndecl);
- }
- sym->backend_decl = fndecl;
-}
+ if (f->sym->ts.cl->backend_decl == NULL
+ || f->sym->ts.cl->backend_decl == length)
+ {
+ if (f->sym->ts.cl->backend_decl == NULL)
+ gfc_create_string_length (f->sym);
+ /* Make sure PARM_DECL type doesn't point to incomplete type. */
+ if (f->sym->attr.flavor == FL_PROCEDURE)
+ type = build_pointer_type (gfc_get_function_type (f->sym));
+ else
+ type = gfc_sym_type (f->sym);
+ }
+ }
-/* Return the decl used to hold the function return value. */
+ /* For non-constant length array arguments, make sure they use
+ a different type node from TYPE_ARG_TYPES type. */
+ if (f->sym->attr.dimension
+ && type == TREE_VALUE (typelist)
+ && TREE_CODE (type) == POINTER_TYPE
+ && GFC_ARRAY_TYPE_P (type)
+ && f->sym->as->type != AS_ASSUMED_SIZE
+ && ! COMPLETE_TYPE_P (TREE_TYPE (type)))
+ {
+ if (f->sym->attr.flavor == FL_PROCEDURE)
+ type = build_pointer_type (gfc_get_function_type (f->sym));
+ else
+ type = gfc_sym_type (f->sym);
+ }
-tree
-gfc_get_fake_result_decl (gfc_symbol * sym)
-{
- tree decl;
- tree length;
+ /* Build a the argument declaration. */
+ parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
- char name[GFC_MAX_SYMBOL_LEN + 10];
+ /* Fill in arg stuff. */
+ DECL_CONTEXT (parm) = fndecl;
+ DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
+ /* All implementation args are read-only. */
+ TREE_READONLY (parm) = 1;
- if (current_fake_result_decl != NULL_TREE)
- return current_fake_result_decl;
+ gfc_finish_decl (parm, NULL_TREE);
- /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
- sym is NULL. */
- if (!sym)
- return NULL_TREE;
+ f->sym->backend_decl = parm;
- if (sym->ts.type == BT_CHARACTER
- && !sym->ts.cl->backend_decl)
- {
- length = gfc_create_string_length (sym);
- gfc_finish_var_decl (length, sym);
+ arglist = chainon (arglist, parm);
+ typelist = TREE_CHAIN (typelist);
}
- if (gfc_return_by_reference (sym))
- {
- decl = DECL_ARGUMENTS (sym->backend_decl);
-
- TREE_USED (decl) = 1;
- if (sym->as)
- decl = gfc_build_dummy_array_decl (sym, decl);
- }
- else
- {
- sprintf (name, "__result_%.20s",
- IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
+ /* Add the hidden string length parameters. */
+ arglist = chainon (arglist, hidden_arglist);
- decl = build_decl (VAR_DECL, get_identifier (name),
- TREE_TYPE (TREE_TYPE (current_function_decl)));
+ gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
+ DECL_ARGUMENTS (fndecl) = arglist;
+}
- DECL_ARTIFICIAL (decl) = 1;
- DECL_EXTERNAL (decl) = 0;
- TREE_PUBLIC (decl) = 0;
- TREE_USED (decl) = 1;
+/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
- layout_decl (decl, 0);
+static void
+gfc_gimplify_function (tree fndecl)
+{
+ struct cgraph_node *cgn;
- gfc_add_decl_to_function (decl);
- }
+ gimplify_function_tree (fndecl);
+ dump_function (TDI_generic, fndecl);
- current_fake_result_decl = decl;
+ /* Generate errors for structured block violations. */
+ /* ??? Could be done as part of resolve_labels. */
+ if (flag_openmp)
+ diagnose_omp_structured_block_errors (fndecl);
- return decl;
+ /* Convert all nested functions to GIMPLE now. We do things in this order
+ so that items like VLA sizes are expanded properly in the context of the
+ correct function. */
+ cgn = cgraph_node (fndecl);
+ for (cgn = cgn->nested; cgn; cgn = cgn->next_nested)
+ gfc_gimplify_function (cgn->decl);
}
-/* Builds a function decl. The remaining parameters are the types of the
- function arguments. Negative nargs indicates a varargs function. */
+/* Do the setup necessary before generating the body of a function. */
-tree
-gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
+static void
+trans_function_start (gfc_symbol * sym)
{
- tree arglist;
- tree argtype;
- tree fntype;
tree fndecl;
- va_list p;
- int n;
-
- /* Library functions must be declared with global scope. */
- assert (current_function_decl == NULL_TREE);
- va_start (p, nargs);
+ fndecl = sym->backend_decl;
+ /* Let GCC know the current scope is this function. */
+ current_function_decl = fndecl;
- /* Create a list of the argument types. */
- for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
- {
- argtype = va_arg (p, tree);
- arglist = gfc_chainon_list (arglist, argtype);
- }
+ /* Let the world know what we're about to do. */
+ announce_function (fndecl);
- if (nargs >= 0)
+ if (DECL_CONTEXT (fndecl) == NULL_TREE)
{
- /* Terminate the list. */
- arglist = gfc_chainon_list (arglist, void_type_node);
+ /* Create RTL for function declaration. */
+ rest_of_decl_compilation (fndecl, 1, 0);
}
- /* Build the function type and decl. */
- fntype = build_function_type (rettype, arglist);
- fndecl = build_decl (FUNCTION_DECL, name, fntype);
+ /* Create RTL for function definition. */
+ make_decl_rtl (fndecl);
- /* Mark this decl as external. */
- DECL_EXTERNAL (fndecl) = 1;
- TREE_PUBLIC (fndecl) = 1;
+ init_function_start (fndecl);
- va_end (p);
+ /* Even though we're inside a function body, we still don't want to
+ 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;
+
+ /* function.c requires a push at the start of the function. */
+ pushlevel (0);
+}
+
+/* Create thunks for alternate entry points. */
+
+static void
+build_entry_thunks (gfc_namespace * ns)
+{
+ gfc_formal_arglist *formal;
+ gfc_formal_arglist *thunk_formal;
+ gfc_entry_list *el;
+ gfc_symbol *thunk_sym;
+ stmtblock_t body;
+ tree thunk_fndecl;
+ tree args;
+ tree string_args;
+ tree tmp;
+ locus old_loc;
+
+ /* This should always be a toplevel function. */
+ gcc_assert (current_function_decl == NULL_TREE);
+
+ gfc_get_backend_locus (&old_loc);
+ for (el = ns->entries; el; el = el->next)
+ {
+ thunk_sym = el->sym;
+
+ build_function_decl (thunk_sym);
+ create_function_arglist (thunk_sym);
+
+ trans_function_start (thunk_sym);
+
+ thunk_fndecl = thunk_sym->backend_decl;
+
+ gfc_start_block (&body);
+
+ /* Pass extra parameter identifying this entry point. */
+ tmp = build_int_cst (gfc_array_index_type, el->id);
+ args = tree_cons (NULL_TREE, tmp, NULL_TREE);
+ string_args = NULL_TREE;
+
+ if (thunk_sym->attr.function)
+ {
+ if (gfc_return_by_reference (ns->proc_name))
+ {
+ tree ref = DECL_ARGUMENTS (current_function_decl);
+ args = tree_cons (NULL_TREE, ref, args);
+ if (ns->proc_name->ts.type == BT_CHARACTER)
+ args = tree_cons (NULL_TREE, TREE_CHAIN (ref),
+ args);
+ }
+ }
+
+ for (formal = ns->proc_name->formal; formal; formal = formal->next)
+ {
+ /* Ignore alternate returns. */
+ if (formal->sym == NULL)
+ continue;
+
+ /* We don't have a clever way of identifying arguments, so resort to
+ a brute-force search. */
+ for (thunk_formal = thunk_sym->formal;
+ thunk_formal;
+ thunk_formal = thunk_formal->next)
+ {
+ if (thunk_formal->sym == formal->sym)
+ break;
+ }
+
+ if (thunk_formal)
+ {
+ /* Pass the argument. */
+ args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
+ args);
+ if (formal->sym->ts.type == BT_CHARACTER)
+ {
+ tmp = thunk_formal->sym->ts.cl->backend_decl;
+ string_args = tree_cons (NULL_TREE, tmp, string_args);
+ }
+ }
+ else
+ {
+ /* Pass NULL for a missing argument. */
+ args = tree_cons (NULL_TREE, null_pointer_node, args);
+ if (formal->sym->ts.type == BT_CHARACTER)
+ {
+ tmp = convert (gfc_charlen_type_node, integer_zero_node);
+ string_args = tree_cons (NULL_TREE, tmp, string_args);
+ }
+ }
+ }
+
+ /* Call the master function. */
+ args = nreverse (args);
+ args = chainon (args, nreverse (string_args));
+ tmp = ns->proc_name->backend_decl;
+ tmp = build_function_call_expr (tmp, args);
+ if (ns->proc_name->attr.mixed_entry_master)
+ {
+ tree union_decl, field;
+ tree master_type = TREE_TYPE (ns->proc_name->backend_decl);
+
+ union_decl = build_decl (VAR_DECL, get_identifier ("__result"),
+ TREE_TYPE (master_type));
+ DECL_ARTIFICIAL (union_decl) = 1;
+ DECL_EXTERNAL (union_decl) = 0;
+ TREE_PUBLIC (union_decl) = 0;
+ TREE_USED (union_decl) = 1;
+ layout_decl (union_decl, 0);
+ pushdecl (union_decl);
+
+ DECL_CONTEXT (union_decl) = current_function_decl;
+ tmp = 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));
+ field; field = TREE_CHAIN (field))
+ if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
+ 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 = 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 = build1_v (RETURN_EXPR, tmp);
+ }
+ gfc_add_expr_to_block (&body, tmp);
+
+ /* Finish off this function and send it for code generation. */
+ DECL_SAVED_TREE (thunk_fndecl) = gfc_finish_block (&body);
+ poplevel (1, 0, 1);
+ BLOCK_SUPERCONTEXT (DECL_INITIAL (thunk_fndecl)) = thunk_fndecl;
+
+ /* Output the GENERIC tree. */
+ dump_function (TDI_original, thunk_fndecl);
+
+ /* Store the end of the function, so that we get good line number
+ info for the epilogue. */
+ cfun->function_end_locus = input_location;
+
+ /* 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;
+
+ current_function_decl = NULL_TREE;
+
+ gfc_gimplify_function (thunk_fndecl);
+ cgraph_finalize_function (thunk_fndecl, false);
+
+ /* We share the symbols in the formal argument list with other entry
+ points and the master function. Clear them so that they are
+ recreated for each function. */
+ for (formal = thunk_sym->formal; formal; formal = formal->next)
+ if (formal->sym != NULL) /* Ignore alternate returns. */
+ {
+ formal->sym->backend_decl = NULL_TREE;
+ if (formal->sym->ts.type == BT_CHARACTER)
+ formal->sym->ts.cl->backend_decl = NULL_TREE;
+ }
+
+ if (thunk_sym->attr.function)
+ {
+ if (thunk_sym->ts.type == BT_CHARACTER)
+ thunk_sym->ts.cl->backend_decl = NULL_TREE;
+ if (thunk_sym->result->ts.type == BT_CHARACTER)
+ thunk_sym->result->ts.cl->backend_decl = NULL_TREE;
+ }
+ }
+
+ gfc_set_backend_locus (&old_loc);
+}
+
+
+/* Create a decl for a function, and create any thunks for alternate entry
+ points. */
+
+void
+gfc_create_function_decl (gfc_namespace * ns)
+{
+ /* Create a declaration for the master function. */
+ build_function_decl (ns->proc_name);
+
+ /* Compile the entry thunks. */
+ if (ns->entries)
+ build_entry_thunks (ns);
+
+ /* Now create the read argument list. */
+ create_function_arglist (ns->proc_name);
+}
+
+/* Return the decl used to hold the function return value. If
+ parent_flag is set, the context is the parent_scope*/
+
+tree
+gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
+{
+ tree decl;
+ tree length;
+ tree this_fake_result_decl;
+ tree this_function_decl;
+
+ char name[GFC_MAX_SYMBOL_LEN + 10];
+
+ if (parent_flag)
+ {
+ this_fake_result_decl = parent_fake_result_decl;
+ this_function_decl = DECL_CONTEXT (current_function_decl);
+ }
+ else
+ {
+ this_fake_result_decl = current_fake_result_decl;
+ this_function_decl = current_function_decl;
+ }
+
+ if (sym
+ && sym->ns->proc_name->backend_decl == this_function_decl
+ && sym->ns->proc_name->attr.entry_master
+ && sym != sym->ns->proc_name)
+ {
+ tree t = NULL, var;
+ if (this_fake_result_decl != NULL)
+ for (t = TREE_CHAIN (this_fake_result_decl); t; t = TREE_CHAIN (t))
+ if (strcmp (IDENTIFIER_POINTER (TREE_PURPOSE (t)), sym->name) == 0)
+ break;
+ if (t)
+ return TREE_VALUE (t);
+ decl = gfc_get_fake_result_decl (sym->ns->proc_name, parent_flag);
+
+ if (parent_flag)
+ this_fake_result_decl = parent_fake_result_decl;
+ else
+ this_fake_result_decl = current_fake_result_decl;
+
+ if (decl && sym->ns->proc_name->attr.mixed_entry_master)
+ {
+ tree field;
+
+ for (field = TYPE_FIELDS (TREE_TYPE (decl));
+ field; field = TREE_CHAIN (field))
+ if (strcmp (IDENTIFIER_POINTER (DECL_NAME (field)),
+ sym->name) == 0)
+ break;
+
+ gcc_assert (field != NULL_TREE);
+ decl = build3 (COMPONENT_REF, TREE_TYPE (field), decl, field,
+ NULL_TREE);
+ }
+
+ var = create_tmp_var_raw (TREE_TYPE (decl), sym->name);
+ if (parent_flag)
+ gfc_add_decl_to_parent_function (var);
+ else
+ gfc_add_decl_to_function (var);
+
+ SET_DECL_VALUE_EXPR (var, decl);
+ DECL_HAS_VALUE_EXPR_P (var) = 1;
+ GFC_DECL_RESULT (var) = 1;
+
+ TREE_CHAIN (this_fake_result_decl)
+ = tree_cons (get_identifier (sym->name), var,
+ TREE_CHAIN (this_fake_result_decl));
+ return var;
+ }
+
+ if (this_fake_result_decl != NULL_TREE)
+ return TREE_VALUE (this_fake_result_decl);
+
+ /* Only when gfc_get_fake_result_decl is called by gfc_trans_return,
+ sym is NULL. */
+ if (!sym)
+ return NULL_TREE;
+
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ if (sym->ts.cl->backend_decl == NULL_TREE)
+ length = gfc_create_string_length (sym);
+ else
+ length = sym->ts.cl->backend_decl;
+ if (TREE_CODE (length) == VAR_DECL
+ && DECL_CONTEXT (length) == NULL_TREE)
+ gfc_add_decl_to_function (length);
+ }
+
+ if (gfc_return_by_reference (sym))
+ {
+ decl = DECL_ARGUMENTS (this_function_decl);
+
+ if (sym->ns->proc_name->backend_decl == this_function_decl
+ && sym->ns->proc_name->attr.entry_master)
+ decl = TREE_CHAIN (decl);
+
+ TREE_USED (decl) = 1;
+ if (sym->as)
+ decl = gfc_build_dummy_array_decl (sym, decl);
+ }
+ else
+ {
+ sprintf (name, "__result_%.20s",
+ IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
+
+ decl = build_decl (VAR_DECL, get_identifier (name),
+ TREE_TYPE (TREE_TYPE (this_function_decl)));
+
+ DECL_ARTIFICIAL (decl) = 1;
+ DECL_EXTERNAL (decl) = 0;
+ TREE_PUBLIC (decl) = 0;
+ TREE_USED (decl) = 1;
+ GFC_DECL_RESULT (decl) = 1;
+
+ layout_decl (decl, 0);
+
+ if (parent_flag)
+ gfc_add_decl_to_parent_function (decl);
+ else
+ gfc_add_decl_to_function (decl);
+ }
+
+ if (parent_flag)
+ parent_fake_result_decl = build_tree_list (NULL, decl);
+ else
+ current_fake_result_decl = build_tree_list (NULL, decl);
+
+ return decl;
+}
+
+
+/* Builds a function decl. The remaining parameters are the types of the
+ function arguments. Negative nargs indicates a varargs function. */
+
+tree
+gfc_build_library_function_decl (tree name, tree rettype, int nargs, ...)
+{
+ tree arglist;
+ tree argtype;
+ tree fntype;
+ tree fndecl;
+ va_list p;
+ int n;
+
+ /* Library functions must be declared with global scope. */
+ gcc_assert (current_function_decl == NULL_TREE);
+
+ va_start (p, nargs);
+
+
+ /* Create a list of the argument types. */
+ for (arglist = NULL_TREE, n = abs (nargs); n > 0; n--)
+ {
+ argtype = va_arg (p, tree);
+ arglist = gfc_chainon_list (arglist, argtype);
+ }
+
+ if (nargs >= 0)
+ {
+ /* Terminate the list. */
+ arglist = gfc_chainon_list (arglist, void_type_node);
+ }
+
+ /* Build the function type and decl. */
+ fntype = build_function_type (rettype, arglist);
+ fndecl = build_decl (FUNCTION_DECL, name, fntype);
+
+ /* Mark this decl as external. */
+ DECL_EXTERNAL (fndecl) = 1;
+ TREE_PUBLIC (fndecl) = 1;
+
+ va_end (p);
pushdecl (fndecl);
- rest_of_decl_compilation (fndecl, NULL, 1, 0);
+ rest_of_decl_compilation (fndecl, 1, 0);
return fndecl;
}
static void
gfc_build_intrinsic_function_decls (void)
{
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+ 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);
+
/* String functions. */
gfor_fndecl_copy_string =
gfc_build_library_function_decl (get_identifier (PREFIX("copy_string")),
void_type_node,
4,
- gfc_strlen_type_node, pchar_type_node,
- gfc_strlen_type_node, pchar_type_node);
+ gfc_charlen_type_node, pchar_type_node,
+ gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_compare_string =
gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
gfc_int4_type_node,
4,
- gfc_strlen_type_node, pchar_type_node,
- gfc_strlen_type_node, pchar_type_node);
+ gfc_charlen_type_node, pchar_type_node,
+ gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_concat_string =
gfc_build_library_function_decl (get_identifier (PREFIX("concat_string")),
void_type_node,
6,
- gfc_strlen_type_node, pchar_type_node,
- gfc_strlen_type_node, pchar_type_node,
- gfc_strlen_type_node, pchar_type_node);
+ gfc_charlen_type_node, pchar_type_node,
+ gfc_charlen_type_node, pchar_type_node,
+ gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_string_len_trim =
gfc_build_library_function_decl (get_identifier (PREFIX("string_len_trim")),
gfc_int4_type_node,
- 2, gfc_strlen_type_node,
+ 2, gfc_charlen_type_node,
pchar_type_node);
gfor_fndecl_string_index =
gfc_build_library_function_decl (get_identifier (PREFIX("string_index")),
gfc_int4_type_node,
- 5, gfc_strlen_type_node, pchar_type_node,
- gfc_strlen_type_node, pchar_type_node,
+ 5, gfc_charlen_type_node, pchar_type_node,
+ gfc_charlen_type_node, pchar_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_strlen_type_node, pchar_type_node,
- gfc_strlen_type_node, pchar_type_node,
+ 5, gfc_charlen_type_node, pchar_type_node,
+ gfc_charlen_type_node, pchar_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_strlen_type_node, pchar_type_node,
- gfc_strlen_type_node, pchar_type_node,
+ 5, gfc_charlen_type_node, pchar_type_node,
+ gfc_charlen_type_node, pchar_type_node,
gfc_logical4_type_node);
gfor_fndecl_string_trim =
gfc_build_library_function_decl (get_identifier (PREFIX("string_trim")),
void_type_node,
4,
- build_pointer_type (gfc_strlen_type_node),
+ build_pointer_type (gfc_charlen_type_node),
ppvoid_type_node,
- gfc_strlen_type_node,
+ gfc_charlen_type_node,
pchar_type_node);
gfor_fndecl_string_repeat =
void_type_node,
4,
pchar_type_node,
- gfc_strlen_type_node,
+ gfc_charlen_type_node,
pchar_type_node,
gfc_int4_type_node);
+ gfor_fndecl_ttynam =
+ gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
+ void_type_node,
+ 3,
+ pchar_type_node,
+ gfc_charlen_type_node,
+ gfc_c_int_type_node);
+
+ gfor_fndecl_fdate =
+ gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
+ void_type_node,
+ 2,
+ pchar_type_node,
+ gfc_charlen_type_node);
+
+ gfor_fndecl_ctime =
+ gfc_build_library_function_decl (get_identifier (PREFIX("ctime")),
+ void_type_node,
+ 3,
+ pchar_type_node,
+ 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_strlen_type_node, 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,
- gfc_strlen_type_node, pchar_type_node);
+ gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_si_kind =
gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
2, pvoid_type_node,
pvoid_type_node);
-
/* Power functions. */
- gfor_fndecl_math_powf =
- gfc_build_library_function_decl (get_identifier ("powf"),
- gfc_real4_type_node,
- 1, gfc_real4_type_node);
- gfor_fndecl_math_pow =
- gfc_build_library_function_decl (get_identifier ("pow"),
- gfc_real8_type_node,
- 1, gfc_real8_type_node);
+ {
+ tree ctype, rtype, itype, jtype;
+ int rkind, ikind, jkind;
+#define NIKINDS 3
+#define NRKINDS 4
+ static int ikinds[NIKINDS] = {4, 8, 16};
+ static int rkinds[NRKINDS] = {4, 8, 10, 16};
+ char name[PREFIX_LEN + 12]; /* _gfortran_pow_?n_?n */
+
+ for (ikind=0; ikind < NIKINDS; ikind++)
+ {
+ itype = gfc_get_int_type (ikinds[ikind]);
+
+ for (jkind=0; jkind < NIKINDS; jkind++)
+ {
+ jtype = gfc_get_int_type (ikinds[jkind]);
+ if (itype && jtype)
+ {
+ sprintf(name, PREFIX("pow_i%d_i%d"), ikinds[ikind],
+ ikinds[jkind]);
+ gfor_fndecl_math_powi[jkind][ikind].integer =
+ gfc_build_library_function_decl (get_identifier (name),
+ jtype, 2, jtype, itype);
+ }
+ }
+
+ for (rkind = 0; rkind < NRKINDS; rkind ++)
+ {
+ rtype = gfc_get_real_type (rkinds[rkind]);
+ if (rtype && itype)
+ {
+ sprintf(name, PREFIX("pow_r%d_i%d"), rkinds[rkind],
+ ikinds[ikind]);
+ gfor_fndecl_math_powi[rkind][ikind].real =
+ gfc_build_library_function_decl (get_identifier (name),
+ rtype, 2, rtype, itype);
+ }
+
+ ctype = gfc_get_complex_type (rkinds[rkind]);
+ if (ctype && itype)
+ {
+ sprintf(name, PREFIX("pow_c%d_i%d"), rkinds[rkind],
+ ikinds[ikind]);
+ gfor_fndecl_math_powi[rkind][ikind].cmplx =
+ gfc_build_library_function_decl (get_identifier (name),
+ ctype, 2,ctype, itype);
+ }
+ }
+ }
+#undef NIKINDS
+#undef NRKINDS
+ }
+
gfor_fndecl_math_cpowf =
gfc_build_library_function_decl (get_identifier ("cpowf"),
gfc_complex4_type_node,
gfc_build_library_function_decl (get_identifier ("cpow"),
gfc_complex8_type_node,
1, gfc_complex8_type_node);
- gfor_fndecl_math_cabsf =
- gfc_build_library_function_decl (get_identifier ("cabsf"),
- gfc_real4_type_node,
- 1, gfc_complex4_type_node);
- gfor_fndecl_math_cabs =
- gfc_build_library_function_decl (get_identifier ("cabs"),
- gfc_real8_type_node,
- 1, gfc_complex8_type_node);
- gfor_fndecl_math_sign4 =
- gfc_build_library_function_decl (get_identifier ("copysignf"),
- gfc_real4_type_node,
- 1, gfc_real4_type_node);
- gfor_fndecl_math_sign8 =
- gfc_build_library_function_decl (get_identifier ("copysign"),
- gfc_real8_type_node,
- 1, gfc_real8_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_build_library_function_decl (get_identifier (PREFIX("ishftc8")),
gfc_int8_type_node,
3, gfc_int8_type_node,
- gfc_int8_type_node, gfc_int8_type_node);
+ gfc_int4_type_node, gfc_int4_type_node);
+ if (gfc_int16_type_node)
+ gfor_fndecl_math_ishftc16 =
+ gfc_build_library_function_decl (get_identifier (PREFIX("ishftc16")),
+ gfc_int16_type_node, 3,
+ gfc_int16_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,
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);
/* Other functions. */
gfor_fndecl_size0 =
gfc_array_index_type,
2, pvoid_type_node,
gfc_array_index_type);
+
+ gfor_fndecl_iargc =
+ gfc_build_library_function_decl (get_identifier (PREFIX ("iargc")),
+ gfc_int4_type_node,
+ 0);
}
void
gfc_build_builtin_function_decls (void)
{
+ tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
+ tree gfc_int4_type_node = gfc_get_int_type (4);
+ tree gfc_int8_type_node = gfc_get_int_type (8);
+ tree gfc_logical4_type_node = gfc_get_logical_type (4);
+ tree gfc_pint4_type_node = build_pointer_type (gfc_int4_type_node);
+
+ /* Treat these two internal malloc wrappers as malloc. */
gfor_fndecl_internal_malloc =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_malloc")),
pvoid_type_node, 1, gfc_int4_type_node);
+ DECL_IS_MALLOC (gfor_fndecl_internal_malloc) = 1;
gfor_fndecl_internal_malloc64 =
gfc_build_library_function_decl (get_identifier
(PREFIX("internal_malloc64")),
pvoid_type_node, 1, gfc_int8_type_node);
+ DECL_IS_MALLOC (gfor_fndecl_internal_malloc64) = 1;
+
+ gfor_fndecl_internal_realloc =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("internal_realloc")),
+ pvoid_type_node, 2, pvoid_type_node,
+ gfc_int4_type_node);
+
+ gfor_fndecl_internal_realloc64 =
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("internal_realloc64")),
+ pvoid_type_node, 2, pvoid_type_node,
+ gfc_int8_type_node);
gfor_fndecl_internal_free =
gfc_build_library_function_decl (get_identifier (PREFIX("internal_free")),
void_type_node, 2, ppvoid_type_node,
gfc_int8_type_node);
+ gfor_fndecl_allocate_array =
+ gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
+ void_type_node, 2, ppvoid_type_node,
+ gfc_int4_type_node);
+
+ gfor_fndecl_allocate64_array =
+ gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
+ void_type_node, 2, ppvoid_type_node,
+ gfc_int8_type_node);
+
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
- void_type_node, 1, ppvoid_type_node);
+ void_type_node, 2, ppvoid_type_node,
+ gfc_pint4_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
void_type_node, 1, gfc_int4_type_node);
+ /* Stop doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
+
gfor_fndecl_stop_string =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_string")),
void_type_node, 2, pchar_type_node,
gfc_int4_type_node);
+ /* Stop doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_stop_string) = 1;
gfor_fndecl_pause_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("pause_numeric")),
3,
pchar_type_node, pchar_type_node,
gfc_int4_type_node);
+ /* The runtime_error function does not return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
+
+ gfor_fndecl_set_fpe =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_fpe")),
+ void_type_node, 1, gfc_c_int_type_node);
+
+ gfor_fndecl_set_std =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_std")),
+ void_type_node,
+ 3,
+ gfc_int4_type_node,
+ gfc_int4_type_node,
+ gfc_int4_type_node);
+
+ gfor_fndecl_set_convert =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
+ void_type_node, 1, gfc_c_int_type_node);
+
+ gfor_fndecl_set_record_marker =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
+ void_type_node, 1, gfc_c_int_type_node);
gfor_fndecl_in_pack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_pack")),
}
-/* Exaluate the length of dummy character variables. */
+/* Evaluate the length of dummy character variables. */
static tree
-gfc_trans_dummy_character (gfc_charlen * cl, tree fnbody)
+gfc_trans_dummy_character (gfc_symbol *sym, gfc_charlen *cl, tree fnbody)
{
stmtblock_t body;
/* Evaluate the string length expression. */
gfc_trans_init_string_length (cl, &body);
-
+
+ gfc_trans_vla_type_sizes (sym, &body);
+
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
{
stmtblock_t body;
tree decl;
- tree args;
tree tmp;
- assert (sym->backend_decl);
- assert (sym->ts.cl && sym->ts.cl->length);
+ gcc_assert (sym->backend_decl);
+ gcc_assert (sym->ts.cl && sym->ts.cl->length);
gfc_start_block (&body);
/* Evaluate the string length expression. */
gfc_trans_init_string_length (sym->ts.cl, &body);
- decl = sym->backend_decl;
+ gfc_trans_vla_type_sizes (sym, &body);
- DECL_DEFER_OUTPUT (decl) = 1;
+ decl = sym->backend_decl;
- /* Generate code to allocate the automatic variable. It will be freed
- automatically. */
- tmp = gfc_build_addr_expr (NULL, decl);
- args = gfc_chainon_list (NULL_TREE, tmp);
- args = gfc_chainon_list (args, sym->ts.cl->backend_decl);
- tmp = gfc_build_function_call (built_in_decls[BUILT_IN_STACK_ALLOC], args);
+ /* 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);
gfc_add_expr_to_block (&body, tmp);
+
gfc_add_expr_to_block (&body, fnbody);
return gfc_finish_block (&body);
}
+/* Set the initial value of ASSIGN statement auxiliary variable explicitly. */
+
+static tree
+gfc_trans_assign_aux_var (gfc_symbol * sym, tree fnbody)
+{
+ stmtblock_t body;
+
+ gcc_assert (sym->backend_decl);
+ gfc_start_block (&body);
+
+ /* 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),
+ build_int_cst (NULL_TREE, -2));
+
+ gfc_add_expr_to_block (&body, fnbody);
+ return gfc_finish_block (&body);
+}
+
+static void
+gfc_trans_vla_one_sizepos (tree *tp, stmtblock_t *body)
+{
+ tree t = *tp, var, val;
+
+ if (t == NULL || t == error_mark_node)
+ return;
+ if (TREE_CONSTANT (t) || DECL_P (t))
+ return;
+
+ if (TREE_CODE (t) == SAVE_EXPR)
+ {
+ if (SAVE_EXPR_RESOLVED_P (t))
+ {
+ *tp = TREE_OPERAND (t, 0);
+ return;
+ }
+ val = TREE_OPERAND (t, 0);
+ }
+ else
+ val = t;
+
+ var = gfc_create_var_np (TREE_TYPE (t), NULL);
+ gfc_add_decl_to_function (var);
+ gfc_add_modify_expr (body, var, val);
+ if (TREE_CODE (t) == SAVE_EXPR)
+ TREE_OPERAND (t, 0) = var;
+ *tp = var;
+}
+
+static void
+gfc_trans_vla_type_sizes_1 (tree type, stmtblock_t *body)
+{
+ tree t;
+
+ if (type == NULL || type == error_mark_node)
+ return;
+
+ type = TYPE_MAIN_VARIANT (type);
+
+ if (TREE_CODE (type) == INTEGER_TYPE)
+ {
+ gfc_trans_vla_one_sizepos (&TYPE_MIN_VALUE (type), body);
+ gfc_trans_vla_one_sizepos (&TYPE_MAX_VALUE (type), body);
+
+ for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+ {
+ TYPE_MIN_VALUE (t) = TYPE_MIN_VALUE (type);
+ TYPE_MAX_VALUE (t) = TYPE_MAX_VALUE (type);
+ }
+ }
+ else if (TREE_CODE (type) == ARRAY_TYPE)
+ {
+ gfc_trans_vla_type_sizes_1 (TREE_TYPE (type), body);
+ gfc_trans_vla_type_sizes_1 (TYPE_DOMAIN (type), body);
+ gfc_trans_vla_one_sizepos (&TYPE_SIZE (type), body);
+ gfc_trans_vla_one_sizepos (&TYPE_SIZE_UNIT (type), body);
+
+ for (t = TYPE_NEXT_VARIANT (type); t; t = TYPE_NEXT_VARIANT (t))
+ {
+ TYPE_SIZE (t) = TYPE_SIZE (type);
+ TYPE_SIZE_UNIT (t) = TYPE_SIZE_UNIT (type);
+ }
+ }
+}
+
+/* Make sure all type sizes and array domains are either constant,
+ or variable or parameter decls. This is a simplified variant
+ of gimplify_type_sizes, but we can't use it here, as none of the
+ variables in the expressions have been gimplified yet.
+ As type sizes and domains for various variable length arrays
+ contain VAR_DECLs that are only initialized at gfc_trans_deferred_vars
+ time, without this routine gimplify_type_sizes in the middle-end
+ could result in the type sizes being gimplified earlier than where
+ those variables are initialized. */
+
+void
+gfc_trans_vla_type_sizes (gfc_symbol *sym, stmtblock_t *body)
+{
+ tree type = TREE_TYPE (sym->backend_decl);
+
+ if (TREE_CODE (type) == FUNCTION_TYPE
+ && (sym->attr.function || sym->attr.result || sym->attr.entry))
+ {
+ if (! current_fake_result_decl)
+ return;
+
+ type = TREE_TYPE (TREE_VALUE (current_fake_result_decl));
+ }
+
+ while (POINTER_TYPE_P (type))
+ type = TREE_TYPE (type);
+
+ if (GFC_DESCRIPTOR_TYPE_P (type))
+ {
+ tree etype = GFC_TYPE_ARRAY_DATAPTR_TYPE (type);
+
+ while (POINTER_TYPE_P (etype))
+ etype = TREE_TYPE (etype);
+
+ gfc_trans_vla_type_sizes_1 (etype, body);
+ }
+
+ gfc_trans_vla_type_sizes_1 (type, body);
+}
+
/* Generate function entry and exit code, and add it to the function body.
This includes:
- Allocation and initialisation of array variables.
+ Allocation and initialization of array variables.
Allocation of character string variables.
- Initialization and possibly repacking of dummy arrays. */
+ Initialization and possibly repacking of dummy arrays.
+ Initialization of ASSIGN statement auxiliary variable. */
static tree
gfc_trans_deferred_vars (gfc_symbol * proc_sym, tree fnbody)
{
locus loc;
gfc_symbol *sym;
+ gfc_formal_arglist *f;
+ stmtblock_t body;
/* Deal with implicit return variables. Explicit return variables will
already have been added. */
{
if (!current_fake_result_decl)
{
- warning ("Function does not return a value");
- return fnbody;
+ gfc_entry_list *el = NULL;
+ if (proc_sym->attr.entry_master)
+ {
+ for (el = proc_sym->ns->entries; el; el = el->next)
+ if (el->sym != el->sym->result)
+ break;
+ }
+ if (el == NULL)
+ warning (0, "Function does not return a value");
}
-
- if (proc_sym->as)
+ else if (proc_sym->as)
{
- fnbody = gfc_trans_dummy_array_bias (proc_sym,
- current_fake_result_decl,
- fnbody);
+ tree result = TREE_VALUE (current_fake_result_decl);
+ fnbody = gfc_trans_dummy_array_bias (proc_sym, result, fnbody);
+
+ /* An automatic character length, pointer array result. */
+ if (proc_sym->ts.type == BT_CHARACTER
+ && TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+ fnbody);
}
else if (proc_sym->ts.type == BT_CHARACTER)
{
if (TREE_CODE (proc_sym->ts.cl->backend_decl) == VAR_DECL)
- fnbody = gfc_trans_dummy_character (proc_sym->ts.cl, fnbody);
+ fnbody = gfc_trans_dummy_character (proc_sym, proc_sym->ts.cl,
+ fnbody);
}
else
- gfc_todo_error ("Deferred non-array return by reference");
+ gcc_assert (gfc_option.flag_f2c
+ && proc_sym->ts.type == BT_COMPLEX);
}
for (sym = proc_sym->tlink; sym != proc_sym; sym = sym->tlink)
case AS_ASSUMED_SIZE:
/* Must be a dummy parameter. */
- assert (sym->attr.dummy);
+ gcc_assert (sym->attr.dummy);
/* We should always pass assumed size arrays the g77 way. */
- assert (TREE_CODE (sym->backend_decl) == PARM_DECL);
fnbody = gfc_trans_g77_array (sym, fnbody);
break;
case AS_ASSUMED_SHAPE:
/* Must be a dummy parameter. */
- assert (sym->attr.dummy);
+ gcc_assert (sym->attr.dummy);
fnbody = gfc_trans_dummy_array_bias (sym, sym->backend_decl,
fnbody);
break;
default:
- abort ();
+ gcc_unreachable ();
}
}
else if (sym->ts.type == BT_CHARACTER)
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
if (sym->attr.dummy || sym->attr.result)
- fnbody = gfc_trans_dummy_character (sym->ts.cl, fnbody);
+ fnbody = gfc_trans_dummy_character (sym, sym->ts.cl, fnbody);
else
fnbody = gfc_trans_auto_character_variable (sym, fnbody);
gfc_set_backend_locus (&loc);
}
+ else if (sym->attr.assign)
+ {
+ 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
- abort ();
+ 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 (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
+ && current_fake_result_decl != NULL)
+ {
+ gcc_assert (proc_sym->ts.cl->backend_decl != NULL);
+ if (TREE_CODE (proc_sym->ts.cl->backend_decl) == PARM_DECL)
+ gfc_trans_vla_type_sizes (proc_sym, &body);
}
- return fnbody;
+ gfc_add_expr_to_block (&body, fnbody);
+ return gfc_finish_block (&body);
}
gfc_create_module_variable (gfc_symbol * sym)
{
tree decl;
- gfc_se se;
/* Only output symbols from this module. */
if (sym->ns != module_namespace)
internal_error ("module symbol %s in wrong namespace", sym->name);
}
- /* Don't ouptut symbols from common blocks. */
- if (sym->attr.common)
- return;
-
- /* Only output variables and array valued parametes. */
+ /* Only output variables and array valued parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
return;
- /* Don't generate variables from other modules. */
- if (sym->attr.use_assoc)
+ /* Don't generate variables from other modules. Variables from
+ COMMONs will already have been generated. */
+ if (sym->attr.use_assoc || sym->attr.in_common)
return;
+ /* Equivalenced variables arrive here after creation. */
+ if (sym->backend_decl
+ && (sym->equiv_built || sym->attr.in_equivalence))
+ return;
+
if (sym->backend_decl)
internal_error ("backend decl for module variable %s already exists",
sym->name);
/* Create the decl. */
decl = gfc_get_symbol_decl (sym);
- /* We want to allocate storage for this variable. */
- TREE_STATIC (decl) = 1;
-
- if (sym->attr.dimension)
- {
- assert (sym->attr.pointer || sym->attr.allocatable
- || GFC_ARRAY_TYPE_P (TREE_TYPE (sym->backend_decl)));
- if (sym->attr.pointer || sym->attr.allocatable)
- gfc_trans_static_array_pointer (sym);
- else
- gfc_trans_auto_array_allocation (sym->backend_decl, sym, NULL_TREE);
- }
- else if (sym->ts.type == BT_DERIVED)
- {
- if (sym->value)
- gfc_todo_error ("Initialization of derived type module variables");
- }
- else
- {
- if (sym->value)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_constant (&se, sym->value);
- DECL_INITIAL (decl) = se.expr;
- }
- }
-
/* Create the variable. */
pushdecl (decl);
- rest_of_decl_compilation (decl, NULL, 1, 0);
+ rest_of_decl_compilation (decl, 1, 0);
/* Also add length of strings. */
if (sym->ts.type == BT_CHARACTER)
if (!INTEGER_CST_P (length))
{
pushdecl (length);
- rest_of_decl_compilation (length, NULL, 1, 0);
+ rest_of_decl_compilation (length, 1, 0);
}
}
}
{
module_namespace = ns;
- /* Check the frontend left the namespace in a reasonable state. */
- assert (ns->proc_name && !ns->proc_name->tlink);
+ /* Check if the frontend left the namespace in a reasonable state. */
+ gcc_assert (ns->proc_name && !ns->proc_name->tlink);
+
+ /* Generate COMMON blocks. */
+ gfc_trans_common (ns);
- /* Create decls for all the module varuiables. */
+ /* Create decls for all the module variables. */
gfc_traverse_ns (ns, gfc_create_module_variable);
}
if (ns->parent != parent)
continue;
- gfc_build_function_decl (ns->proc_name);
+ gfc_create_function_decl (ns);
}
for (ns = parent->contained; ns; ns = ns->sibling)
{
if (sym->attr.flavor == FL_VARIABLE)
{
- /* TODO: The frontend sometimes creates symbols for things which don't
- actually exist. E.g. common block names and the names of formal
- arguments. The latter are created while attempting to parse
- the argument list as a substring reference.
-
- The proper fix is to avoid adding these symbols in the first place.
- For now we hack round it by ignoring anything with an unknown type.
- */
- if (sym->ts.type == BT_UNKNOWN)
- return;
-
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
- else if (sym->attr.dummy)
- {
- if (warn_unused_parameter)
- warning ("unused parameter `%s'", sym->name);
- }
- /* warn for unused variables, but not if they're inside a common
- block. */
- else if (warn_unused_variable && !sym->attr.in_common)
- warning ("unused variable `%s'", sym->name);
+ else if (sym->attr.dummy && warn_unused_parameter)
+ warning (0, "unused parameter %qs", sym->name);
+ /* Warn for unused variables, but not if they're inside a common
+ block or are use-associated. */
+ else if (warn_unused_variable
+ && !(sym->attr.in_common || sym->attr.use_assoc))
+ warning (0, "unused variable %qs", sym->name);
+ /* For variable length CHARACTER parameters, the PARM_DECL already
+ references the length variable, so force gfc_get_symbol_decl
+ even when not referenced. If optimize > 0, it will be optimized
+ away anyway. But do this only after emitting -Wunused-parameter
+ warning if requested. */
+ if (sym->attr.dummy && ! sym->attr.referenced
+ && sym->ts.type == BT_CHARACTER
+ && sym->ts.cl->backend_decl != NULL
+ && TREE_CODE (sym->ts.cl->backend_decl) == VAR_DECL)
+ {
+ sym->attr.referenced = 1;
+ gfc_get_symbol_decl (sym);
+ }
}
}
}
-/* Finalize DECL and all nested functions with cgraph. */
+/* Generate a switch statement to jump to the correct entry point. Also
+ creates the label decls for the entry points. */
-static void
-gfc_finalize (tree decl)
+static tree
+gfc_trans_entry_master_switch (gfc_entry_list * el)
{
- struct cgraph_node *cgn;
-
- cgn = cgraph_node (decl);
- for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
- gfc_finalize (cgn->decl);
+ stmtblock_t block;
+ tree label;
+ tree tmp;
+ tree val;
- cgraph_finalize_function (decl, false);
+ gfc_init_block (&block);
+ for (; el; el = el->next)
+ {
+ /* Add the case label. */
+ label = gfc_build_label_decl (NULL_TREE);
+ 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_add_expr_to_block (&block, tmp);
+
+ /* Save the label decl. */
+ el->label = label;
+ }
+ tmp = gfc_finish_block (&block);
+ /* The first argument selects the entry point. */
+ val = DECL_ARGUMENTS (current_function_decl);
+ tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
+ return tmp;
}
+
/* Generate code for a function. */
void
gfc_symbol *sym;
sym = ns->proc_name;
- /* Check that the frontend isn't still using this. */
- assert (sym->tlink == NULL);
+ /* Check that the frontend isn't still using this. */
+ gcc_assert (sym->tlink == NULL);
sym->tlink = sym;
/* Create the declaration for functions with global scope. */
if (!sym->backend_decl)
- gfc_build_function_decl (ns->proc_name);
+ gfc_create_function_decl (ns);
fndecl = sym->backend_decl;
old_context = current_function_decl;
saved_function_decls = NULL_TREE;
}
- /* let GCC know the current scope is this function */
- current_function_decl = fndecl;
+ trans_function_start (sym);
- /* print function name on the console at compile time
- (unless this feature was switched of by command line option "-quiet" */
- announce_function (fndecl);
+ gfc_start_block (&block);
- if (DECL_CONTEXT (fndecl) == NULL_TREE)
+ if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
{
- /* create RTL for function declaration */
- rest_of_decl_compilation (fndecl, NULL, 1, 0);
+ /* Copy length backend_decls to all entry point result
+ symbols. */
+ gfc_entry_list *el;
+ tree backend_decl;
+
+ gfc_conv_const_charlen (ns->proc_name->ts.cl);
+ backend_decl = ns->proc_name->result->ts.cl->backend_decl;
+ for (el = ns->entries; el; el = el->next)
+ el->sym->result->ts.cl->backend_decl = backend_decl;
}
- /* create RTL for function definition */
- make_decl_rtl (fndecl, NULL);
+ /* Translate COMMON blocks. */
+ gfc_trans_common (ns);
- /* Set the line and filename. sym->decalred_at seems to point to the last
- statement for subroutines, but it'll do for now. */
- gfc_set_backend_locus (&sym->declared_at);
+ /* Null the parent fake result declaration if this namespace is
+ a module function or an external procedures. */
+ if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
+ || ns->parent == NULL)
+ parent_fake_result_decl = NULL_TREE;
- /* line and file should not be 0 */
- init_function_start (fndecl);
+ gfc_generate_contained_functions (ns);
- /* We're in function-at-a-time mode. */
- cfun->x_whole_function_mode_p = 1;
+ 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)
+ || ns->parent == NULL)
+ current_fake_result_decl = parent_fake_result_decl;
+ else
+ current_fake_result_decl = NULL_TREE;
- /* Even though we're inside a function body, we still don't want to
- 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. */
- immediate_size_expand = 0;
- cfun->x_dont_save_pending_sizes_p = 1;
+ current_function_return_label = NULL;
- /* Will be created as needed. */
- current_fake_result_decl = NULL_TREE;
+ /* Now generate the code for the body of this function. */
+ gfc_init_block (&body);
- /* function.c requires a push at the start of the function */
- pushlevel (0);
+ /* If this is the main program, add a call to set_std to set up the
+ runtime library Fortran language standard parameters. */
- gfc_start_block (&block);
+ if (sym->attr.is_main_program)
+ {
+ tree arglist, gfc_int4_type_node;
+
+ gfc_int4_type_node = gfc_get_int_type (4);
+ arglist = gfc_chainon_list (NULL_TREE,
+ build_int_cst (gfc_int4_type_node,
+ gfc_option.warn_std));
+ arglist = gfc_chainon_list (arglist,
+ build_int_cst (gfc_int4_type_node,
+ gfc_option.allow_std));
+ arglist = gfc_chainon_list (arglist,
+ build_int_cst (gfc_int4_type_node,
+ pedantic));
+ tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
+ gfc_add_expr_to_block (&body, tmp);
+ }
- gfc_generate_contained_functions (ns);
+ /* If this is the main program and a -ffpe-trap option was provided,
+ add a call to set_fpe so that the library will raise a FPE when
+ needed. */
+ if (sym->attr.is_main_program && gfc_option.fpe != 0)
+ {
+ tree arglist, gfc_c_int_type_node;
- /* Translate COMMON blocks. */
- gfc_trans_common (ns);
+ gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
+ arglist = gfc_chainon_list (NULL_TREE,
+ build_int_cst (gfc_c_int_type_node,
+ gfc_option.fpe));
+ tmp = build_function_call_expr (gfor_fndecl_set_fpe, arglist);
+ gfc_add_expr_to_block (&body, tmp);
+ }
- generate_local_vars (ns);
+ /* If this is the main program and an -fconvert option was provided,
+ add a call to set_convert. */
- current_function_return_label = NULL;
+ if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
+ {
+ tree arglist, gfc_c_int_type_node;
- /* Now generate the code for the body of this function. */
- gfc_init_block (&body);
+ gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
+ arglist = gfc_chainon_list (NULL_TREE,
+ build_int_cst (gfc_c_int_type_node,
+ gfc_option.convert));
+ tmp = build_function_call_expr (gfor_fndecl_set_convert, arglist);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* If this is the main program and an -frecord-marker option was provided,
+ add a call to set_record_marker. */
+
+ if (sym->attr.is_main_program && gfc_option.record_marker != 0)
+ {
+ tree arglist, gfc_c_int_type_node;
+
+ gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
+ arglist = gfc_chainon_list (NULL_TREE,
+ build_int_cst (gfc_c_int_type_node,
+ gfc_option.record_marker));
+ tmp = build_function_call_expr (gfor_fndecl_set_record_marker, arglist);
+ gfc_add_expr_to_block (&body, tmp);
+
+ }
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node
&& sym->attr.subroutine)
{
tree alternate_return;
- alternate_return = gfc_get_fake_result_decl (sym);
+ alternate_return = gfc_get_fake_result_decl (sym, 0);
gfc_add_modify_expr (&body, alternate_return, integer_zero_node);
}
+ if (ns->entries)
+ {
+ /* Jump to the correct entry point. */
+ tmp = gfc_trans_entry_master_switch (ns->entries);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
tmp = gfc_trans_code (ns->code);
gfc_add_expr_to_block (&body, tmp);
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
- if (sym->attr.subroutine ||sym == sym->result)
+ if (sym->attr.subroutine || sym == sym->result)
{
- result = current_fake_result_decl;
+ if (current_fake_result_decl != NULL)
+ result = TREE_VALUE (current_fake_result_decl);
+ else
+ result = NULL_TREE;
current_fake_result_decl = NULL_TREE;
}
else
result = sym->result->backend_decl;
if (result == NULL_TREE)
- warning ("Function return value not set");
+ warning (0, "Function return value not set");
else
{
- /* Set the return value to the the dummy result variable. */
- tmp = build (MODIFY_EXPR, TREE_TYPE (result),
- DECL_RESULT (fndecl), result);
- tmp = build_v (RETURN_EXPR, tmp);
+ /* Set the return value to the dummy result variable. */
+ tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
+ DECL_RESULT (fndecl), result);
+ tmp = build1_v (RETURN_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
current_function_decl = old_context;
if (decl_function_context (fndecl))
- {
- /* Register this function with cgraph just far enough to get it
- added to our parent's nested function list. */
- (void) cgraph_node (fndecl);
-
- /* Lowering nested functions requires gimple input. */
- gimplify_function_tree (fndecl);
- }
+ /* Register this function with cgraph just far enough to get it
+ added to our parent's nested function list. */
+ (void) cgraph_node (fndecl);
else
{
- if (cgraph_node (fndecl)->nested)
- {
- gimplify_function_tree (fndecl);
- lower_nested_functions (fndecl);
- }
- gfc_finalize (fndecl);
+ gfc_gimplify_function (fndecl);
+ cgraph_finalize_function (fndecl, false);
}
}
-
void
gfc_generate_constructors (void)
{
- if (gfc_static_ctors != NULL_TREE)
- abort ();
+ gcc_assert (gfc_static_ctors == NULL_TREE);
#if 0
tree fnname;
tree type;
TREE_PUBLIC (fndecl) = 1;
decl = build_decl (RESULT_DECL, NULL_TREE, void_type_node);
+ DECL_ARTIFICIAL (decl) = 1;
+ DECL_IGNORED_P (decl) = 1;
DECL_CONTEXT (decl) = fndecl;
DECL_RESULT (fndecl) = decl;
current_function_decl = fndecl;
- rest_of_decl_compilation (fndecl, NULL, 1, 0);
-
- make_decl_rtl (fndecl, NULL);
+ rest_of_decl_compilation (fndecl, 1, 0);
- init_function_start (fndecl, input_filename, input_line);
+ make_decl_rtl (fndecl);
- cfun->x_whole_function_mode_p = 1;
-
- immediate_size_expand = 0;
+ init_function_start (fndecl);
pushlevel (0);
for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
{
tmp =
- gfc_build_function_call (TREE_VALUE (gfc_static_ctors), NULL_TREE);
+ build_function_call_expr (TREE_VALUE (gfc_static_ctors), NULL_TREE);
DECL_SAVED_TREE (fndecl) = build_stmt (EXPR_STMT, tmp);
}
free_after_parsing (cfun);
free_after_compilation (cfun);
- tree_rest_of_compilation (fndecl, 0);
+ tree_rest_of_compilation (fndecl);
current_function_decl = NULL_TREE;
#endif
}
+/* Translates a BLOCK DATA program unit. This means emitting the
+ commons contained therein plus their initializations. We also emit
+ a globally visible symbol to make sure that each BLOCK DATA program
+ unit remains unique. */
+
+void
+gfc_generate_block_data (gfc_namespace * ns)
+{
+ tree decl;
+ tree id;
+
+ /* Tell the backend the source location of the block data. */
+ if (ns->proc_name)
+ gfc_set_backend_locus (&ns->proc_name->declared_at);
+ else
+ gfc_set_backend_locus (&gfc_current_locus);
+
+ /* Process the DATA statements. */
+ gfc_trans_common (ns);
+
+ /* Create a global symbol with the mane of the block data. This is to
+ generate linker errors if the same name is used twice. It is never
+ really used. */
+ if (ns->proc_name)
+ id = gfc_sym_mangled_function_id (ns->proc_name);
+ else
+ id = get_identifier ("__BLOCK_DATA__");
+
+ decl = build_decl (VAR_DECL, id, gfc_array_index_type);
+ TREE_PUBLIC (decl) = 1;
+ TREE_STATIC (decl) = 1;
+
+ pushdecl (decl);
+ rest_of_decl_compilation (decl, 1, 0);
+}
+
+
#include "gt-fortran-trans-decl.h"
OSDN Git Service
