/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005 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 "gfortran.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_set_max_subrecord_length;
+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. */
-tree gfor_fndecl_copy_string;
tree gfor_fndecl_compare_string;
tree gfor_fndecl_concat_string;
tree gfor_fndecl_string_len_trim;
tree gfor_fndecl_si_kind;
tree gfor_fndecl_sr_kind;
+/* BLAS gemm functions. */
+tree gfor_fndecl_sgemm;
+tree gfor_fndecl_dgemm;
+tree gfor_fndecl_cgemm;
+tree gfor_fndecl_zgemm;
+
static void
gfc_add_decl_to_parent_function (tree decl)
}
-/* 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;
}
{
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.external
+ || 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
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 && !sym->attr.dummy)
+ else if (sym->module && !sym->attr.result && !sym->attr.dummy)
{
/* TODO: Don't set sym->module for result or dummy variables. */
- gcc_assert (current_function_decl == NULL_TREE);
+ 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;
if ((sym->attr.save || sym->attr.data || sym->value)
&& !sym->attr.use_assoc)
TREE_STATIC (decl) = 1;
-
+
+ if (sym->attr.volatile_)
+ {
+ tree new;
+ TREE_THIS_VOLATILE (decl) = 1;
+ new = build_qualified_type (TREE_TYPE (decl), TYPE_QUAL_VOLATILE);
+ TREE_TYPE (decl) = new;
+ }
+
/* Keep variables larger than max-stack-var-size off stack. */
if (!sym->ns->proc_name->attr.recursive
&& INTEGER_CST_P (DECL_SIZE_UNIT (decl))
- && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl)))
+ && !gfc_can_put_var_on_stack (DECL_SIZE_UNIT (decl))
+ /* Put variable length auto array pointers always into stack. */
+ && (TREE_CODE (TREE_TYPE (decl)) != POINTER_TYPE
+ || sym->attr.dimension == 0
+ || sym->as->type != AS_EXPLICIT
+ || sym->attr.pointer
+ || sym->attr.allocatable)
+ && !DECL_ARTIFICIAL (decl))
TREE_STATIC (decl) = 1;
+
+ /* Handle threadprivate variables. */
+ if (sym->attr.threadprivate && targetm.have_tls
+ && (TREE_STATIC (decl) || DECL_EXTERNAL (decl)))
+ DECL_TLS_MODEL (decl) = decl_default_tls_model (decl);
}
{
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
type = TREE_TYPE (type);
if (GFC_DESCRIPTOR_TYPE_P (type))
{
- /* Create a decriptorless array pointer. */
+ /* Create a descriptorless array pointer. */
as = sym->as;
packed = 0;
if (!gfc_option.flag_repack_arrays)
/* We now have an expression for the element size, so create a fully
qualified type. Reset sym->backend decl or this will just return the
old type. */
+ DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = NULL_TREE;
type = gfc_sym_type (sym);
packed = 2;
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;
- gcc_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. */
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);
- }
+ /* Add the string length to the same context as the symbol. */
+ if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
+ gfc_add_decl_to_function (length);
+ else
+ gfc_add_decl_to_parent_function (length);
+
+ gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
+ DECL_CONTEXT (length));
+
+ gfc_defer_symbol_init (sym);
}
}
/* Use a copy of the descriptor for dummy arrays. */
if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
{
- sym->backend_decl =
- gfc_build_dummy_array_decl (sym, sym->backend_decl);
+ decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
+ /* Prevent the dummy from being detected as unused if it is copied. */
+ if (sym->backend_decl != NULL && decl != sym->backend_decl)
+ DECL_ARTIFICIAL (sym->backend_decl) = 1;
+ sym->backend_decl = decl;
}
TREE_USED (sym->backend_decl) = 1;
+ if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
+ {
+ gfc_add_assign_aux_vars (sym);
+ }
return sym->backend_decl;
}
/* 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_DECL_PACKED_ARRAY (decl) = 1;
}
- gfc_finish_var_decl (decl, sym);
+ if (sym->ts.type == BT_DERIVED && sym->ts.derived->attr.alloc_comp)
+ gfc_defer_symbol_init (sym);
- if (sym->attr.assign)
- {
- gfc_allocate_lang_decl (decl);
- GFC_DECL_ASSIGN (decl) = 1;
- length = gfc_create_var (gfc_charlen_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);
- }
+ gfc_finish_var_decl (decl, sym);
if (sym->ts.type == BT_CHARACTER)
{
{
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);
}
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 + 23]; /* "_gfortran_f2c_specific" and '\0'. */
tree name;
tree mangled_name;
isym->resolve.f1 (&e, &argexpr);
else
{
- /* All specific intrinsics take one or two arguments. */
- gcc_assert (isym->formal->next->next == NULL);
- isym->resolve.f2 (&e, &argexpr, NULL);
+ if (isym->formal->next->next == NULL)
+ isym->resolve.f2 (&e, &argexpr, NULL);
+ else
+ {
+ /* All specific intrinsics take less than 4 arguments. */
+ gcc_assert (isym->formal->next->next->next == NULL);
+ isym->resolve.f3 (&e, &argexpr, NULL, 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, "_gfortran_f2c_specific%s", e.value.function.name);
+ }
+ else
+ sprintf (s, "_gfortran_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)
/* 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)
+ 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)
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
+ DECL_ARTIFICIAL (parm) = 1;
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
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;
- DECL_ARTIFICIAL (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);
- gcc_assert (type == gfc_charlen_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;
}
gcc_assert (TREE_CODE (length) == PARM_DECL);
- arglist = chainon (arglist, length);
- typelist = TREE_CHAIN (typelist);
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);
- gcc_assert (type == gfc_charlen_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_ARTIFICIAL (length) = 1;
- 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);
+ /* 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);
+ }
+
+ /* 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;
+
+ gfc_finish_decl (parm, NULL_TREE);
+
+ f->sym->backend_decl = parm;
+
+ arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
}
- gcc_assert (TREE_VALUE (typelist) == void_type_node);
+ /* Add the hidden string length parameters. */
+ arglist = chainon (arglist, hidden_arglist);
+
+ gcc_assert (hidden_typelist == NULL_TREE
+ || TREE_VALUE (hidden_typelist) == void_type_node);
DECL_ARGUMENTS (fndecl) = arglist;
}
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. */
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;
if (thunk_formal)
{
/* Pass the argument. */
+ DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
args);
if (formal->sym->ts.type == BT_CHARACTER)
args = tree_cons (NULL_TREE, null_pointer_node, args);
if (formal->sym->ts.type == BT_CHARACTER)
{
- tmp = convert (gfc_charlen_type_node, integer_zero_node);
+ tmp = build_int_cst (gfc_charlen_type_node, 0);
string_args = tree_cons (NULL_TREE, tmp, string_args);
}
}
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. */
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;
}
}
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)));
-
- decl = build_decl (VAR_DECL, get_identifier (name),
- TREE_TYPE (TREE_TYPE (current_function_decl)));
+ IDENTIFIER_POINTER (DECL_NAME (this_function_decl)));
+ if (!sym->attr.mixed_entry_master && sym->attr.function)
+ decl = build_decl (VAR_DECL, get_identifier (name),
+ gfc_sym_type (sym));
+ else
+ decl = build_decl (VAR_DECL, get_identifier (name),
+ TREE_TYPE (TREE_TYPE (this_function_decl)));
DECL_ARTIFICIAL (decl) = 1;
DECL_EXTERNAL (decl) = 0;
TREE_PUBLIC (decl) = 0;
TREE_USED (decl) = 1;
+ GFC_DECL_RESULT (decl) = 1;
+ TREE_ADDRESSABLE (decl) = 1;
layout_decl (decl, 0);
- gfc_add_decl_to_function (decl);
+ if (parent_flag)
+ gfc_add_decl_to_parent_function (decl);
+ else
+ gfc_add_decl_to_function (decl);
}
- current_fake_result_decl = decl;
+ if (parent_flag)
+ parent_fake_result_decl = build_tree_list (NULL, decl);
+ else
+ current_fake_result_decl = build_tree_list (NULL, decl);
return decl;
}
{
tree gfc_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_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,
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,
gfc_charlen_type_node, pchar_type_node);
gfor_fndecl_si_kind =
- gfc_build_library_function_decl (get_identifier ("selected_int_kind"),
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("selected_int_kind")),
gfc_int4_type_node,
1,
pvoid_type_node);
gfor_fndecl_sr_kind =
- gfc_build_library_function_decl (get_identifier ("selected_real_kind"),
+ gfc_build_library_function_decl (get_identifier
+ (PREFIX("selected_real_kind")),
gfc_int4_type_node,
2, pvoid_type_node,
pvoid_type_node);
/* 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);
+ TREE_READONLY (gfor_fndecl_math_powi[jkind][ikind].integer) = 1;
+ }
+ }
+
+ 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);
+ TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].real) = 1;
+ }
+
+ 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);
+ TREE_READONLY (gfor_fndecl_math_powi[rkind][ikind].cmplx) = 1;
+ }
}
}
+#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);
+
+ /* BLAS functions. */
+ {
+ tree pint = build_pointer_type (gfc_c_int_type_node);
+ tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
+ tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
+ tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
+ tree pz = build_pointer_type
+ (gfc_get_complex_type (gfc_default_double_kind));
+
+ gfor_fndecl_sgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "sgemm_"
+ : "sgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, ps, ps, pint,
+ ps, pint, ps, ps, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ gfor_fndecl_dgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "dgemm_"
+ : "dgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, pd, pd, pint,
+ pd, pint, pd, pd, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ gfor_fndecl_cgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "cgemm_"
+ : "cgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, pc, pc, pint,
+ pc, pint, pc, pc, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ gfor_fndecl_zgemm = gfc_build_library_function_decl
+ (get_identifier
+ (gfc_option.flag_underscoring ? "zgemm_"
+ : "zgemm"),
+ void_type_node, 15, pchar_type_node,
+ pchar_type_node, pint, pint, pint, pz, pz, pint,
+ pz, pint, pz, pz, pint, gfc_c_int_type_node,
+ gfc_c_int_type_node);
+ }
/* 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")),
gfor_fndecl_allocate =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int4_type_node);
+ pvoid_type_node, 2,
+ gfc_int4_type_node, gfc_pint4_type_node);
+ DECL_IS_MALLOC (gfor_fndecl_allocate) = 1;
gfor_fndecl_allocate64 =
gfc_build_library_function_decl (get_identifier (PREFIX("allocate64")),
- void_type_node, 2, ppvoid_type_node,
- gfc_int8_type_node);
+ pvoid_type_node, 2,
+ gfc_int8_type_node, gfc_pint4_type_node);
+ DECL_IS_MALLOC (gfor_fndecl_allocate64) = 1;
+
+ gfor_fndecl_allocate_array =
+ gfc_build_library_function_decl (get_identifier (PREFIX("allocate_array")),
+ pvoid_type_node, 3, pvoid_type_node,
+ gfc_int4_type_node, gfc_pint4_type_node);
+ DECL_IS_MALLOC (gfor_fndecl_allocate_array) = 1;
+
+ gfor_fndecl_allocate64_array =
+ gfc_build_library_function_decl (get_identifier (PREFIX("allocate64_array")),
+ pvoid_type_node, 3, pvoid_type_node,
+ gfc_int8_type_node, gfc_pint4_type_node);
+ DECL_IS_MALLOC (gfor_fndecl_allocate64_array) = 1;
gfor_fndecl_deallocate =
gfc_build_library_function_decl (get_identifier (PREFIX("deallocate")),
- void_type_node, 1, ppvoid_type_node);
+ void_type_node, 2, pvoid_type_node,
+ gfc_pint4_type_node);
gfor_fndecl_stop_numeric =
gfc_build_library_function_decl (get_identifier (PREFIX("stop_numeric")),
void_type_node, 1, gfc_int4_type_node);
+ /* Stop doesn't return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_stop_numeric) = 1;
+
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,
+ 4,
+ gfc_int4_type_node,
+ 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_set_max_subrecord_length =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
+ void_type_node, 1, gfc_c_int_type_node);
gfor_fndecl_in_pack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_pack")),
/* 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);
}
/* 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
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;
+ bool seen_trans_deferred_array = false;
/* 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)
{
+ bool sym_has_alloc_comp = (sym->ts.type == BT_DERIVED)
+ && sym->ts.derived->attr.alloc_comp;
if (sym->attr.dimension)
{
switch (sym->as->type)
if (TREE_STATIC (sym->backend_decl))
gfc_trans_static_array_pointer (sym);
else
- fnbody = gfc_trans_deferred_array (sym, fnbody);
+ {
+ seen_trans_deferred_array = true;
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
+ }
}
else
{
+ if (sym_has_alloc_comp)
+ {
+ seen_trans_deferred_array = true;
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
+ }
+
gfc_get_backend_locus (&loc);
gfc_set_backend_locus (&sym->declared_at);
fnbody = gfc_trans_auto_array_allocation (sym->backend_decl,
break;
case AS_DEFERRED:
+ seen_trans_deferred_array = true;
fnbody = gfc_trans_deferred_array (sym, fnbody);
break;
default:
gcc_unreachable ();
}
+ if (sym_has_alloc_comp && !seen_trans_deferred_array)
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
}
+ else if (sym_has_alloc_comp)
+ fnbody = gfc_trans_deferred_array (sym, fnbody);
else if (sym->ts.type == BT_CHARACTER)
{
gfc_get_backend_locus (&loc);
gfc_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
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);
}
{
tree decl;
- /* Only output symbols from this module. */
- if (sym->ns != module_namespace)
- {
- /* I don't think this should ever happen. */
- internal_error ("module symbol %s in wrong namespace", sym->name);
- }
+ /* Module functions with alternate entries are dealt with later and
+ would get caught by the next condition. */
+ if (sym->attr.entry)
+ return;
/* Only output variables and array valued parameters. */
if (sym->attr.flavor != FL_VARIABLE
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);
}
+/* Drill down through expressions for the array specification bounds and
+ character length calling generate_local_decl for all those variables
+ that have not already been declared. */
+
+static void
+generate_local_decl (gfc_symbol *);
+
+static void
+generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
+{
+ gfc_actual_arglist *arg;
+ gfc_ref *ref;
+ int i;
+
+ if (e == NULL)
+ return;
+
+ switch (e->expr_type)
+ {
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ generate_expr_decls (sym, arg->expr);
+ break;
+
+ /* If the variable is not the same as the dependent, 'sym', and
+ it is not marked as being declared and it is in the same
+ namespace as 'sym', add it to the local declarations. */
+ case EXPR_VARIABLE:
+ if (sym == e->symtree->n.sym
+ || e->symtree->n.sym->mark
+ || e->symtree->n.sym->ns != sym->ns)
+ return;
+
+ generate_local_decl (e->symtree->n.sym);
+ break;
+
+ case EXPR_OP:
+ generate_expr_decls (sym, e->value.op.op1);
+ generate_expr_decls (sym, e->value.op.op2);
+ break;
+
+ default:
+ break;
+ }
+
+ if (e->ref)
+ {
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ generate_expr_decls (sym, ref->u.ar.start[i]);
+ generate_expr_decls (sym, ref->u.ar.end[i]);
+ generate_expr_decls (sym, ref->u.ar.stride[i]);
+ }
+ break;
+
+ case REF_SUBSTRING:
+ generate_expr_decls (sym, ref->u.ss.start);
+ generate_expr_decls (sym, ref->u.ss.end);
+ break;
+
+ case REF_COMPONENT:
+ if (ref->u.c.component->ts.type == BT_CHARACTER
+ && ref->u.c.component->ts.cl->length->expr_type
+ != EXPR_CONSTANT)
+ generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
+
+ if (ref->u.c.component->as)
+ for (i = 0; i < ref->u.c.component->as->rank; i++)
+ {
+ generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
+ generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
+ }
+ break;
+ }
+ }
+ }
+}
+
+
+/* Check for dependencies in the character length and array spec. */
+
+static void
+generate_dependency_declarations (gfc_symbol *sym)
+{
+ int i;
+
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
+ generate_expr_decls (sym, sym->ts.cl->length);
+
+ if (sym->as && sym->as->rank)
+ {
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ generate_expr_decls (sym, sym->as->lower[i]);
+ generate_expr_decls (sym, sym->as->upper[i]);
+ }
+ }
+}
+
+
/* Generate decls for all local variables. We do this to ensure correct
handling of expressions which only appear in the specification of
other functions. */
{
if (sym->attr.flavor == FL_VARIABLE)
{
+ /* Check for dependencies in the array specification and string
+ length, adding the necessary declarations to the function. We
+ mark the symbol now, as well as in traverse_ns, to prevent
+ getting stuck in a circular dependency. */
+ sym->mark = 1;
+ if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
+ generate_dependency_declarations (sym);
+
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
else if (sym->attr.dummy && warn_unused_parameter)
- warning ("unused parameter %qs", sym->name);
+ gfc_warning ("Unused parameter %s declared at %L", sym->name,
+ &sym->declared_at);
/* Warn for unused variables, but not if they're inside a common
block or are use-associated. */
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->attr.use_assoc))
- warning ("unused variable %qs", sym->name);
+ gfc_warning ("Unused variable %s declared at %L", sym->name,
+ &sym->declared_at);
+ /* For variable length CHARACTER parameters, the PARM_DECL already
+ references the length variable, so force gfc_get_symbol_decl
+ even when not referenced. If optimize > 0, it will be optimized
+ 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;
+ 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);
tree old_context;
tree decl;
tree tmp;
+ tree tmp2;
stmtblock_t block;
stmtblock_t body;
tree result;
gfc_symbol *sym;
+ int rank;
sym = ns->proc_name;
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));
+ arglist = gfc_chainon_list (arglist,
+ build_int_cst (gfc_int4_type_node,
+ gfc_option.flag_dump_core));
+
+ 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 (sym->attr.is_main_program && gfc_option.max_subrecord_length != 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.max_subrecord_length));
+ tmp = build_function_call_expr (gfor_fndecl_set_max_subrecord_length, 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);
}
tmp = gfc_finish_block (&body);
/* Add code to create and cleanup arrays. */
tmp = gfc_trans_deferred_vars (sym, tmp);
- gfc_add_expr_to_block (&block, tmp);
if (TREE_TYPE (DECL_RESULT (fndecl)) != void_type_node)
{
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");
+ if (result != NULL_TREE && sym->attr.function
+ && sym->ts.type == BT_DERIVED
+ && sym->ts.derived->attr.alloc_comp)
+ {
+ rank = sym->as ? sym->as->rank : 0;
+ tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
+ gfc_add_expr_to_block (&block, tmp2);
+ }
+
+ gfc_add_expr_to_block (&block, tmp);
+
+ if (result == NULL_TREE)
+ warning (0, "Function return value not set");
else
{
- /* Set the return value to the dummy result variable. */
- tmp = build2 (MODIFY_EXPR, TREE_TYPE (result),
- DECL_RESULT (fndecl), result);
+ /* Set the return value to the dummy result variable. The
+ types may be different for scalar default REAL functions
+ with -ff2c, therefore we have to convert. */
+ tmp = convert (TREE_TYPE (DECL_RESULT (fndecl)), result);
+ tmp = build2 (MODIFY_EXPR, TREE_TYPE (tmp),
+ DECL_RESULT (fndecl), tmp);
tmp = build1_v (RETURN_EXPR, tmp);
gfc_add_expr_to_block (&block, tmp);
}
}
+ else
+ gfc_add_expr_to_block (&block, tmp);
+
/* Add all the decls we created during processing. */
decl = saved_function_decls;
if (gfc_static_ctors == NULL_TREE)
return;
- fnname = get_file_function_name ('I');
+ fnname = get_file_function_name ("I");
type = build_function_type (void_type_node,
gfc_chainon_list (NULL_TREE, void_type_node));
for (; gfc_static_ctors; gfc_static_ctors = TREE_CHAIN (gfc_static_ctors))
{
tmp =
- 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);
}
rest_of_decl_compilation (decl, 1, 0);
}
+
#include "gt-fortran-trans-decl.h"
OSDN Git Service
