Commit c3f34952 by Tobias Burnus

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
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> 2011-11-14 Tobias Burnus <burnus@net-b.de>
PR fortran/51073 PR fortran/51073
......
...@@ -2630,6 +2630,7 @@ gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus); ...@@ -2630,6 +2630,7 @@ gfc_try gfc_check_symbol_typed (gfc_symbol*, gfc_namespace*, bool, locus);
gfc_namespace* gfc_find_proc_namespace (gfc_namespace*); gfc_namespace* gfc_find_proc_namespace (gfc_namespace*);
bool gfc_is_associate_pointer (gfc_symbol*); 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. */ /* intrinsic.c -- true if working in an init-expr, false otherwise. */
extern bool gfc_init_expr_flag; extern bool gfc_init_expr_flag;
...@@ -2874,6 +2875,9 @@ match gfc_match_rvalue (gfc_expr **); ...@@ -2874,6 +2875,9 @@ match gfc_match_rvalue (gfc_expr **);
match gfc_match_varspec (gfc_expr*, int, bool, bool); match gfc_match_varspec (gfc_expr*, int, bool, bool);
int gfc_check_digit (char, int); int gfc_check_digit (char, int);
bool gfc_is_function_return_value (gfc_symbol *, gfc_namespace *); 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 */ /* trans.c */
void gfc_generate_code (gfc_namespace *); void gfc_generate_code (gfc_namespace *);
......
...@@ -1262,8 +1262,9 @@ check_interface0 (gfc_interface *p, const char *interface_name) ...@@ -1262,8 +1262,9 @@ check_interface0 (gfc_interface *p, const char *interface_name)
{ {
/* Make sure all symbols in the interface have been defined as /* Make sure all symbols in the interface have been defined as
functions or subroutines. */ functions or subroutines. */
if ((!p->sym->attr.function && !p->sym->attr.subroutine) if (((!p->sym->attr.function && !p->sym->attr.subroutine)
|| !p->sym->attr.if_source) || !p->sym->attr.if_source)
&& p->sym->attr.flavor != FL_DERIVED)
{ {
if (p->sym->attr.external) if (p->sym->attr.external)
gfc_error ("Procedure '%s' in %s at %L has no explicit interface", 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) ...@@ -1276,11 +1277,18 @@ check_interface0 (gfc_interface *p, const char *interface_name)
} }
/* Verify that procedures are either all SUBROUTINEs or all FUNCTIONs. */ /* 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)) || (psave->sym->attr.subroutine && !p->sym->attr.subroutine))
{ {
gfc_error ("In %s at %L procedures must be either all SUBROUTINEs" if (p->sym->attr.flavor != FL_DERIVED)
" or all FUNCTIONs", interface_name, &p->sym->declared_at); 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; return 1;
} }
...@@ -1336,8 +1344,10 @@ check_interface1 (gfc_interface *p, gfc_interface *q0, ...@@ -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) if (p->sym->name == q->sym->name && p->sym->module == q->sym->module)
continue; continue;
if (gfc_compare_interfaces (p->sym, q->sym, q->sym->name, generic_flag, if (p->sym->attr.flavor != FL_DERIVED
0, NULL, 0)) && q->sym->attr.flavor != FL_DERIVED
&& gfc_compare_interfaces (p->sym, q->sym, q->sym->name,
generic_flag, 0, NULL, 0))
{ {
if (referenced) if (referenced)
gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L", gfc_error ("Ambiguous interfaces '%s' and '%s' in %s at %L",
...@@ -3019,6 +3029,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag, ...@@ -3019,6 +3029,8 @@ gfc_search_interface (gfc_interface *intr, int sub_flag,
for (; intr; intr = intr->next) for (; intr; intr = intr->next)
{ {
if (intr->sym->attr.flavor == FL_DERIVED)
continue;
if (sub_flag && intr->sym->attr.function) if (sub_flag && intr->sym->attr.function)
continue; continue;
if (!sub_flag && intr->sym->attr.subroutine) if (!sub_flag && intr->sym->attr.subroutine)
......
...@@ -1920,6 +1920,9 @@ match_derived_type_spec (gfc_typespec *ts) ...@@ -1920,6 +1920,9 @@ match_derived_type_spec (gfc_typespec *ts)
gfc_find_symbol (name, NULL, 1, &derived); 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) if (derived && derived->attr.flavor == FL_DERIVED)
{ {
ts->type = BT_DERIVED; ts->type = BT_DERIVED;
......
...@@ -206,7 +206,7 @@ match gfc_match_bind_c (gfc_symbol *, bool); ...@@ -206,7 +206,7 @@ match gfc_match_bind_c (gfc_symbol *, bool);
match gfc_get_type_attr_spec (symbol_attribute *, char*); match gfc_get_type_attr_spec (symbol_attribute *, char*);
/* primary.c. */ /* 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_variable (gfc_expr **, int);
match gfc_match_equiv_variable (gfc_expr **); match gfc_match_equiv_variable (gfc_expr **);
match gfc_match_actual_arglist (int, gfc_actual_arglist **); match gfc_match_actual_arglist (int, gfc_actual_arglist **);
......
...@@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see ...@@ -80,7 +80,7 @@ along with GCC; see the file COPYING3. If not see
/* Don't put any single quote (') in MOD_VERSION, /* Don't put any single quote (') in MOD_VERSION,
if yout want it to be recognized. */ if yout want it to be recognized. */
#define MOD_VERSION "7" #define MOD_VERSION "8"
/* Structure that describes a position within a module file. */ /* Structure that describes a position within a module file. */
...@@ -429,6 +429,34 @@ resolve_fixups (fixup_t *f, void *gp) ...@@ -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 /* Call here during module reading when we know what pointer to
associate with an integer. Any fixups that exist are resolved at associate with an integer. Any fixups that exist are resolved at
this time. */ this time. */
...@@ -699,12 +727,18 @@ static const char * ...@@ -699,12 +727,18 @@ static const char *
find_use_name_n (const char *name, int *inst, bool interface) find_use_name_n (const char *name, int *inst, bool interface)
{ {
gfc_use_rename *u; gfc_use_rename *u;
const char *low_name = NULL;
int i; int i;
/* For derived types. */
if (name[0] != (char) TOLOWER ((unsigned char) name[0]))
low_name = dt_lower_string (name);
i = 0; i = 0;
for (u = gfc_rename_list; u; u = u->next) 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)
|| (u->op != INTRINSIC_USER && interface)) || (u->op != INTRINSIC_USER && interface))
continue; continue;
...@@ -723,6 +757,13 @@ find_use_name_n (const char *name, int *inst, bool interface) ...@@ -723,6 +757,13 @@ find_use_name_n (const char *name, int *inst, bool interface)
u->found = 1; 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; return (u->local_name[0] != '\0') ? u->local_name : name;
} }
...@@ -780,6 +821,7 @@ find_use_operator (gfc_intrinsic_op op) ...@@ -780,6 +821,7 @@ find_use_operator (gfc_intrinsic_op op)
typedef struct true_name typedef struct true_name
{ {
BBT_HEADER (true_name); BBT_HEADER (true_name);
const char *name;
gfc_symbol *sym; gfc_symbol *sym;
} }
true_name; true_name;
...@@ -803,7 +845,7 @@ compare_true_names (void *_t1, void *_t2) ...@@ -803,7 +845,7 @@ compare_true_names (void *_t1, void *_t2)
if (c != 0) if (c != 0)
return c; 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) ...@@ -817,7 +859,7 @@ find_true_name (const char *name, const char *module)
gfc_symbol sym; gfc_symbol sym;
int c; int c;
sym.name = gfc_get_string (name); t.name = gfc_get_string (name);
if (module != NULL) if (module != NULL)
sym.module = gfc_get_string (module); sym.module = gfc_get_string (module);
else else
...@@ -847,6 +889,10 @@ add_true_name (gfc_symbol *sym) ...@@ -847,6 +889,10 @@ add_true_name (gfc_symbol *sym)
t = XCNEW (true_name); t = XCNEW (true_name);
t->sym = sym; 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); gfc_insert_bbt (&true_name_root, t, compare_true_names);
} }
...@@ -858,13 +904,19 @@ add_true_name (gfc_symbol *sym) ...@@ -858,13 +904,19 @@ add_true_name (gfc_symbol *sym)
static void static void
build_tnt (gfc_symtree *st) build_tnt (gfc_symtree *st)
{ {
const char *name;
if (st == NULL) if (st == NULL)
return; return;
build_tnt (st->left); build_tnt (st->left);
build_tnt (st->right); 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; return;
add_true_name (st->n.sym); add_true_name (st->n.sym);
...@@ -2986,8 +3038,12 @@ fix_mio_expr (gfc_expr *e) ...@@ -2986,8 +3038,12 @@ fix_mio_expr (gfc_expr *e)
namespace to see if the required, non-contained symbol is available namespace to see if the required, non-contained symbol is available
yet. If so, the latter should be written. */ yet. If so, the latter should be written. */
if (e->symtree->n.sym && check_unique_name (e->symtree->name)) 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 /* 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. */ new symbol is a dummy argument, do not do the promotion. */
...@@ -4205,6 +4261,7 @@ load_needed (pointer_info *p) ...@@ -4205,6 +4261,7 @@ load_needed (pointer_info *p)
1, &ns->proc_name); 1, &ns->proc_name);
sym = gfc_new_symbol (p->u.rsym.true_name, ns); 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); sym->module = gfc_get_string (p->u.rsym.module);
strcpy (sym->binding_label, p->u.rsym.binding_label); strcpy (sym->binding_label, p->u.rsym.binding_label);
...@@ -4497,6 +4554,7 @@ read_module (void) ...@@ -4497,6 +4554,7 @@ read_module (void)
{ {
info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name, info->u.rsym.sym = gfc_new_symbol (info->u.rsym.true_name,
gfc_current_ns); gfc_current_ns);
info->u.rsym.sym->name = dt_lower_string (info->u.rsym.true_name);
sym = info->u.rsym.sym; sym = info->u.rsym.sym;
sym->module = gfc_get_string (info->u.rsym.module); sym->module = gfc_get_string (info->u.rsym.module);
...@@ -4835,7 +4893,7 @@ write_dt_extensions (gfc_symtree *st) ...@@ -4835,7 +4893,7 @@ write_dt_extensions (gfc_symtree *st)
return; return;
mio_lparen (); mio_lparen ();
mio_pool_string (&st->n.sym->name); mio_pool_string (&st->name);
if (st->n.sym->module != NULL) if (st->n.sym->module != NULL)
mio_pool_string (&st->n.sym->module); mio_pool_string (&st->n.sym->module);
else else
...@@ -4870,7 +4928,15 @@ write_symbol (int n, gfc_symbol *sym) ...@@ -4870,7 +4928,15 @@ write_symbol (int n, gfc_symbol *sym)
gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name); gfc_internal_error ("write_symbol(): bad module symbol '%s'", sym->name);
mio_integer (&n); 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); mio_pool_string (&sym->module);
if (sym->attr.is_bind_c || sym->attr.is_iso_c) if (sym->attr.is_bind_c || sym->attr.is_iso_c)
...@@ -5566,7 +5632,8 @@ create_derived_type (const char *name, const char *modname, ...@@ -5566,7 +5632,8 @@ create_derived_type (const char *name, const char *modname,
intmod_id module, int id) intmod_id module, int id)
{ {
gfc_symtree *tmp_symtree; 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); tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
if (tmp_symtree != NULL) if (tmp_symtree != NULL)
...@@ -5579,18 +5646,35 @@ create_derived_type (const char *name, const char *modname, ...@@ -5579,18 +5646,35 @@ create_derived_type (const char *name, const char *modname,
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false); gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym; sym = tmp_symtree->n.sym;
sym->module = gfc_get_string (modname); sym->module = gfc_get_string (modname);
sym->from_intmod = module; sym->from_intmod = module;
sym->intmod_sym_id = id; sym->intmod_sym_id = id;
sym->attr.flavor = FL_DERIVED; sym->attr.flavor = FL_PROCEDURE;
sym->attr.private_comp = 1; sym->attr.function = 1;
sym->attr.zero_comp = 1; sym->attr.generic = 1;
sym->attr.use_assoc = 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. */ /* USE the ISO_FORTRAN_ENV intrinsic module. */
static void static void
......
...@@ -3881,6 +3881,12 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) ...@@ -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)) if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
goto fixup_contained; 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; old_sym = st->n.sym;
if (old_sym->ns == ns if (old_sym->ns == ns
&& !old_sym->attr.contained && !old_sym->attr.contained
......
...@@ -454,7 +454,8 @@ resolve_formal_arglist (gfc_symbol *proc) ...@@ -454,7 +454,8 @@ resolve_formal_arglist (gfc_symbol *proc)
static void static void
find_arglists (gfc_symbol *sym) 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; return;
resolve_formal_arglist (sym); resolve_formal_arglist (sym);
...@@ -967,13 +968,6 @@ resolve_structure_cons (gfc_expr *expr, int init) ...@@ -967,13 +968,6 @@ resolve_structure_cons (gfc_expr *expr, int init)
resolve_fl_derived0 (expr->ts.u.derived); resolve_fl_derived0 (expr->ts.u.derived);
cons = gfc_constructor_first (expr->value.constructor); 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 /* See if the user is trying to invoke a structure constructor for one of
the iso_c_binding derived types. */ the iso_c_binding derived types. */
...@@ -992,6 +986,14 @@ resolve_structure_cons (gfc_expr *expr, int init) ...@@ -992,6 +986,14 @@ resolve_structure_cons (gfc_expr *expr, int init)
&& cons->expr && cons->expr->expr_type == EXPR_NULL) && cons->expr && cons->expr->expr_type == EXPR_NULL)
return SUCCESS; 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)) for (; comp && cons; comp = comp->next, cons = gfc_constructor_next (cons))
{ {
int rank; int rank;
...@@ -1401,7 +1403,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context) ...@@ -1401,7 +1403,8 @@ is_illegal_recursion (gfc_symbol* sym, gfc_namespace* context)
gfc_symbol* context_proc; gfc_symbol* context_proc;
gfc_namespace* real_context; gfc_namespace* real_context;
if (sym->attr.flavor == FL_PROGRAM) if (sym->attr.flavor == FL_PROGRAM
|| sym->attr.flavor == FL_DERIVED)
return false; return false;
gcc_assert (sym->attr.flavor == FL_PROCEDURE); gcc_assert (sym->attr.flavor == FL_PROCEDURE);
...@@ -2323,6 +2326,7 @@ resolve_generic_f (gfc_expr *expr) ...@@ -2323,6 +2326,7 @@ resolve_generic_f (gfc_expr *expr)
{ {
gfc_symbol *sym; gfc_symbol *sym;
match m; match m;
gfc_interface *intr = NULL;
sym = expr->symtree->n.sym; sym = expr->symtree->n.sym;
...@@ -2335,6 +2339,11 @@ resolve_generic_f (gfc_expr *expr) ...@@ -2335,6 +2339,11 @@ resolve_generic_f (gfc_expr *expr)
return FAILURE; return FAILURE;
generic: generic:
if (!intr)
for (intr = sym->generic; intr; intr = intr->next)
if (intr->sym->attr.flavor == FL_DERIVED)
break;
if (sym->ns->parent == NULL) if (sym->ns->parent == NULL)
break; break;
gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym); gfc_find_symbol (sym->name, sym->ns->parent, 1, &sym);
...@@ -2347,16 +2356,25 @@ generic: ...@@ -2347,16 +2356,25 @@ generic:
/* Last ditch attempt. See if the reference is to an intrinsic /* Last ditch attempt. See if the reference is to an intrinsic
that possesses a matching interface. 14.1.2.4 */ 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", gfc_error ("There is no specific function for the generic '%s' "
expr->symtree->n.sym->name, &expr->where); "at %L", expr->symtree->n.sym->name, &expr->where);
return FAILURE; 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); m = gfc_intrinsic_func_interface (expr, 0);
if (m == MATCH_YES) if (m == MATCH_YES)
return SUCCESS; return SUCCESS;
if (m == MATCH_NO) if (m == MATCH_NO)
gfc_error ("Generic function '%s' at %L is not consistent with a " gfc_error ("Generic function '%s' at %L is not consistent with a "
"specific intrinsic interface", expr->symtree->n.sym->name, "specific intrinsic interface", expr->symtree->n.sym->name,
...@@ -5053,6 +5071,9 @@ resolve_variable (gfc_expr *e) ...@@ -5053,6 +5071,9 @@ resolve_variable (gfc_expr *e)
if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY) if (sym->assoc && !sym->attr.dimension && e->ref && e->ref->type == REF_ARRAY)
return FAILURE; 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; /* On the other hand, the parser may not have known this is an array;
in this case, we have to add a FULL reference. */ in this case, we have to add a FULL reference. */
if (sym->assoc && sym->attr.dimension && !e->ref) if (sym->assoc && sym->attr.dimension && !e->ref)
...@@ -10152,6 +10173,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag) ...@@ -10152,6 +10173,8 @@ resolve_fl_variable_derived (gfc_symbol *sym, int no_init_flag)
{ {
gfc_symbol *s; gfc_symbol *s;
gfc_find_symbol (sym->ts.u.derived->name, sym->ns, 0, &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) if (s && s->attr.flavor != FL_DERIVED)
{ {
gfc_error ("The type '%s' cannot be host associated at %L " gfc_error ("The type '%s' cannot be host associated at %L "
...@@ -11718,6 +11741,13 @@ resolve_fl_derived0 (gfc_symbol *sym) ...@@ -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 if (!sym->attr.is_class && c->ts.type == BT_DERIVED && !sym->attr.vtype
&& c->attr.pointer && c->ts.u.derived->components == NULL && c->attr.pointer && c->ts.u.derived->components == NULL
&& !c->ts.u.derived->attr.zero_comp) && !c->ts.u.derived->attr.zero_comp)
...@@ -11788,6 +11818,23 @@ resolve_fl_derived0 (gfc_symbol *sym) ...@@ -11788,6 +11818,23 @@ resolve_fl_derived0 (gfc_symbol *sym)
static gfc_try static gfc_try
resolve_fl_derived (gfc_symbol *sym) 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) if (sym->attr.is_class && sym->ts.u.derived == NULL)
{ {
/* Fix up incomplete CLASS symbols. */ /* Fix up incomplete CLASS symbols. */
...@@ -12191,6 +12238,20 @@ resolve_symbol (gfc_symbol *sym) ...@@ -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 /* 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 do this for something that was implicitly typed because that is handled
in gfc_set_default_type. Handle dummy arguments and procedure in gfc_set_default_type. Handle dummy arguments and procedure
...@@ -12260,7 +12321,8 @@ resolve_symbol (gfc_symbol *sym) ...@@ -12260,7 +12321,8 @@ resolve_symbol (gfc_symbol *sym)
the type is not declared in the scope of the implicit the type is not declared in the scope of the implicit
statement. Change the type to BT_UNKNOWN, both because it is so statement. Change the type to BT_UNKNOWN, both because it is so
and to prevent an ICE. */ 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) && !sym->ts.u.derived->attr.zero_comp)
{ {
gfc_error ("The derived type '%s' at %L is of type '%s', " gfc_error ("The derived type '%s' at %L is of type '%s', "
...@@ -12276,22 +12338,9 @@ resolve_symbol (gfc_symbol *sym) ...@@ -12276,22 +12338,9 @@ resolve_symbol (gfc_symbol *sym)
if (sym->ts.type == BT_DERIVED if (sym->ts.type == BT_DERIVED
&& sym->ts.u.derived->attr.use_assoc && sym->ts.u.derived->attr.use_assoc
&& sym->ns->proc_name && sym->ns->proc_name
&& sym->ns->proc_name->attr.flavor == FL_MODULE) && sym->ns->proc_name->attr.flavor == FL_MODULE
{ && resolve_fl_derived (sym->ts.u.derived) == FAILURE)
gfc_symbol *ds; return;
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++;
}
}
/* Unless the derived-type declaration is use associated, Fortran 95 /* Unless the derived-type declaration is use associated, Fortran 95
does not allow public entries of private derived types. does not allow public entries of private derived types.
......
...@@ -5027,6 +5027,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr) ...@@ -5027,6 +5027,11 @@ gfc_conv_array_initializer (tree type, gfc_expr * expr)
tree index, range; tree index, range;
VEC(constructor_elt,gc) *v = NULL; 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) switch (expr->expr_type)
{ {
case EXPR_CONSTANT: case EXPR_CONSTANT:
......
...@@ -699,6 +699,18 @@ gfc_get_module_backend_decl (gfc_symbol *sym) ...@@ -699,6 +699,18 @@ gfc_get_module_backend_decl (gfc_symbol *sym)
} }
else if (sym->attr.flavor == FL_DERIVED) 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) if (!s->backend_decl)
s->backend_decl = gfc_get_derived_type (s); s->backend_decl = gfc_get_derived_type (s);
gfc_copy_dt_decls_ifequal (s, sym, true); gfc_copy_dt_decls_ifequal (s, sym, true);
...@@ -4035,7 +4047,18 @@ gfc_trans_use_stmts (gfc_namespace * ns) ...@@ -4035,7 +4047,18 @@ gfc_trans_use_stmts (gfc_namespace * ns)
st = gfc_find_symtree (ns->sym_root, st = gfc_find_symtree (ns->sym_root,
rent->local_name[0] rent->local_name[0]
? rent->local_name : rent->use_name); ? 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 /* Sometimes, generic interfaces wind up being over-ruled by a
local symbol (see PR41062). */ local symbol (see PR41062). */
......
...@@ -2257,6 +2257,10 @@ gfc_get_derived_type (gfc_symbol * derived) ...@@ -2257,6 +2257,10 @@ gfc_get_derived_type (gfc_symbol * derived)
gfc_dt_list *dt; gfc_dt_list *dt;
gfc_namespace *ns; 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); gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
/* See if it's one of the iso_c_binding derived types. */ /* See if it's one of the iso_c_binding derived types. */
......
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> 2011-10-16 Matthew Gretton-Dann <matthew.gretton-dann@arm.com>
* gcc.dg/vect/pr30858.c: Update expected output for * gcc.dg/vect/pr30858.c: Update expected output for
...@@ -12,7 +33,7 @@ ...@@ -12,7 +33,7 @@
2011-11-16 Razya Ladelsky <razya@il.ibm.com> 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.c: New test.
* gcc.dg/autopar/pr49960-1.c: New test. * gcc.dg/autopar/pr49960-1.c: New test.
......
! { 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" } }
! { 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" } }
! { 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" } }
! { 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" } }
! { 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" } }
! { 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
! { 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" } }
! { 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" } }
...@@ -14,6 +14,6 @@ end ...@@ -14,6 +14,6 @@ end
! PR 50403: SIGSEGV in gfc_use_derived ! 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" } f=110 ! { dg-error "Unclassifiable statement" }
end end
...@@ -14,5 +14,10 @@ namelist /s/ a,b,c ! { dg-error "attribute conflicts" } ...@@ -14,5 +14,10 @@ namelist /s/ a,b,c ! { dg-error "attribute conflicts" }
end function end function
function h() result(t) 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 end function
...@@ -13,6 +13,6 @@ PROGRAM test ...@@ -13,6 +13,6 @@ PROGRAM test
TYPE(basics_t) :: basics 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 END PROGRAM test
...@@ -14,6 +14,6 @@ PROGRAM test ...@@ -14,6 +14,6 @@ PROGRAM test
TYPE(basics_t) :: basics 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.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 END PROGRAM test
! { 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
! { 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" } }
! { 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" } }
! { 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