/* Backend function setup
- Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
- Inc.
+ Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007 Free Software
+ Foundation, Inc.
Contributed by Paul Brook
This file is part of GCC.
GCC is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free
-Software Foundation; either version 2, or (at your option) any later
+Software Foundation; either version 3, or (at your option) any later
version.
GCC is distributed in the hope that it will be useful, but WITHOUT ANY
for more details.
You should have received a copy of the GNU General Public License
-along with GCC; see the file COPYING. If not, write to the Free
-Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
-02110-1301, USA. */
+along with GCC; see the file COPYING3. If not see
+<http://www.gnu.org/licenses/>. */
/* trans-decl.c -- Handling of backend function and variable decls, etc */
/* Function declarations for builtin library functions. */
-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_numeric;
tree gfor_fndecl_stop_string;
tree gfor_fndecl_select_string;
tree gfor_fndecl_runtime_error;
+tree gfor_fndecl_runtime_error_at;
+tree gfor_fndecl_os_error;
+tree gfor_fndecl_generate_error;
tree gfor_fndecl_set_fpe;
-tree gfor_fndecl_set_std;
+tree gfor_fndecl_set_options;
tree gfor_fndecl_set_convert;
tree gfor_fndecl_set_record_marker;
tree gfor_fndecl_set_max_subrecord_length;
tree gfor_fndecl_string_scan;
tree gfor_fndecl_string_verify;
tree gfor_fndecl_string_trim;
-tree gfor_fndecl_string_repeat;
+tree gfor_fndecl_string_minmax;
tree gfor_fndecl_adjustl;
tree gfor_fndecl_adjustr;
{
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ /* Prevent the mangling of identifiers that have an assigned
+ binding label (mainly those that are bind(c)). */
+ if (sym->attr.is_bind_c == 1
+ && sym->binding_label[0] != '\0')
+ return get_identifier(sym->binding_label);
+
if (sym->module == NULL)
return gfc_sym_identifier (sym);
else
{
- snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
+ snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
return get_identifier (name);
}
}
int has_underscore;
char name[GFC_MAX_MANGLED_SYMBOL_LEN + 1];
+ /* It may be possible to simply use the binding label if it's
+ provided, and remove the other checks. Then we could use it
+ for other things if we wished. */
+ if ((sym->attr.is_bind_c == 1 || sym->attr.is_iso_c == 1) &&
+ sym->binding_label[0] != '\0')
+ /* use the binding label rather than the mangled name */
+ return get_identifier (sym->binding_label);
+
if (sym->module == NULL || sym->attr.proc == PROC_EXTERNAL
|| (sym->module != NULL && (sym->attr.external
|| sym->attr.if_source == IFSRC_IFBODY)))
}
else
{
- snprintf (name, sizeof name, "__%s__%s", sym->module, sym->name);
+ snprintf (name, sizeof name, "__%s_MOD_%s", sym->module, sym->name);
return get_identifier (name);
}
}
}
-/* Finish processing of a declaration and install its initial value. */
+/* Finish processing of a declaration without an initial value. */
static void
-gfc_finish_decl (tree decl, tree init)
+gfc_finish_decl (tree decl)
{
- if (TREE_CODE (decl) == PARM_DECL)
- 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)
- gcc_assert (DECL_INITIAL (decl) == NULL_TREE);
- else
- gcc_assert (DECL_INITIAL (decl) == error_mark_node);
-
- if (init != NULL_TREE)
- {
- if (TREE_CODE (decl) != TYPE_DECL)
- DECL_INITIAL (decl) = init;
- else
- {
- /* typedef foo = bar; store the type of bar as the type of foo. */
- TREE_TYPE (decl) = TREE_TYPE (init);
- DECL_INITIAL (decl) = init = 0;
- }
- }
+ gcc_assert (TREE_CODE (decl) == PARM_DECL
+ || DECL_INITIAL (decl) == NULL_TREE);
- if (TREE_CODE (decl) == VAR_DECL)
- {
- if (DECL_SIZE (decl) == NULL_TREE
- && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
- layout_decl (decl, 0);
-
- /* A static variable with an incomplete type is an error if it is
- initialized. Also if it is not file scope. Otherwise, let it
- through, but if it is not `extern' then it may cause an error
- message later. */
- /* An automatic variable with an incomplete type is an error. */
- if (DECL_SIZE (decl) == NULL_TREE
- && (TREE_STATIC (decl) ? (DECL_INITIAL (decl) != 0
- || DECL_CONTEXT (decl) != 0)
- : !DECL_EXTERNAL (decl)))
- {
- gfc_fatal_error ("storage size not known");
- }
-
- if ((DECL_EXTERNAL (decl) || TREE_STATIC (decl))
- && (DECL_SIZE (decl) != 0)
- && (TREE_CODE (DECL_SIZE (decl)) != INTEGER_CST))
- {
- gfc_fatal_error ("storage size not constant");
- }
- }
+ if (TREE_CODE (decl) != VAR_DECL)
+ return;
+ if (DECL_SIZE (decl) == NULL_TREE
+ && TYPE_SIZE (TREE_TYPE (decl)) != NULL_TREE)
+ layout_decl (decl, 0);
+
+ /* A few consistency checks. */
+ /* A static variable with an incomplete type is an error if it is
+ initialized. Also if it is not file scope. Otherwise, let it
+ through, but if it is not `extern' then it may cause an error
+ message later. */
+ /* An automatic variable with an incomplete type is an error. */
+
+ /* We should know the storage size. */
+ gcc_assert (DECL_SIZE (decl) != NULL_TREE
+ || (TREE_STATIC (decl)
+ ? (!DECL_INITIAL (decl) || !DECL_CONTEXT (decl))
+ : DECL_EXTERNAL (decl)));
+
+ /* The storage size should be constant. */
+ gcc_assert ((!DECL_EXTERNAL (decl) && !TREE_STATIC (decl))
+ || !DECL_SIZE (decl)
+ || TREE_CODE (DECL_SIZE (decl)) == INTEGER_CST);
}
static void
gfc_finish_var_decl (tree decl, gfc_symbol * sym)
{
+ tree new;
/* TREE_ADDRESSABLE means the address of this variable is actually needed.
This is the equivalent of the TARGET variables.
We also need to set this if the variable is passed by reference in a
if (sym->attr.cray_pointee)
return;
+ if(sym->attr.is_bind_c == 1)
+ {
+ /* We need to put variables that are bind(c) into the common
+ segment of the object file, because this is what C would do.
+ gfortran would typically put them in either the BSS or
+ initialized data segments, and only mark them as common if
+ they were part of common blocks. However, if they are not put
+ into common space, then C cannot initialize global fortran
+ variables that it interoperates with and the draft says that
+ either Fortran or C should be able to initialize it (but not
+ both, of course.) (J3/04-007, section 15.3). */
+ TREE_PUBLIC(decl) = 1;
+ DECL_COMMON(decl) = 1;
+ }
+
/* If a variable is USE associated, it's always external. */
if (sym->attr.use_assoc)
{
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;
for (dim = 0; dim < GFC_TYPE_ARRAY_RANK (type); dim++)
{
if (GFC_TYPE_ARRAY_LBOUND (type, dim) == NULL_TREE)
- GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+ {
+ GFC_TYPE_ARRAY_LBOUND (type, dim) = create_index_var ("lbound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_LBOUND (type, dim)) = 1;
+ }
/* Don't try to use the unknown bound for assumed shape arrays. */
if (GFC_TYPE_ARRAY_UBOUND (type, dim) == NULL_TREE
&& (sym->as->type != AS_ASSUMED_SIZE
|| dim < GFC_TYPE_ARRAY_RANK (type) - 1))
- GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+ {
+ GFC_TYPE_ARRAY_UBOUND (type, dim) = create_index_var ("ubound", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_UBOUND (type, dim)) = 1;
+ }
if (GFC_TYPE_ARRAY_STRIDE (type, dim) == NULL_TREE)
- GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
+ {
+ GFC_TYPE_ARRAY_STRIDE (type, dim) = create_index_var ("stride", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_STRIDE (type, dim)) = 1;
+ }
}
if (GFC_TYPE_ARRAY_OFFSET (type) == NULL_TREE)
{
GFC_TYPE_ARRAY_OFFSET (type) = gfc_create_var_np (gfc_array_index_type,
"offset");
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_OFFSET (type)) = 1;
+
if (nest)
gfc_add_decl_to_parent_function (GFC_TYPE_ARRAY_OFFSET (type));
else
if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
&& sym->as->type != AS_ASSUMED_SIZE)
- GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+ {
+ GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
+ TREE_NO_WARNING (GFC_TYPE_ARRAY_SIZE (type)) = 1;
+ }
if (POINTER_TYPE_P (type))
{
tree type;
gfc_array_spec *as;
char *name;
- int packed;
+ gfc_packed packed;
int n;
bool known_size;
{
/* Create a descriptorless array pointer. */
as = sym->as;
- packed = 0;
+ packed = PACKED_NO;
if (!gfc_option.flag_repack_arrays)
{
if (as->type == AS_ASSUMED_SIZE)
- packed = 2;
+ packed = PACKED_FULL;
}
else
{
if (as->type == AS_EXPLICIT)
{
- packed = 2;
+ packed = PACKED_FULL;
for (n = 0; n < as->rank; n++)
{
if (!(as->upper[n]
&& as->lower[n]
&& as->upper[n]->expr_type == EXPR_CONSTANT
&& as->lower[n]->expr_type == EXPR_CONSTANT))
- packed = 1;
+ packed = PACKED_PARTIAL;
}
}
else
- packed = 1;
+ packed = PACKED_PARTIAL;
}
type = gfc_typenode_for_spec (&sym->ts);
DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = NULL_TREE;
type = gfc_sym_type (sym);
- packed = 2;
+ packed = PACKED_FULL;
}
ASM_FORMAT_PRIVATE_NAME (name, IDENTIFIER_POINTER (DECL_NAME (dummy)), 0);
frontend bugs. */
gcc_assert (sym->as->type != AS_DEFERRED);
- switch (packed)
- {
- case 1:
- GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
- break;
-
- case 2:
- GFC_DECL_PACKED_ARRAY (decl) = 1;
- break;
- }
+ if (packed == PACKED_PARTIAL)
+ GFC_DECL_PARTIAL_PACKED_ARRAY (decl) = 1;
+ else if (packed == PACKED_FULL)
+ GFC_DECL_PACKED_ARRAY (decl) = 1;
gfc_build_qualified_array (decl, sym);
int byref;
gcc_assert (sym->attr.referenced
- || sym->ns->proc_name->attr.if_source == IFSRC_IFBODY);
+ || sym->attr.use_assoc
+ || 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);
isym->resolve.f2 (&e, &argexpr, NULL);
else
{
- /* All specific intrinsics take less than 4 arguments. */
- gcc_assert (isym->formal->next->next->next == NULL);
- isym->resolve.f3 (&e, &argexpr, NULL, NULL);
+ if (isym->formal->next->next->next == NULL)
+ isym->resolve.f3 (&e, &argexpr, NULL, NULL);
+ else
+ {
+ /* All specific intrinsics take less than 5 arguments. */
+ gcc_assert (isym->formal->next->next->next->next == NULL);
+ isym->resolve.f4 (&e, &argexpr, NULL, NULL, NULL);
+ }
}
}
if (attr.pure || attr.elemental)
{
/* TODO: check if a pure SUBROUTINE has no INTENT(OUT) arguments
- including a alternate return. In that case it can also be
+ including an alternate return. In that case it can also be
marked as PURE. See also in gfc_get_extern_function_decl(). */
if (attr.function && !gfc_return_by_reference (sym))
DECL_IS_PURE (fndecl) = 1;
DECL_CONTEXT (parm) = fndecl;
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
+ gfc_finish_decl (parm);
DECL_ARTIFICIAL (parm) = 1;
arglist = chainon (arglist, parm);
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
DECL_ARTIFICIAL (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
+ gfc_finish_decl (length);
if (sym->ts.cl->backend_decl == NULL
|| sym->ts.cl->backend_decl == length)
{
DECL_ARG_TYPE (parm) = TREE_VALUE (typelist);
TREE_READONLY (parm) = 1;
DECL_ARTIFICIAL (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
+ gfc_finish_decl (parm);
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
DECL_ARTIFICIAL (length) = 1;
DECL_ARG_TYPE (length) = len_type;
TREE_READONLY (length) = 1;
- gfc_finish_decl (length, NULL_TREE);
+ gfc_finish_decl (length);
/* TODO: Check string lengths when -fbounds-check. */
if (!f->sym->ts.cl->length)
{
TREE_USED (length) = 1;
- if (!f->sym->ts.cl->backend_decl)
- f->sym->ts.cl->backend_decl = length;
- else
- {
- /* there is already another variable using this
- gfc_charlen node, build a new one for this variable
- and chain it into the list of gfc_charlens.
- This happens for e.g. in the case
- CHARACTER(*)::c1,c2
- since CHARACTER declarations on the same line share
- the same gfc_charlen node. */
- gfc_charlen *cl;
-
- cl = gfc_get_charlen ();
- cl->backend_decl = length;
- cl->next = f->sym->ts.cl->next;
- f->sym->ts.cl->next = cl;
- f->sym->ts.cl = cl;
- }
+ gcc_assert (!f->sym->ts.cl->backend_decl);
+ f->sym->ts.cl->backend_decl = length;
}
hidden_typelist = TREE_CHAIN (hidden_typelist);
/* All implementation args are read-only. */
TREE_READONLY (parm) = 1;
- gfc_finish_decl (parm, NULL_TREE);
+ gfc_finish_decl (parm);
f->sym->backend_decl = parm;
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_compare_string =
gfc_build_library_function_decl (get_identifier (PREFIX("compare_string")),
- gfc_int4_type_node,
- 4,
+ integer_type_node, 4,
gfc_charlen_type_node, pchar_type_node,
gfc_charlen_type_node, pchar_type_node);
gfc_charlen_type_node,
pchar_type_node);
- gfor_fndecl_string_repeat =
- gfc_build_library_function_decl (get_identifier (PREFIX("string_repeat")),
- void_type_node,
- 4,
- pchar_type_node,
- gfc_charlen_type_node,
- pchar_type_node,
- gfc_int4_type_node);
+ gfor_fndecl_string_minmax =
+ gfc_build_library_function_decl (get_identifier (PREFIX("string_minmax")),
+ void_type_node, -4,
+ build_pointer_type (gfc_charlen_type_node),
+ ppvoid_type_node, integer_type_node,
+ integer_type_node);
gfor_fndecl_ttynam =
gfc_build_library_function_decl (get_identifier (PREFIX("ttynam")),
3,
pchar_type_node,
gfc_charlen_type_node,
- gfc_c_int_type_node);
+ integer_type_node);
gfor_fndecl_fdate =
gfc_build_library_function_decl (get_identifier (PREFIX("fdate")),
/* BLAS functions. */
{
- tree pint = build_pointer_type (gfc_c_int_type_node);
+ tree pint = build_pointer_type (integer_type_node);
tree ps = build_pointer_type (gfc_get_real_type (gfc_default_real_kind));
tree pd = build_pointer_type (gfc_get_real_type (gfc_default_double_kind));
tree pc = build_pointer_type (gfc_get_complex_type (gfc_default_real_kind));
: "sgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, ps, ps, pint,
- ps, pint, ps, ps, pint, gfc_c_int_type_node,
- gfc_c_int_type_node);
+ ps, pint, ps, ps, pint, integer_type_node,
+ integer_type_node);
gfor_fndecl_dgemm = gfc_build_library_function_decl
(get_identifier
(gfc_option.flag_underscoring ? "dgemm_"
: "dgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, pd, pd, pint,
- pd, pint, pd, pd, pint, gfc_c_int_type_node,
- gfc_c_int_type_node);
+ pd, pint, pd, pd, pint, integer_type_node,
+ integer_type_node);
gfor_fndecl_cgemm = gfc_build_library_function_decl
(get_identifier
(gfc_option.flag_underscoring ? "cgemm_"
: "cgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, pc, pc, pint,
- pc, pint, pc, pc, pint, gfc_c_int_type_node,
- gfc_c_int_type_node);
+ pc, pint, pc, pc, pint, integer_type_node,
+ integer_type_node);
gfor_fndecl_zgemm = gfc_build_library_function_decl
(get_identifier
(gfc_option.flag_underscoring ? "zgemm_"
: "zgemm"),
void_type_node, 15, pchar_type_node,
pchar_type_node, pint, pint, pint, pz, pz, pint,
- pz, pint, pz, pz, pint, gfc_c_int_type_node,
- gfc_c_int_type_node);
+ pz, pint, pz, pz, pint, integer_type_node,
+ integer_type_node);
}
/* Other functions. */
void
gfc_build_builtin_function_decls (void)
{
- tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tree gfc_int4_type_node = gfc_get_int_type (4);
- tree gfc_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, 1, pvoid_type_node);
-
- gfor_fndecl_allocate =
- gfc_build_library_function_decl (get_identifier (PREFIX("allocate")),
- 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")),
- 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, 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_select_string =
gfc_build_library_function_decl (get_identifier (PREFIX("select_string")),
- pvoid_type_node, 0);
+ integer_type_node, 0);
gfor_fndecl_runtime_error =
gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error")),
- void_type_node, 1, pchar_type_node);
+ void_type_node, -1, pchar_type_node);
/* The runtime_error function does not return. */
TREE_THIS_VOLATILE (gfor_fndecl_runtime_error) = 1;
+ gfor_fndecl_runtime_error_at =
+ gfc_build_library_function_decl (get_identifier (PREFIX("runtime_error_at")),
+ void_type_node, -2, pchar_type_node,
+ pchar_type_node);
+ /* The runtime_error_at function does not return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_runtime_error_at) = 1;
+
+ gfor_fndecl_generate_error =
+ gfc_build_library_function_decl (get_identifier (PREFIX("generate_error")),
+ void_type_node, 3, pvoid_type_node,
+ integer_type_node, pchar_type_node);
+
+ gfor_fndecl_os_error =
+ gfc_build_library_function_decl (get_identifier (PREFIX("os_error")),
+ void_type_node, 1, pchar_type_node);
+ /* The runtime_error function does not return. */
+ TREE_THIS_VOLATILE (gfor_fndecl_os_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);
+ void_type_node, 1, integer_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);
+ /* Keep the array dimension in sync with the call, later in this file. */
+ gfor_fndecl_set_options =
+ gfc_build_library_function_decl (get_identifier (PREFIX("set_options")),
+ void_type_node, 2, integer_type_node,
+ pvoid_type_node);
gfor_fndecl_set_convert =
gfc_build_library_function_decl (get_identifier (PREFIX("set_convert")),
- void_type_node, 1, gfc_c_int_type_node);
+ void_type_node, 1, integer_type_node);
gfor_fndecl_set_record_marker =
gfc_build_library_function_decl (get_identifier (PREFIX("set_record_marker")),
- void_type_node, 1, gfc_c_int_type_node);
+ void_type_node, 1, integer_type_node);
gfor_fndecl_set_max_subrecord_length =
gfc_build_library_function_decl (get_identifier (PREFIX("set_max_subrecord_length")),
- void_type_node, 1, gfc_c_int_type_node);
+ void_type_node, 1, integer_type_node);
gfor_fndecl_in_pack = gfc_build_library_function_decl (
get_identifier (PREFIX("internal_pack")),
gfor_fndecl_associated =
gfc_build_library_function_decl (
get_identifier (PREFIX("associated")),
- gfc_logical4_type_node,
- 2,
- ppvoid_type_node,
+ integer_type_node, 2, ppvoid_type_node,
ppvoid_type_node);
gfc_build_intrinsic_function_decls ();
{
stmtblock_t body;
- gfc_finish_decl (cl->backend_decl, NULL_TREE);
+ gfc_finish_decl (cl->backend_decl);
gfc_start_block (&body);
gfc_init_block (&body);
for (f = proc_sym->formal; f; f = f->next)
- if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
- {
- gcc_assert (f->sym->ts.cl->backend_decl != NULL);
- if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
- gfc_trans_vla_type_sizes (f->sym, &body);
- }
+ {
+ if (f->sym && f->sym->tlink == NULL && f->sym->ts.type == BT_CHARACTER)
+ {
+ gcc_assert (f->sym->ts.cl->backend_decl != NULL);
+ if (TREE_CODE (f->sym->ts.cl->backend_decl) == PARM_DECL)
+ gfc_trans_vla_type_sizes (f->sym, &body);
+ }
+
+ /* If an INTENT(OUT) dummy of derived type has a default
+ initializer, it must be initialized here. */
+ if (f->sym && f->sym->attr.intent == INTENT_OUT
+ && f->sym->ts.type == BT_DERIVED
+ && !f->sym->ts.derived->attr.alloc_comp
+ && f->sym->value)
+ {
+ gfc_expr *tmpe;
+ tree tmp, present;
+ gcc_assert (!f->sym->attr.allocatable);
+ gfc_set_sym_referenced (f->sym);
+ tmpe = gfc_lval_expr_from_sym (f->sym);
+ tmp = gfc_trans_assignment (tmpe, f->sym->value, false);
+
+ present = gfc_conv_expr_present (f->sym);
+ tmp = build3 (COND_EXPR, TREE_TYPE (tmp), present,
+ tmp, build_empty_stmt ());
+ gfc_add_expr_to_block (&body, tmp);
+ gfc_free_expr (tmpe);
+ }
+ }
if (gfc_return_by_reference (proc_sym) && proc_sym->ts.type == BT_CHARACTER
&& current_fake_result_decl != NULL)
if (sym->attr.entry)
return;
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
+
/* Only output variables and array valued parameters. */
if (sym->attr.flavor != FL_VARIABLE
&& (sym->attr.flavor != FL_PARAMETER || sym->attr.dimension == 0))
}
-/* Check for dependencies in the character length and array spec. */
+/* Check for dependencies in the character length and array spec. */
static void
generate_dependency_declarations (gfc_symbol *sym)
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
- else if (sym->attr.dummy && warn_unused_parameter)
- gfc_warning ("Unused parameter %s declared at %L", sym->name,
+ /* INTENT(out) dummy arguments are likely meant to be set. */
+ else if (warn_unused_variable
+ && sym->attr.dummy
+ && sym->attr.intent == INTENT_OUT)
+ gfc_warning ("Dummy argument '%s' at %L was declared INTENT(OUT) but was not set",
+ sym->name, &sym->declared_at);
+ /* Specific warning for unused dummy arguments. */
+ else if (warn_unused_variable && sym->attr.dummy)
+ gfc_warning ("Unused dummy argument '%s' at %L", sym->name,
&sym->declared_at);
/* Warn for unused variables, but not if they're inside a common
block or are use-associated. */
else if (warn_unused_variable
&& !(sym->attr.in_common || sym->attr.use_assoc))
- gfc_warning ("Unused variable %s declared at %L", sym->name,
+ 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
sym->attr.referenced = 1;
gfc_get_symbol_decl (sym);
}
+
+ /* We do not want the middle-end to warn about unused parameters
+ as this was already done above. */
+ if (sym->attr.dummy && sym->backend_decl != NULL_TREE)
+ TREE_NO_WARNING(sym->backend_decl) = 1;
+ }
+ else if (sym->attr.flavor == FL_PARAMETER)
+ {
+ if (warn_unused_parameter
+ && !sym->attr.referenced
+ && !sym->attr.use_assoc)
+ gfc_warning ("Unused parameter '%s' declared at %L", sym->name,
+ &sym->declared_at);
}
+
+ if (sym->attr.dummy == 1)
+ {
+ /* Modify the tree type for scalar character dummy arguments of bind(c)
+ procedures if they are passed by value. The tree type for them will
+ be promoted to INTEGER_TYPE for the middle end, which appears to be
+ what C would do with characters passed by-value. The value attribute
+ implies the dummy is a scalar. */
+ if (sym->attr.value == 1 && sym->backend_decl != NULL
+ && sym->ts.type == BT_CHARACTER && sym->ts.is_c_interop
+ && sym->ns->proc_name != NULL && sym->ns->proc_name->attr.is_bind_c)
+ gfc_conv_scalar_char_value (sym, NULL, NULL);
+ }
+
+ /* Make sure we convert the types of the derived types from iso_c_binding
+ into (void *). */
+ if (sym->attr.flavor != FL_PROCEDURE && sym->attr.is_iso_c
+ && sym->ts.type == BT_DERIVED)
+ sym->backend_decl = gfc_typenode_for_spec (&(sym->ts));
}
static void
/* Now generate the code for the body of this function. */
gfc_init_block (&body);
- /* If this is the main program, add a call to set_std to set up the
+ /* If this is the main program, add a call to set_options to set up the
runtime library Fortran language standard parameters. */
-
if (sym->attr.is_main_program)
{
- tree gfc_int4_type_node = gfc_get_int_type (4);
- tmp = build_call_expr (gfor_fndecl_set_std, 3,
- build_int_cst (gfc_int4_type_node,
- gfc_option.warn_std),
- build_int_cst (gfc_int4_type_node,
- gfc_option.allow_std),
- build_int_cst (gfc_int4_type_node,
- pedantic),
- build_int_cst (gfc_int4_type_node,
- gfc_option.flag_dump_core));
+ tree array_type, array, var;
+
+ /* Passing a new option to the library requires four modifications:
+ + add it to the tree_cons list below
+ + change the array size in the call to build_array_type
+ + change the first argument to the library call
+ gfor_fndecl_set_options
+ + modify the library (runtime/compile_options.c)! */
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.warn_std), NULL_TREE);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.allow_std), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node, pedantic), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.flag_dump_core), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.flag_backtrace), array);
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ gfc_option.flag_sign_zero), array);
+
+ array = tree_cons (NULL_TREE,
+ build_int_cst (integer_type_node,
+ flag_bounds_check), array);
+
+ array_type = build_array_type (integer_type_node,
+ build_index_type (build_int_cst (NULL_TREE,
+ 6)));
+ array = build_constructor_from_list (array_type, nreverse (array));
+ TREE_CONSTANT (array) = 1;
+ TREE_INVARIANT (array) = 1;
+ TREE_STATIC (array) = 1;
+
+ /* Create a static variable to hold the jump table. */
+ var = gfc_create_var (array_type, "options");
+ TREE_CONSTANT (var) = 1;
+ TREE_INVARIANT (var) = 1;
+ TREE_STATIC (var) = 1;
+ TREE_READONLY (var) = 1;
+ DECL_INITIAL (var) = array;
+ var = gfc_build_addr_expr (pvoid_type_node, var);
+
+ tmp = build_call_expr (gfor_fndecl_set_options, 2,
+ build_int_cst (integer_type_node, 7), var);
gfc_add_expr_to_block (&body, tmp);
}
needed. */
if (sym->attr.is_main_program && gfc_option.fpe != 0)
{
- tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_fpe, 1,
- build_int_cst (gfc_c_int_type_node,
+ build_int_cst (integer_type_node,
gfc_option.fpe));
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.convert != CONVERT_NATIVE)
{
- tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_convert, 1,
- build_int_cst (gfc_c_int_type_node,
+ build_int_cst (integer_type_node,
gfc_option.convert));
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.record_marker != 0)
{
- tree gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_record_marker, 1,
- build_int_cst (gfc_c_int_type_node,
+ build_int_cst (integer_type_node,
gfc_option.record_marker));
gfc_add_expr_to_block (&body, tmp);
}
if (sym->attr.is_main_program && gfc_option.max_subrecord_length != 0)
{
- tree gfc_c_int_type_node;
-
- gfc_c_int_type_node = gfc_get_int_type (gfc_c_int_kind);
tmp = build_call_expr (gfor_fndecl_set_max_subrecord_length,
1,
- build_int_cst (gfc_c_int_type_node,
+ build_int_cst (integer_type_node,
gfc_option.max_subrecord_length));
gfc_add_expr_to_block (&body, tmp);
}
if (result != NULL_TREE && sym->attr.function
&& sym->ts.type == BT_DERIVED
- && sym->ts.derived->attr.alloc_comp)
+ && sym->ts.derived->attr.alloc_comp
+ && !sym->attr.pointer)
{
rank = sym->as ? sym->as->rank : 0;
tmp2 = gfc_nullify_alloc_comp (sym->ts.derived, result, rank);
OSDN Git Service
