/* 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 GCC.
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, 59 Temple Place - Suite 330, Boston, MA
-02111-1307, USA. */
+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. */
-gfc_powdecl_list gfor_fndecl_math_powi[3][2];
+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. */
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);
/* Tell the debugger where the label came from. */
if (lp->value <= MAX_LABEL_VALUE) /* An internal label. */
- {
- DECL_SOURCE_LINE (label_decl) = lp->where.lb->linenum;
- DECL_SOURCE_FILE (label_decl) = lp->where.lb->file->filename;
- }
+ gfc_set_decl_location (label_decl, &lp->where);
else
DECL_ARTIFICIAL (label_decl) = 1;
static tree
gfc_sym_identifier (gfc_symbol * sym)
{
-
return (get_identifier (sym->name));
}
{
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)
{
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);
}
void
gfc_allocate_lang_decl (tree decl)
{
-
DECL_LANG_SPECIFIC (decl) = (struct lang_decl *)
ggc_alloc_cleared (sizeof (struct lang_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? */
{
/* 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 length = NULL_TREE;
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;
}
/* Create the decl for the variable. */
decl = build_decl (VAR_DECL, gfc_sym_identifier (sym), gfc_sym_type (sym));
+ 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)
- {
- 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_cst (NULL_TREE, -2, -1);
- }
-
if (sym->ts.type == BT_CHARACTER)
{
/* Character variables need special handling. */
{
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);
}
}
sym->backend_decl = decl;
+ if (sym->attr.assign)
+ {
+ gfc_add_assign_aux_vars (sym);
+ }
+
if (TREE_STATIC (decl) && !sym->attr.use_assoc)
{
/* Add static initializer. */
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;
/* 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. */
- assert (!(sym->attr.entry || sym->attr.entry_master));
+ gcc_assert (!(sym->attr.entry || sym->attr.entry_master));
if (sym->attr.intrinsic)
{
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;
}
sense. */
if (sym->attr.pure || sym->attr.elemental)
{
- if (sym->attr.function)
+ 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
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)
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);
DECL_CONTEXT (fndecl) = current_function_decl;
DECL_EXTERNAL (fndecl) = 0;
- /* This specifies if a function is globaly visible, i.e. it is
+ /* 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)
{
/* 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_fucntion_decl(). */
- if (attr.function)
+ 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;
}
{
tree fndecl;
gfc_formal_arglist *f;
- tree typelist;
- tree arglist;
- tree length;
+ tree typelist, hidden_typelist;
+ tree arglist, hidden_arglist;
tree type;
tree parm;
/* 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)
if (gfc_return_by_reference (sym))
{
- type = TREE_VALUE (typelist);
- parm = build_decl (PARM_DECL, get_identifier ("__result"), 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);
+ tree type = TREE_VALUE (typelist), length = NULL;
if (sym->ts.type == BT_CHARACTER)
{
- gfc_allocate_lang_decl (parm);
-
/* Length of character result. */
- type = TREE_VALUE (typelist);
- assert (type == gfc_strlen_type_node);
+ tree len_type = TREE_VALUE (TREE_CHAIN (typelist));
+ gcc_assert (len_type == gfc_charlen_type_node);
length = build_decl (PARM_DECL,
get_identifier (".__result"),
- type);
+ len_type);
if (!sym->ts.cl->length)
{
sym->ts.cl->backend_decl = length;
TREE_USED (length) = 1;
}
- assert (TREE_CODE (length) == PARM_DECL);
- arglist = chainon (arglist, length);
- typelist = TREE_CHAIN (typelist);
+ gcc_assert (TREE_CODE (length) == PARM_DECL);
DECL_CONTEXT (length) = fndecl;
- DECL_ARG_TYPE (length) = type;
+ DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
+ DECL_ARTIFICIAL (length) = 1;
gfc_finish_decl (length, NULL_TREE);
- }
- }
-
- for (f = sym->formal; f; f = f->next)
- {
- if (f->sym != NULL) /* ignore alternate returns. */
- {
- length = NULL_TREE;
+ if (sym->ts.cl->backend_decl == NULL
+ || sym->ts.cl->backend_decl == length)
+ {
+ gfc_symbol *arg;
+ tree backend_decl;
- type = TREE_VALUE (typelist);
+ if (sym->ts.cl->backend_decl == NULL)
+ {
+ 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;
+ }
- /* Build a the argument declaration. */
- parm = build_decl (PARM_DECL,
- gfc_sym_identifier (f->sym), type);
+ /* 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);
+ }
+ }
- /* 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;
+ parm = build_decl (PARM_DECL, get_identifier ("__result"), type);
- gfc_finish_decl (parm, NULL_TREE);
+ 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);
- f->sym->backend_decl = parm;
+ arglist = chainon (arglist, parm);
+ typelist = TREE_CHAIN (typelist);
- arglist = chainon (arglist, parm);
+ if (sym->ts.type == BT_CHARACTER)
+ {
+ gfc_allocate_lang_decl (parm);
+ arglist = chainon (arglist, length);
typelist = TREE_CHAIN (typelist);
}
}
- /* Add the hidden string length parameters. */
- parm = arglist;
+ hidden_typelist = typelist;
+ for (f = sym->formal; f; f = f->next)
+ if (f->sym != NULL) /* Ignore alternate returns. */
+ hidden_typelist = TREE_CHAIN (hidden_typelist);
+
for (f = sym->formal; f; f = f->next)
{
char name[GFC_MAX_SYMBOL_LEN + 2];
+
/* Ignore alternate returns. */
if (f->sym == NULL)
continue;
- if (f->sym->ts.type != BT_CHARACTER)
- continue;
-
- parm = f->sym->backend_decl;
type = TREE_VALUE (typelist);
- assert (type == gfc_strlen_type_node);
- strcpy (&name[1], f->sym->name);
- name[0] = '_';
- length = build_decl (PARM_DECL, get_identifier (name), type);
+ 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);
- arglist = chainon (arglist, length);
- DECL_CONTEXT (length) = fndecl;
- DECL_ARG_TYPE (length) = type;
- TREE_READONLY (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
+ strcpy (&name[1], f->sym->name);
+ name[0] = '_';
+ length = build_decl (PARM_DECL, get_identifier (name), len_type);
- /* TODO: Check string lengths when -fbounds-check. */
+ 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);
- /* Use the passed value for assumed length variables. */
- 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
+ /* TODO: Check string lengths when -fbounds-check. */
+
+ /* Use the passed value for assumed length variables. */
+ if (!f->sym->ts.cl->length)
{
- /* 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;
+ 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;
+ 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;
+ }
+ }
+
+ hidden_typelist = TREE_CHAIN (hidden_typelist);
+
+ 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);
}
}
- parm = TREE_CHAIN (parm);
- typelist = TREE_CHAIN (typelist);
- }
+ /* 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);
+ }
- assert (TREE_VALUE (typelist) == void_type_node);
- DECL_ARGUMENTS (fndecl) = arglist;
-}
+ /* Build a the argument declaration. */
+ parm = build_decl (PARM_DECL, gfc_sym_identifier (f->sym), type);
+ /* 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;
-/* Finalize DECL and all nested functions with cgraph. */
+ gfc_finish_decl (parm, NULL_TREE);
-static void
-gfc_finalize (tree decl)
-{
- struct cgraph_node *cgn;
+ f->sym->backend_decl = parm;
- cgn = cgraph_node (decl);
- for (cgn = cgn->nested; cgn ; cgn = cgn->next_nested)
- gfc_finalize (cgn->decl);
+ arglist = chainon (arglist, parm);
+ typelist = TREE_CHAIN (typelist);
+ }
- cgraph_finalize_function (decl, false);
-}
+ /* Add the hidden string length parameters. */
+ arglist = chainon (arglist, hidden_arglist);
+ gcc_assert (TREE_VALUE (hidden_typelist) == void_type_node);
+ DECL_ARGUMENTS (fndecl) = arglist;
+}
/* Convert FNDECL's code to GIMPLE and handle any nested functions. */
gimplify_function_tree (fndecl);
dump_function (TDI_generic, fndecl);
+ /* Generate errors for structured block violations. */
+ /* ??? Could be done as part of resolve_labels. */
+ if (flag_openmp)
+ diagnose_omp_structured_block_errors (fndecl);
+
/* 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. */
/* Create RTL for function definition. */
make_decl_rtl (fndecl);
- /* 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);
-
init_function_start (fndecl);
/* Even though we're inside a function body, we still don't want to
tree args;
tree string_args;
tree tmp;
+ locus old_loc;
/* This should always be a toplevel function. */
- assert (current_function_decl == NULL_TREE);
+ gcc_assert (current_function_decl == NULL_TREE);
- /* Remember the master function argument decls. */
- for (formal = ns->proc_name->formal; formal; formal = formal->next)
- {
- }
-
+ gfc_get_backend_locus (&old_loc);
for (el = ns->entries; el; el = el->next)
{
thunk_sym = el->sym;
gfc_start_block (&body);
/* Pass extra parameter identifying this entry point. */
- tmp = build_int_cst (gfc_array_index_type, el->id, 0);
+ tmp = build_int_cst (gfc_array_index_type, el->id);
args = tree_cons (NULL_TREE, tmp, NULL_TREE);
string_args = NULL_TREE;
- /* TODO: Pass return by reference parameters. */
- if (ns->proc_name->attr.function)
- gfc_todo_error ("Functons with multiple entry points");
-
+ 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;
args = tree_cons (NULL_TREE, null_pointer_node, args);
if (formal->sym->ts.type == BT_CHARACTER)
{
- tmp = convert (gfc_strlen_type_node, integer_zero_node);
+ tmp = convert (gfc_charlen_type_node, integer_zero_node);
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
args = nreverse (args);
args = chainon (args, nreverse (string_args));
tmp = ns->proc_name->backend_decl;
- tmp = gfc_build_function_call (tmp, args);
- /* TODO: function return value. */
+ 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. */
current_function_decl = NULL_TREE;
gfc_gimplify_function (thunk_fndecl);
- lower_nested_functions (thunk_fndecl);
- gfc_finalize (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)
{
- formal->sym->backend_decl = NULL_TREE;
- if (formal->sym->ts.type == BT_CHARACTER)
- formal->sym->ts.cl->backend_decl = NULL_TREE;
+ 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_function_arglist (ns->proc_name);
}
-/* Return the decl used to hold the function return value. */
+/* Return the decl used to hold the function return value. If
+ parent_flag is set, the context is the parent_scope*/
tree
-gfc_get_fake_result_decl (gfc_symbol * sym)
+gfc_get_fake_result_decl (gfc_symbol * sym, int parent_flag)
{
tree decl;
tree length;
+ tree this_fake_result_decl;
+ tree this_function_decl;
char name[GFC_MAX_SYMBOL_LEN + 10];
- if (current_fake_result_decl != NULL_TREE)
- return current_fake_result_decl;
+ 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
- && !sym->ts.cl->backend_decl)
+ if (sym->ts.type == BT_CHARACTER)
{
- length = gfc_create_string_length (sym);
- gfc_finish_var_decl (length, sym);
+ 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 (sym->backend_decl);
+ 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)
else
{
sprintf (name, "__result_%.20s",
- IDENTIFIER_POINTER (DECL_NAME (current_function_decl)));
+ IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
decl = build_decl (VAR_DECL, get_identifier (name),
- TREE_TYPE (TREE_TYPE (current_function_decl)));
+ 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);
- gfc_add_decl_to_function (decl);
+ if (parent_flag)
+ gfc_add_decl_to_parent_function (decl);
+ else
+ gfc_add_decl_to_function (decl);
}
- current_fake_result_decl = 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;
}
int n;
/* Library functions must be declared with global scope. */
- assert (current_function_decl == NULL_TREE);
+ gcc_assert (current_function_decl == NULL_TREE);
va_start (p, nargs);
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. */
{
- tree type;
- tree itype;
- int kind;
- int ikind;
- static int kinds[2] = {4, 8};
- char name[PREFIX_LEN + 10]; /* _gfortran_pow_?n_?n */
-
- for (ikind=0; ikind < 2; ikind++)
+ 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 (kinds[ikind]);
- for (kind = 0; kind < 2; kind ++)
+ 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 ++)
{
- type = gfc_get_int_type (kinds[kind]);
- sprintf(name, PREFIX("pow_i%d_i%d"), kinds[kind], kinds[ikind]);
- gfor_fndecl_math_powi[kind][ikind].integer =
- gfc_build_library_function_decl (get_identifier (name),
- type, 2, type, itype);
-
- type = gfc_get_real_type (kinds[kind]);
- sprintf(name, PREFIX("pow_r%d_i%d"), kinds[kind], kinds[ikind]);
- gfor_fndecl_math_powi[kind][ikind].real =
- gfc_build_library_function_decl (get_identifier (name),
- type, 2, type, itype);
-
- type = gfc_get_complex_type (kinds[kind]);
- sprintf(name, PREFIX("pow_c%d_i%d"), kinds[kind], kinds[ikind]);
- gfor_fndecl_math_powi[kind][ikind].cmplx =
- gfc_build_library_function_decl (get_identifier (name),
- type, 2, type, itype);
+ 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 ("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_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 =
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")),
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
- void_type_node,
- 3,
- pchar_type_node, pchar_type_node,
- gfc_int4_type_node);
+ void_type_node, 1, pchar_type_node);
+ /* The runtime_error function does not return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
+
+ gfor_fndecl_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);
}
tree decl;
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);
+ gfc_trans_vla_type_sizes (sym, &body);
+
decl = sym->backend_decl;
/* Emit a DECL_EXPR for this variable, which will cause the
gimplifier to allocate storage, and all that good stuff. */
- tmp = build (DECL_EXPR, TREE_TYPE (decl), decl);
+ 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 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. */
fnbody = gfc_trans_g77_array (sym, fnbody);
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 ();
}
- return fnbody;
+ 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);
+ }
+
+ gfc_add_expr_to_block (&body, fnbody);
+ return gfc_finish_block (&body);
}
internal_error ("module symbol %s in wrong namespace", sym->name);
}
- /* 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;
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);
module_namespace = ns;
/* Check if the frontend left the namespace in a reasonable state. */
- assert (ns->proc_name && !ns->proc_name->tlink);
+ gcc_assert (ns->proc_name && !ns->proc_name->tlink);
/* Generate COMMON blocks. */
gfc_trans_common (ns);
{
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
- else if (sym->attr.dummy)
- {
- if (warn_unused_parameter)
- warning ("unused parameter `%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. */
+ block or are use-associated. */
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->attr.use_assoc))
- warning ("unused variable `%s'", sym->name);
+ 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);
+ }
}
}
for (; el; el = el->next)
{
/* Add the case label. */
- label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
- DECL_CONTEXT (label) = current_function_decl;
- val = build_int_cst (gfc_array_index_type, el->id, 0);
- tmp = build_v (CASE_LABEL_EXPR, val, NULL_TREE, 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);
- TREE_USED (label) = 1;
- DECL_CONTEXT (label) = current_function_decl;
tmp = build1_v (GOTO_EXPR, label);
gfc_add_expr_to_block (&block, tmp);
tmp = gfc_finish_block (&block);
/* The first argument selects the entry point. */
val = DECL_ARGUMENTS (current_function_decl);
- tmp = build_v (SWITCH_EXPR, val, tmp, NULL_TREE);
+ tmp = build3_v (SWITCH_EXPR, val, tmp, NULL_TREE);
return tmp;
}
sym = ns->proc_name;
/* Check that the frontend isn't still using this. */
- assert (sym->tlink == NULL);
+ gcc_assert (sym->tlink == NULL);
sym->tlink = sym;
/* Create the declaration for functions with global scope. */
trans_function_start (sym);
- /* Will be created as needed. */
- current_fake_result_decl = NULL_TREE;
-
gfc_start_block (&block);
- gfc_generate_contained_functions (ns);
+ if (ns->entries && ns->proc_name->ts.type == BT_CHARACTER)
+ {
+ /* 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;
+ }
/* Translate COMMON blocks. */
gfc_trans_common (ns);
+ /* Null the parent fake result declaration if this namespace is
+ a module function or an external procedures. */
+ if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
+ || ns->parent == NULL)
+ parent_fake_result_decl = NULL_TREE;
+
+ gfc_generate_contained_functions (ns);
+
generate_local_vars (ns);
+
+ /* Keep the parent fake result declaration in module functions
+ or external procedures. */
+ if ((ns->parent && ns->parent->proc_name->attr.flavor == FL_MODULE)
+ || ns->parent == NULL)
+ current_fake_result_decl = parent_fake_result_decl;
+ else
+ current_fake_result_decl = NULL_TREE;
current_function_return_label = NULL;
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
+ /* If this is the main program, add a call to set_std to set up the
+ runtime library Fortran language standard parameters. */
+
+ if (sym->attr.is_main_program)
+ {
+ tree arglist, gfc_int4_type_node;
+
+ gfc_int4_type_node = gfc_get_int_type (4);
+ arglist = gfc_chainon_list (NULL_TREE,
+ build_int_cst (gfc_int4_type_node,
+ gfc_option.warn_std));
+ arglist = gfc_chainon_list (arglist,
+ build_int_cst (gfc_int4_type_node,
+ gfc_option.allow_std));
+ arglist = gfc_chainon_list (arglist,
+ build_int_cst (gfc_int4_type_node,
+ pedantic));
+ tmp = build_function_call_expr (gfor_fndecl_set_std, arglist);
+ gfc_add_expr_to_block (&body, tmp);
+ }
+
+ /* 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;
+
+ 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);
+ }
+
+ /* 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)
+ {
+ 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.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 (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 dummy result variable. */
- tmp = build (MODIFY_EXPR, TREE_TYPE (result),
- DECL_RESULT (fndecl), result);
- tmp = build_v (RETURN_EXPR, tmp);
+ tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
+ DECL_RESULT (fndecl), result);
+ tmp = build1_v (RETURN_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
else
{
gfc_gimplify_function (fndecl);
- lower_nested_functions (fndecl);
- gfc_finalize (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;
make_decl_rtl (fndecl);
- init_function_start (fndecl, input_filename, input_line);
+ 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"