Skip to content

R
riscv-gcc-1
Commit c3f34952 by Tobias Burnus
Options

re PR fortran/39427 (F2003: Procedures with same name as types/type constructors) 

gcc/fortran
2011-11-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/39427
        PR fortran/37829
        * decl.c (match_data_constant, match_data_constant,
        * variable_decl,
        gfc_match_decl_type_spec, access_attr_decl,
        check_extended_derived_type, gfc_match_derived_decl,
        gfc_match_derived_decl, gfc_match_derived_decl) Modified to deal
        with DT constructors.
        * gfortran.h (gfc_find_dt_in_generic,
        gfc_convert_to_structure_constructor): New function prototypes.
        * interface.c (check_interface0, check_interface1,
        gfc_search_interface): Ignore DT constructors in generic list.
        * match.h (gfc_match_structure_constructor): Update prototype.
        * match.c (match_derived_type_spec): Ensure that one uses the DT
        not the generic function.
        * module.c (MOD_VERSION): Bump.
        (dt_lower_string, dt_upper_string): New functions.
        (find_use_name_n, find_use_operator, compare_true_names,
        find_true_name, add_true_name, fix_mio_expr, load_needed,
        read_module, write_dt_extensions, write_symbol): Changes to deal with
        different symtree vs. sym names.
        (create_derived_type): Create also generic procedure.
        * parse.c (gfc_fixup_sibling_symbols): Don't regard DT and
        * generic
        function as the same.
        * primary.c (gfc_convert_to_structure_constructor): New
        * function.
        (gfc_match_structure_constructor): Restructured; calls
        gfc_convert_to_structure_constructor.
        (build_actual_constructor, gfc_match_rvalue): Update for DT generic
        functions.
        * resolve.c (resolve_formal_arglist, resolve_structure_cons,
        is_illegal_recursion, resolve_generic_f, resolve_variable,
        resolve_fl_variable_derived, resolve_fl_derived0,
        resolve_symbol): Handle DT and DT generic constructors.
        * symbol.c (gfc_use_derived, gfc_undo_symbols,
        gen_special_c_interop_ptr, gen_cptr_param,
        generate_isocbinding_symbol, gfc_get_derived_super_type): Handle
        derived-types, which are hidden in the generic type.
        (gfc_find_dt_in_generic): New function
        * trans-array.c (gfc_conv_array_initializer): Replace
        * FL_PARAMETER
        expr by actual value.
        * trans-decl.c (gfc_get_module_backend_decl,
        * gfc_trans_use_stmts):
        Ensure that we use the DT and not the generic function.
        * trans-types.c (gfc_get_derived_type): Ensure that we use the
        * DT
        and not the generic procedure.

gcc/testsuite/
2011-11-16  Tobias Burnus  <burnus@net-b.de>

        PR fortran/39427
        PR fortran/37829
        * gfortran.dg/constructor_1.f90: New.
        * gfortran.dg/constructor_2.f90: New.
        * gfortran.dg/constructor_3.f90: New.
        * gfortran.dg/constructor_4.f90: New.
        * gfortran.dg/constructor_5.f90: New.
        * gfortran.dg/constructor_6.f90: New.
        * gfortran.dg/use_only_5.f90: New.
        * gfortran.dg/c_ptr_tests_17.f90: New.
        * gfortran.dg/c_ptr_tests_18.f90: New.
        * gfortran.dg/used_types_25.f90: New.
        * gfortran.dg/used_types_26.f90: New
        * gfortran.dg/type_decl_3.f90: New.
        * gfortran.dg/function_types_3.f90: Update dg-error.
        * gfortran.dg/result_1.f90: Ditto.
        * gfortran.dg/structure_constructor_3.f03: Ditto.
        * gfortran.dg/structure_constructor_4.f03: Ditto.

From-SVN: r181425
parent 16e835bb
Showing with 1078 additions and 88 deletions
gcc/fortran/ChangeLog
2011-11-16 Tobias Burnus <burnus@net-b.de>
PR fortran/39427
PR fortran/37829
* decl.c (match_data_constant, match_data_constant, variable_decl,
gfc_match_decl_type_spec, access_attr_decl,
check_extended_derived_type, gfc_match_derived_decl,
gfc_match_derived_decl, gfc_match_derived_decl) Modified to deal
with DT constructors.
* gfortran.h (gfc_find_dt_in_generic,
gfc_convert_to_structure_constructor): New function prototypes.
* interface.c (check_interface0, check_interface1,
gfc_search_interface): Ignore DT constructors in generic list.
* match.h (gfc_match_structure_constructor): Update prototype.
* match.c (match_derived_type_spec): Ensure that one uses the DT
not the generic function.
* module.c (MOD_VERSION): Bump.
(dt_lower_string, dt_upper_string): New functions.
(find_use_name_n, find_use_operator, compare_true_names,
find_true_name, add_true_name, fix_mio_expr, load_needed,
read_module, write_dt_extensions, write_symbol): Changes to deal with
different symtree vs. sym names.
(create_derived_type): Create also generic procedure.
* parse.c (gfc_fixup_sibling_symbols): Don't regard DT and generic
function as the same.
* primary.c (gfc_convert_to_structure_constructor): New function.
(gfc_match_structure_constructor): Restructured; calls
gfc_convert_to_structure_constructor.
(build_actual_constructor, gfc_match_rvalue): Update for DT generic
functions.
* resolve.c (resolve_formal_arglist, resolve_structure_cons,
is_illegal_recursion, resolve_generic_f, resolve_variable,
resolve_fl_variable_derived, resolve_fl_derived0,
resolve_symbol): Handle DT and DT generic constructors.
* symbol.c (gfc_use_derived, gfc_undo_symbols,
gen_special_c_interop_ptr, gen_cptr_param,
generate_isocbinding_symbol, gfc_get_derived_super_type): Handle
derived-types, which are hidden in the generic type.
(gfc_find_dt_in_generic): New function
* trans-array.c (gfc_conv_array_initializer): Replace FL_PARAMETER
expr by actual value.
* trans-decl.c (gfc_get_module_backend_decl, gfc_trans_use_stmts):
Ensure that we use the DT and not the generic function.
* trans-types.c (gfc_get_derived_type): Ensure that we use the DT
and not the generic procedure.
2011-11-14 Tobias Burnus <burnus@net-b.de>
PR fortran/51073
......
gcc/fortran/gfortran.h
......@@ -2630,6 +2630,7 @@ gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
bool gfc_is_associate_pointer (gfc_symbol*);
gfc_symbol * gfc_find_dt_in_generic (gfc_symbol *);
/* intrinsic.c -- true if working in an init-expr, false otherwise. */
extern bool gfc_init_expr_flag;
......@@ -2874,6 +2875,9 @@ match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool, bool);
int gfc_check_digit (char, int);
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *);
gfc_try gfc_convert_to_structure_constructor (gfc_expr *, gfc_symbol *,
gfc_expr **,
gfc_actual_arglist **, bool);
/* trans.c */
void gfc_generate_code (gfc_namespace *);
......
gcc/fortran/interface.c
......@@ -1262,8 +1262,9 @@ check_interface0 (gfc_interface *p, const char *interface_name)
{
/* Make sure all symbols in the interface have been defined as
functions or subroutines. */
if ((!p->sym->attr.function && !p->sym->attr.subroutine)
|| !p->sym->attr.if_source)
if (((!p->sym->attr.function && !p->sym->attr.subroutine)
|| !p->sym->attr.if_source)
&& p->sym->attr.flavor != FL_DERIVED)
{
if (p->sym->attr.external)
gfc_error ("Procedure '%s' in %s at %L has no explicit interface",
......@@ -1276,11 +1277,18 @@ check_interface0 (gfc_interface *p, const char *interface_name)
}
/* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */
if ((psave->sym->attr.function && !p->sym->attr.function)
if ((psave->sym->attr.function && !p->sym->attr.function
&& p->sym->attr.flavor != FL_DERIVED)
|| (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
{
gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
" or all FUNCTIONs", interface_name, &p->sym->declared_at);
if (p->sym->attr.flavor != FL_DERIVED)
gfc_error ("In %s at %L procedures must be either all SUBROUTINEs"
" or all FUNCTIONs", interface_name,
&p->sym->declared_at);
else
gfc_error ("In %s at %L procedures must be all FUNCTIONs as the "
"generic name is also the name of a derived type",
interface_name, &p->sym->declared_at);
return 1;
}
......@@ -1336,8 +1344,10 @@ check_interface1 (gfc_interface *p, gfc_interface *q0,
if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue;
if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag,
0, NULL, 0))
if (p->sym->attr.flavor != FL_DERIVED
&& q->sym->attr.flavor != FL_DERIVED
&& gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
generic_flag, 0, NULL, 0))
{
if (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
......@@ -3019,6 +3029,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
for (; intr; intr = intr->next)
{
if (intr->sym->attr.flavor == FL_DERIVED)
continue;
if (sub_flag && intr->sym->attr.function)
continue;
if (!sub_flag && intr->sym->attr.subroutine)
......
gcc/fortran/match.c
......@@ -1920,6 +1920,9 @@ match_derived_type_spec (gfc_typespec *ts)
gfc_find_symbol (name, NULL, 1, &derived);
if (derived && derived->attr.flavor == FL_PROCEDURE && derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
if (derived && derived->attr.flavor == FL_DERIVED)
{
ts->type = BT_DERIVED;
......
gcc/fortran/match.h
......@@ -206,7 +206,7 @@ match gfc_match_bind_c (gfc_symbol *, bool);
match gfc_get_type_attr_spec (symbol_attribute *, char*);
/* primary.c. */
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **, bool);
match gfc_match_structure_constructor (gfc_symbol *, gfc_expr **);
match gfc_match_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **);
......
gcc/fortran/module.c
......@@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */
#define MOD_VERSION "7"
#define MOD_VERSION "8"
/* Structure that describes a position within a module file. */
......@@ -429,6 +429,34 @@ resolve_fixups (fixup_t *f, void *gp)
}
/* Convert a string such that it starts with a lower-case character. Used
to convert the symtree name of a derived-type to the symbol name or to
the name of the associated generic function. */
const char *
dt_lower_string (const char *name)
{
if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
return gfc_get_string ("%c%s", (char) TOLOWER ((unsigned char) name[0]),
&name[1]);
return gfc_get_string (name);
}
/* Convert a string such that it starts with an upper-case character. Used to
return the symtree-name for a derived type; the symbol name itself and the
symtree/symbol name of the associated generic function start with a lower-
case character. */
const char *
dt_upper_string (const char *name)
{
if (name[0] != (char) TOUPPER ((unsigned char) name[0]))
return gfc_get_string ("%c%s", (char) TOUPPER ((unsigned char) name[0]),
&name[1]);
return gfc_get_string (name);
}
/* Call here during module reading when we know what pointer to
associate with an integer. Any fixups that exist are resolved at
this time. */
......@@ -699,12 +727,18 @@ static const char *
find_use_name_n (const char *name, int *inst, bool interface)
{
gfc_use_rename *u;
const char *low_name = NULL;
int i;
/* For derived types. */
if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
low_name = dt_lower_string (name);
i = 0;
for (u = gfc_rename_list; u; u = u->next)
{
if (strcmp (u->use_name, name) != 0
if ((!low_name && strcmp (u->use_name, name) != 0)
|| (low_name && strcmp (u->use_name, low_name) != 0)
|| (u->op == INTRINSIC_USER && !interface)
|| (u->op != INTRINSIC_USER && interface))
continue;
......@@ -723,6 +757,13 @@ find_use_name_n (const char *name, int *inst, bool interface)
u->found = 1;
if (low_name)
{
if (u->local_name[0] == '\0')
return name;
return dt_upper_string (u->local_name);
}
return (u->local_name[0] != '\0') ? u->local_name : name;
}
......@@ -780,6 +821,7 @@ find_use_operator (gfc_intrinsic_op op)
typedef struct true_name
{
BBT_HEADER (true_name);
const char *name;
gfc_symbol *sym;
}
true_name;
......@@ -803,7 +845,7 @@ compare_true_names (void *_t1, void *_t2)
if (c != 0)
return c;
return strcmp (t1->sym->name, t2->sym->name);
return strcmp (t1->name, t2->name);
}
......@@ -817,7 +859,7 @@ find_true_name (const char *name, const char *module)
gfc_symbol sym;
int c;
sym.name = gfc_get_string (name);
t.name = gfc_get_string (name);
if (module != NULL)
sym.module = gfc_get_string (module);
else
......@@ -847,6 +889,10 @@ add_true_name (gfc_symbol *sym)
t = XCNEW (true_name);
t->sym = sym;
if (sym->attr.flavor == FL_DERIVED)
t->name = dt_upper_string (sym->name);
else
t->name = sym->name;
gfc_insert_bbt (&true_name_root, t, compare_true_names);
}
......@@ -858,13 +904,19 @@ add_true_name (gfc_symbol *sym)
static void
build_tnt (gfc_symtree *st)
{
const char *name;
if (st == NULL)
return;
build_tnt (st->left);
build_tnt (st->right);
if (find_true_name (st->n.sym->name, st->n.sym->module) != NULL)
if (st->n.sym->attr.flavor == FL_DERIVED)
name = dt_upper_string (st->n.sym->name);
else
name = st->n.sym->name;
if (find_true_name (name, st->n.sym->module) != NULL)
return;
add_true_name (st->n.sym);
......@@ -2986,8 +3038,12 @@ fix_mio_expr (gfc_expr *e)
namespace to see if the required, non-contained symbol is available
yet. If so, the latter should be written. */
if (e->symtree->n.sym && check_unique_name (e->symtree->name))
ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
e->symtree->n.sym->name);
{
const char *name = e->symtree->n.sym->name;
if (e->symtree->n.sym->attr.flavor == FL_DERIVED)
name = dt_upper_string (name);
ns_st = gfc_find_symtree (gfc_current_ns->sym_root, name);
}
/* On the other hand, if the existing symbol is the module name or the
new symbol is a dummy argument, do not do the promotion. */
......@@ -4205,6 +4261,7 @@ load_needed (pointer_info *p)
1, &ns->proc_name);
sym = gfc_new_symbol (p->u.rsym.true_name, ns);
sym->name = dt_lower_string (p->u.rsym.true_name);
sym->module = gfc_get_string (p->u.rsym.module);
strcpy (sym->binding_label, p->u.rsym.binding_label);
......@@ -4497,6 +4554,7 @@ read_module (void)
{
info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
gfc_current_ns);
info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module);
......@@ -4835,7 +4893,7 @@ write_dt_extensions (gfc_symtree *st)
return;
mio_lparen ();
mio_pool_string (&st->n.sym->name);
mio_pool_string (&st->name);
if (st->n.sym->module != NULL)
mio_pool_string (&st->n.sym->module);
else
......@@ -4870,7 +4928,15 @@ write_symbol (int n, gfc_symbol *sym)
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_integer (&n);
mio_pool_string (&sym->name);
if (sym->attr.flavor == FL_DERIVED)
{
const char *name;
name = dt_upper_string (sym->name);
mio_pool_string (&name);
}
else
mio_pool_string (&sym->name);
mio_pool_string (&sym->module);
if (sym->attr.is_bind_c || sym->attr.is_iso_c)
......@@ -5566,7 +5632,8 @@ create_derived_type (const char *name, const char *modname,
intmod_id module, int id)
{
gfc_symtree *tmp_symtree;
gfc_symbol *sym;
gfc_symbol *sym, *dt_sym;
gfc_interface *intr, *head;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (tmp_symtree != NULL)
......@@ -5579,18 +5646,35 @@ create_derived_type (const char *name, const char *modname,
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
sym->module = gfc_get_string (modname);
sym->from_intmod = module;
sym->intmod_sym_id = id;
sym->attr.flavor = FL_DERIVED;
sym->attr.private_comp = 1;
sym->attr.zero_comp = 1;
sym->attr.use_assoc = 1;
sym->attr.flavor = FL_PROCEDURE;
sym->attr.function = 1;
sym->attr.generic = 1;
gfc_get_sym_tree (dt_upper_string (sym->name),
gfc_current_ns, &tmp_symtree, false);
dt_sym = tmp_symtree->n.sym;
dt_sym->name = gfc_get_string (sym->name);
dt_sym->attr.flavor = FL_DERIVED;
dt_sym->attr.private_comp = 1;
dt_sym->attr.zero_comp = 1;
dt_sym->attr.use_assoc = 1;
dt_sym->module = gfc_get_string (modname);
dt_sym->from_intmod = module;
dt_sym->intmod_sym_id = id;
head = sym->generic;
intr = gfc_get_interface ();
intr->sym = dt_sym;
intr->where = gfc_current_locus;
intr->next = head;
sym->generic = intr;
sym->attr.if_source = IFSRC_DECL;
}
/* USE the ISO_FORTRAN_ENV intrinsic module. */
static void
......
gcc/fortran/parse.c
......@@ -3881,6 +3881,12 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
goto fixup_contained;
if ((st->n.sym->attr.flavor == FL_DERIVED
&& sym->attr.generic && sym->attr.function)
||(sym->attr.flavor == FL_DERIVED
&& st->n.sym->attr.generic && st->n.sym->attr.function))
goto fixup_contained;
old_sym = st->n.sym;
if (old_sym->ns == ns
&& !old_sym->attr.contained
......
gcc/fortran/resolve.c
......@@ -454,7 +454,8 @@ resolve_formal_arglist (gfc_symbol *proc)
static void
find_arglists (gfc_symbol *sym)
{
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns)
if (sym->attr.if_source == IFSRC_UNKNOWN || sym->ns != gfc_current_ns
|| sym->attr.flavor == FL_DERIVED)
return;
resolve_formal_arglist (sym);
......@@ -967,13 +968,6 @@ resolve_structure_cons (gfc_expr *expr, int init)
resolve_fl_derived0 (expr->ts.u.derived);
cons = gfc_constructor_first (expr->value.constructor);
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
want. */
if (expr->ref)
comp = expr->ref->u.c.sym->components;
else
comp = expr->ts.u.derived->components;
/* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */
......@@ -992,6 +986,14 @@ resolve_structure_cons (gfc_expr *expr, int init)
&& cons->expr && cons->expr->expr_type == EXPR_NULL)
return SUCCESS;
/* A constructor may have references if it is the result of substituting a
parameter variable. In this case we just pull out the component we
want. */
if (expr->ref)
comp = expr->ref->u.c.sym->components;
else
comp = expr->ts.u.derived->components;
for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{
int rank;
......@@ -1401,7 +1403,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
gfc_symbol* context_proc;
gfc_namespace* real_context;
if (sym->attr.flavor == FL_PROGRAM)
if (sym->attr.flavor == FL_PROGRAM
|| sym->attr.flavor == FL_DERIVED)
return false;
gcc_assert (sym->attr.flavor == FL_PROCEDURE);
......@@ -2323,6 +2326,7 @@ resolve_generic_f (gfc_expr *expr)
{
gfc_symbol *sym;
match m;
gfc_interface *intr = NULL;
sym = expr->symtree->n.sym;
......@@ -2335,6 +2339,11 @@ resolve_generic_f (gfc_expr *expr)
return FAILURE;
generic:
if (!intr)
for (intr = sym->generic; intr; intr = intr->next)
if (intr->sym->attr.flavor == FL_DERIVED)
break;
if (sym->ns->parent == NULL)
break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
......@@ -2347,16 +2356,25 @@ generic:
/* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */
if (sym && !gfc_is_intrinsic (sym, 0, expr->where))
if (sym && !intr && !gfc_is_intrinsic (sym, 0, expr->where))
{
gfc_error ("There is no specific function for the generic '%s' at %L",
expr->symtree->n.sym->name, &expr->where);
gfc_error ("There is no specific function for the generic '%s' "
"at %L", expr->symtree->n.sym->name, &expr->where);
return FAILURE;
}
if (intr)
{
if (gfc_convert_to_structure_constructor (expr, intr->sym, NULL, NULL,
false) != SUCCESS)
return FAILURE;
return resolve_structure_cons (expr, 0);
}
m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES)
return SUCCESS;
if (m == MATCH_NO)
gfc_error ("Generic function '%s' at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name,
......@@ -5053,6 +5071,9 @@ resolve_variable (gfc_expr *e)
if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
return FAILURE;
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->attr.generic)
sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
/* On the other hand, the parser may not have known this is an array;
in this case, we have to add a FULL reference. */
if (sym->assoc && sym->attr.dimension && !e->ref)
......@@ -10152,6 +10173,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
{
gfc_symbol *s;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &s);
if (s && s->attr.generic)
s = gfc_find_dt_in_generic (s);
if (s && s->attr.flavor != FL_DERIVED)
{
gfc_error ("The type '%s' cannot be host associated at %L "
......@@ -11718,6 +11741,13 @@ resolve_fl_derived0 (gfc_symbol *sym)
}
}
if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.generic)
c->ts.u.derived = gfc_find_dt_in_generic (c->ts.u.derived);
else if (c->ts.type == BT_CLASS && c->attr.class_ok
&& CLASS_DATA (c)->ts.u.derived->attr.generic)
CLASS_DATA (c)->ts.u.derived
= gfc_find_dt_in_generic (CLASS_DATA (c)->ts.u.derived);
if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
&& c->attr.pointer && c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp)
......@@ -11788,6 +11818,23 @@ resolve_fl_derived0 (gfc_symbol *sym)
static gfc_try
resolve_fl_derived (gfc_symbol *sym)
{
gfc_symbol *gen_dt = NULL;
if (!sym->attr.is_class)
gfc_find_symbol (sym->name, sym->ns, 0, &gen_dt);
if (gen_dt && gen_dt->generic && gen_dt->generic->next
&& gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Generic name '%s' of "
"function '%s' at %L being the same name as derived "
"type at %L", sym->name,
gen_dt->generic->sym == sym
? gen_dt->generic->next->sym->name
: gen_dt->generic->sym->name,
gen_dt->generic->sym == sym
? &gen_dt->generic->next->sym->declared_at
: &gen_dt->generic->sym->declared_at,
&sym->declared_at) == FAILURE)
return FAILURE;
if (sym->attr.is_class && sym->ts.u.derived == NULL)
{
/* Fix up incomplete CLASS symbols. */
......@@ -12191,6 +12238,20 @@ resolve_symbol (gfc_symbol *sym)
}
}
if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
&& sym->ts.u.derived->attr.generic)
{
sym->ts.u.derived = gfc_find_dt_in_generic (sym->ts.u.derived);
if (!sym->ts.u.derived)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
"which has not been defined", sym->name,
&sym->declared_at, sym->ts.u.derived->name);
sym->ts.type = BT_UNKNOWN;
return;
}
}
/* If the symbol is marked as bind(c), verify it's type and kind. Do not
do this for something that was implicitly typed because that is handled
in gfc_set_default_type. Handle dummy arguments and procedure
......@@ -12260,7 +12321,8 @@ resolve_symbol (gfc_symbol *sym)
the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */
if (sym->ts.type == BT_DERIVED && sym->ts.u.derived->components == NULL
if (sym->ts.type == BT_DERIVED && !sym->attr.is_iso_c
&& sym->ts.u.derived->components == NULL
&& !sym->ts.u.derived->attr.zero_comp)
{
gfc_error ("The derived type '%s' at %L is of type '%s', "
......@@ -12276,22 +12338,9 @@ resolve_symbol (gfc_symbol *sym)
if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->attr.use_assoc
&& sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE)
{
gfc_symbol *ds;
if (resolve_fl_derived (sym->ts.u.derived) == FAILURE)
return;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 1, &ds);
if (!ds && sym->attr.function && gfc_check_symbol_access (sym))
{
symtree = gfc_new_symtree (&sym->ns->sym_root,
sym->ts.u.derived->name);
symtree->n.sym = sym->ts.u.derived;
sym->ts.u.derived->refs++;
}
}
&& sym->ns->proc_name->attr.flavor == FL_MODULE
&& resolve_fl_derived (sym->ts.u.derived) == FAILURE)
return;
/* Unless the derived-type declaration is use associated, Fortran 95
does not allow public entries of private derived types.
......
gcc/fortran/trans-array.c
......@@ -5027,6 +5027,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
tree index, range;
VEC(constructor_elt,gc) *v = NULL;
if (expr->expr_type == EXPR_VARIABLE
&& expr->symtree->n.sym->attr.flavor == FL_PARAMETER
&& expr->symtree->n.sym->value)
expr = expr->symtree->n.sym->value;
switch (expr->expr_type)
{
case EXPR_CONSTANT:
......
gcc/fortran/trans-decl.c
......@@ -699,6 +699,18 @@ gfc_get_module_backend_decl (gfc_symbol *sym)
}
else if (sym->attr.flavor == FL_DERIVED)
{
if (s && s->attr.flavor == FL_PROCEDURE)
{
gfc_interface *intr;
gcc_assert (s->attr.generic);
for (intr = s->generic; intr; intr = intr->next)
if (intr->sym->attr.flavor == FL_DERIVED)
{
s = intr->sym;
break;
}
}
if (!s->backend_decl)
s->backend_decl = gfc_get_derived_type (s);
gfc_copy_dt_decls_ifequal (s, sym, true);
......@@ -4035,7 +4047,18 @@ gfc_trans_use_stmts (gfc_namespace * ns)
st = gfc_find_symtree (ns->sym_root,
rent->local_name[0]
? rent->local_name : rent->use_name);
gcc_assert (st);
/* The following can happen if a derived type is renamed. */
if (!st)
{
char *name;
name = xstrdup (rent->local_name[0]
? rent->local_name : rent->use_name);
name[0] = (char) TOUPPER ((unsigned char) name[0]);
st = gfc_find_symtree (ns->sym_root, name);
free (name);
gcc_assert (st);
}
/* Sometimes, generic interfaces wind up being over-ruled by a
local symbol (see PR41062). */
......
gcc/fortran/trans-types.c
......@@ -2257,6 +2257,10 @@ gfc_get_derived_type (gfc_symbol * derived)
gfc_dt_list *dt;
gfc_namespace *ns;
if (derived && derived->attr.flavor == FL_PROCEDURE
&& derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
/* See if it's one of the iso_c_binding derived types. */
......
gcc/testsuite/ChangeLog
2011-11-16 Tobias Burnus <burnus@net-b.de>
PR fortran/39427
PR fortran/37829
* gfortran.dg/constructor_1.f90: New.
* gfortran.dg/constructor_2.f90: New.
* gfortran.dg/constructor_3.f90: New.
* gfortran.dg/constructor_4.f90: New.
* gfortran.dg/constructor_5.f90: New.
* gfortran.dg/constructor_6.f90: New.
* gfortran.dg/use_only_5.f90: New.
* gfortran.dg/c_ptr_tests_17.f90: New.
* gfortran.dg/c_ptr_tests_18.f90: New.
* gfortran.dg/used_types_25.f90: New.
* gfortran.dg/used_types_26.f90: New
* gfortran.dg/type_decl_3.f90: New.
* gfortran.dg/function_types_3.f90: Update dg-error.
* gfortran.dg/result_1.f90: Ditto.
* gfortran.dg/structure_constructor_3.f03: Ditto.
* gfortran.dg/structure_constructor_4.f03: Ditto.
2011-10-16 Matthew Gretton-Dann <matthew.gretton-dann@arm.com>
* gcc.dg/vect/pr30858.c: Update expected output for
......@@ -12,7 +33,7 @@
2011-11-16 Razya Ladelsky <razya@il.ibm.com>
PR tree-optimization/49960
PR tree-optimization/49960
* gcc.dg/autopar/pr49960.c: New test.
* gcc.dg/autopar/pr49960-1.c: New test.
......
gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/37829
!
! Contributed by James Van Buskirk and Jerry DeLisle.
!
! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR.
module m3
use ISO_C_BINDING
implicit none
private
public kill_C_PTR
interface
function kill_C_PTR() bind(C)
import
implicit none
type(C_PTR) kill_C_PTR
end function kill_C_PTR
end interface
public kill_C_FUNPTR
interface
function kill_C_FUNPTR() bind(C)
import
implicit none
type(C_FUNPTR) kill_C_FUNPTR
end function kill_C_FUNPTR
end interface
end module m3
module m1
use m3
end module m1
program X
use m1
use ISO_C_BINDING
implicit none
type(C_PTR) cp
type(C_FUNPTR) fp
integer(C_INT),target :: i
interface
function fun() bind(C)
use ISO_C_BINDING
implicit none
real(C_FLOAT) fun
end function fun
end interface
cp = C_NULL_PTR
cp = C_LOC(i)
fp = C_NULL_FUNPTR
fp = C_FUNLOC(fun)
end program X
function fun() bind(C)
use ISO_C_BINDING
implicit none
real(C_FLOAT) fun
fun = 1.0
end function fun
function kill_C_PTR() bind(C)
use ISO_C_BINDING
implicit none
type(C_PTR) kill_C_PTR
integer(C_INT), pointer :: p
allocate(p)
kill_C_PTR = C_LOC(p)
end function kill_C_PTR
function kill_C_FUNPTR() bind(C)
use ISO_C_BINDING
implicit none
type(C_FUNPTR) kill_C_FUNPTR
interface
function fun() bind(C)
use ISO_C_BINDING
implicit none
real(C_FLOAT) fun
end function fun
end interface
kill_C_FUNPTR = C_FUNLOC(fun)
end function kill_C_FUNPTR
! { dg-final { cleanup-modules "m3 m1" } }
gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/37829
! PR fortran/45190
!
! Contributed by Mat Cross
!
! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR.
MODULE NAG_J_TYPES
USE ISO_C_BINDING, ONLY : C_PTR
IMPLICIT NONE
TYPE :: NAG_IMAGE
INTEGER :: WIDTH, HEIGHT, PXFMT, NCHAN
TYPE (C_PTR) :: PIXELS
END TYPE NAG_IMAGE
END MODULE NAG_J_TYPES
program cfpointerstress
use nag_j_types
use iso_c_binding
implicit none
type(nag_image),pointer :: img
type(C_PTR) :: ptr
real, pointer :: r
allocate(r)
allocate(img)
r = 12
ptr = c_loc(img)
write(*,*) 'C_ASSOCIATED =', C_ASSOCIATED(ptr)
call c_f_pointer(ptr, img)
write(*,*) 'ASSOCIATED =', associated(img)
deallocate(r)
end program cfpointerstress
! { dg-final { cleanup-modules "nag_j_types" } }
gcc/testsuite/gfortran.dg/constructor_1.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/39427
!
! Check constructor functionality.
!
! Contributed by Damian Rouson.
!
module mycomplex_module
private
public :: mycomplex
type mycomplex
! private
real :: argument, modulus
end type
interface mycomplex
module procedure complex_to_mycomplex, two_reals_to_mycomplex
end interface
! :
contains
type(mycomplex) function complex_to_mycomplex(c)
complex, intent(in) :: c
! :
end function complex_to_mycomplex
type(mycomplex) function two_reals_to_mycomplex(x,y)
real, intent(in) :: x
real, intent(in), optional :: y
! :
end function two_reals_to_mycomplex
! :
end module mycomplex_module
! :
program myuse
use mycomplex_module
type(mycomplex) :: a, b, c
! :
a = mycomplex(argument=5.6, modulus=1.0) ! The structure constructor
c = mycomplex(x=0.0, y=1.0) ! A function reference
c = mycomplex(0.0, 1.0) ! A function reference
end program myuse
! { dg-final { cleanup-modules "mycomplex_module" } }
gcc/testsuite/gfortran.dg/constructor_2.f90 0 → 100644
! { dg-do run }
!
! PR fortran/39427
!
module foo_module
interface foo
procedure constructor
end interface
type foo
integer :: bar
end type
contains
type(foo) function constructor()
constructor%bar = 1
end function
subroutine test_foo()
type(foo) :: f
f = foo()
if (f%bar /= 1) call abort ()
f = foo(2)
if (f%bar /= 2) call abort ()
end subroutine test_foo
end module foo_module
! Same as foo_module but order
! of INTERFACE and TYPE reversed
module bar_module
type bar
integer :: bar
end type
interface bar
procedure constructor
end interface
contains
type(bar) function constructor()
constructor%bar = 3
end function
subroutine test_bar()
type(bar) :: f
f = bar()
if (f%bar /= 3) call abort ()
f = bar(4)
if (f%bar /= 4) call abort ()
end subroutine test_bar
end module bar_module
program main
use foo_module
use bar_module
implicit none
type(foo) :: f
type(bar) :: b
call test_foo()
f = foo()
if (f%bar /= 1) call abort ()
f = foo(2)
if (f%bar /= 2) call abort ()
call test_bar()
b = bar()
if (b%bar /= 3) call abort ()
b = bar(4)
if (b%bar /= 4) call abort ()
end program main
! { dg-final { cleanup-tree-dump "foo_module bar_module" } }
gcc/testsuite/gfortran.dg/constructor_3.f90 0 → 100644
! { dg-do run }
!
! PR fortran/39427
!
! Check constructor functionality.
!
!
module m
interface cons
procedure cons42
end interface cons
contains
integer function cons42()
cons42 = 42
end function cons42
end module m
module m2
type cons
integer :: j = -1
end type cons
interface cons
procedure consT
end interface cons
contains
type(cons) function consT(k)
integer :: k
consT%j = k**2
end function consT
end module m2
use m
use m2, only: cons
implicit none
type(cons) :: x
integer :: k
x = cons(3)
k = cons()
if (x%j /= 9) call abort ()
if (k /= 42) call abort ()
!print *, x%j
!print *, k
end
! { dg-final { cleanup-modules "m m2" } }
gcc/testsuite/gfortran.dg/constructor_4.f90 0 → 100644
! { dg-do compile }
! { dg-options "-std=f95" }
!
! PR fortran/39427
!
! Check constructor functionality.
!
!
module m
type t ! { dg-error "the same name as derived type" }
integer :: x
end type t
interface t
module procedure f
end interface t
contains
function f() ! { dg-error "the same name as derived type" }
type(t) :: f
end function
end module
module m2
interface t2
module procedure f2
end interface t2
type t2 ! { dg-error "the same name as derived type" }
integer :: x2
end type t2
contains
function f2() ! { dg-error "the same name as derived type" }
type(t2) :: f2
end function
end module
gcc/testsuite/gfortran.dg/constructor_5.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/39427
!
! Check constructor functionality.
!
!
module m
type t
integer :: x
end type t
interface t
module procedure f
end interface t
contains
function f()
type(t) :: f
end function
end module
module m2
interface t2
module procedure f2
end interface t2
type t2
integer :: x2
end type t2
contains
function f2()
type(t2) :: f2
end function
end module
! { dg-final { cleanup-modules "m m2" } }
gcc/testsuite/gfortran.dg/constructor_6.f90 0 → 100644
! { dg-do run }
!
! PR fortran/39427
!
! Contributed by Norman S. Clerman (in PR fortran/45155)
!
! Constructor test case
!
!
module test_cnt
integer, public, save :: my_test_cnt = 0
end module test_cnt
module Rational
use test_cnt
implicit none
private
type, public :: rational_t
integer :: n = 0, id = 1
contains
procedure, nopass :: Construct_rational_t
procedure :: Print_rational_t
procedure, private :: Rational_t_init
generic :: Rational_t => Construct_rational_t
generic :: print => Print_rational_t
end type rational_t
contains
function Construct_rational_t (message_) result (return_type)
character (*), intent (in) :: message_
type (rational_t) :: return_type
! print *, trim (message_)
if (my_test_cnt /= 1) call abort()
my_test_cnt = my_test_cnt + 1
call return_type % Rational_t_init
end function Construct_rational_t
subroutine Print_rational_t (this_)
class (rational_t), intent (in) :: this_
! print *, "n, id", this_% n, this_% id
if (my_test_cnt == 0) then
if (this_% n /= 0 .or. this_% id /= 1) call abort ()
else if (my_test_cnt == 2) then
if (this_% n /= 10 .or. this_% id /= 0) call abort ()
else
call abort ()
end if
my_test_cnt = my_test_cnt + 1
end subroutine Print_rational_t
subroutine Rational_t_init (this_)
class (rational_t), intent (in out) :: this_
this_% n = 10
this_% id = 0
end subroutine Rational_t_init
end module Rational
module Temp_node
use test_cnt
implicit none
private
real, parameter :: NOMINAL_TEMP = 20.0
type, public :: temp_node_t
real :: temperature = NOMINAL_TEMP
integer :: id = 1
contains
procedure :: Print_temp_node_t
procedure, private :: Temp_node_t_init
generic :: Print => Print_temp_node_t
end type temp_node_t
interface temp_node_t
module procedure Construct_temp_node_t
end interface
contains
function Construct_temp_node_t (message_) result (return_type)
character (*), intent (in) :: message_
type (temp_node_t) :: return_type
!print *, trim (message_)
if (my_test_cnt /= 4) call abort()
my_test_cnt = my_test_cnt + 1
call return_type % Temp_node_t_init
end function Construct_temp_node_t
subroutine Print_temp_node_t (this_)
class (temp_node_t), intent (in) :: this_
! print *, "temp, id", this_% temperature, this_% id
if (my_test_cnt == 3) then
if (this_% temperature /= 20 .or. this_% id /= 1) call abort ()
else if (my_test_cnt == 5) then
if (this_% temperature /= 10 .or. this_% id /= 0) call abort ()
else
call abort ()
end if
my_test_cnt = my_test_cnt + 1
end subroutine Print_temp_node_t
subroutine Temp_node_t_init (this_)
class (temp_node_t), intent (in out) :: this_
this_% temperature = 10.0
this_% id = 0
end subroutine Temp_node_t_init
end module Temp_node
program Struct_over
use test_cnt
use Rational, only : rational_t
use Temp_node, only : temp_node_t
implicit none
type (rational_t) :: sample_rational_t
type (temp_node_t) :: sample_temp_node_t
! print *, "rational_t"
! print *, "----------"
! print *, ""
!
! print *, "after declaration"
if (my_test_cnt /= 0) call abort()
call sample_rational_t % print
if (my_test_cnt /= 1) call abort()
sample_rational_t = sample_rational_t % rational_t ("using override")
if (my_test_cnt /= 2) call abort()
! print *, "after override"
! call print (sample_rational_t)
! call sample_rational_t % print ()
call sample_rational_t % print
if (my_test_cnt /= 3) call abort()
! print *, "sample_t"
! print *, "--------"
! print *, ""
!
! print *, "after declaration"
call sample_temp_node_t % print
if (my_test_cnt /= 4) call abort()
sample_temp_node_t = temp_node_t ("using override")
if (my_test_cnt /= 5) call abort()
! print *, "after override"
! call print (sample_rational_t)
! call sample_rational_t % print ()
call sample_temp_node_t % print
if (my_test_cnt /= 6) call abort()
end program Struct_over
! { dg-final { cleanup-modules "test_cnt rational temp_node" } }
gcc/testsuite/gfortran.dg/function_types_3.f90
......@@ -14,6 +14,6 @@ end
! PR 50403: SIGSEGV in gfc_use_derived
type(f) function f() ! { dg-error "conflicts with DERIVED attribute|is not accessible" }
type(f) function f() ! { dg-error "Type name 'f' at .1. conflicts with previously declared entity|The type for function 'f' at .1. is not accessible" }
f=110 ! { dg-error "Unclassifiable statement" }
end
gcc/testsuite/gfortran.dg/result_1.f90
......@@ -14,5 +14,10 @@ namelist /s/ a,b,c ! { dg-error "attribute conflicts" }
end function
function h() result(t)
type t ! { dg-error "attribute conflicts" }
type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" }
end type t ! { dg-error "Expecting END FUNCTION statement" }
end function
function i() result(t)
type t ! { dg-error "GENERIC attribute conflicts with RESULT attribute" }
end function
gcc/testsuite/gfortran.dg/structure_constructor_3.f03
......@@ -13,6 +13,6 @@ PROGRAM test
TYPE(basics_t) :: basics
basics = basics_t (i=42, 1.5) ! { dg-error "without name after" }
basics = basics_t (i=42, 1.5) ! { dg-error "Missing keyword name" }
END PROGRAM test
gcc/testsuite/gfortran.dg/structure_constructor_4.f03
......@@ -14,6 +14,6 @@ PROGRAM test
TYPE(basics_t) :: basics
basics = basics_t (42, r=1.5, i=15) ! { dg-error "'i' is initialized twice" }
basics = basics_t (42, r=1., r=-2.) ! { dg-error "'r' is initialized twice" }
basics = basics_t (42, r=1., r=-2.) ! { dg-error "has already appeared in the current argument list" }
END PROGRAM test
gcc/testsuite/gfortran.dg/type_decl_3.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/39427
!
subroutine t(x) ! { dg-error "conflicts with previously declared entity" }
type(t) :: x ! { dg-error "conflicts with previously declared entity" }
end subroutine t
gcc/testsuite/gfortran.dg/use_only_5.f90 0 → 100644
! { dg-do compile }
!
! PR fortran/39427
!
! Test case was failing with the initial version of the
! constructor patch.
!
! Based on the Fortran XML library FoX
module m_common_attrs
implicit none
private
type dict_item
integer, allocatable :: i(:)
end type dict_item
type dictionary_t
private
type(dict_item), pointer :: d => null()
end type dictionary_t
public :: dictionary_t
public :: get_prefix_by_index
contains
pure function get_prefix_by_index(dict) result(prefix)
type(dictionary_t), intent(in) :: dict
character(len=size(dict%d%i)) :: prefix
end function get_prefix_by_index
end module m_common_attrs
module m_common_namespaces
use m_common_attrs, only: dictionary_t
use m_common_attrs, only: get_prefix_by_index
end module m_common_namespaces
! { dg-final { cleanup-modules "m_common_attrs m_common_namespaces" } }
gcc/testsuite/gfortran.dg/used_types_25.f90 0 → 100644
! { dg-do compile }
!
! Created to check this ambiguity when
! constructors were added. Cf. PR fortran/39427
module m
type t
end type t
end module m
use m
type t ! { dg-error "Derived type definition of 't' at .1. has already been defined" }
end type t ! { dg-error "Expecting END PROGRAM statement" }
end
! { dg-final { cleanup-modules "m" } }
gcc/testsuite/gfortran.dg/used_types_26.f90 0 → 100644
! { dg-do compile }
!
! Check for ambiguity.
!
! Added as part of the constructor work (PR fortran/39427).
!
module m
type t
end type t
end module m
module m2
type t
end type t
end module m2
use m
use m2
type(t) :: x ! { dg-error "Type name 't' at .1. is ambiguous" }
end
! { dg-final { cleanup-modules "m m2" } }
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment