OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

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

Browse Source 
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
This commit is contained in:
Tobias Burnus 2011-11-16 22:37:43 +01:00
parent 16e835bb5c
commit c3f3495248
31 changed files with 1442 additions and 311 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
gcc/fortran/ChangeLog
View File

@ -1,3 +1,49 @@
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

179
gcc/fortran/decl.c
View File

@ -323,7 +323,7 @@ static match
match_data_constant (gfc_expr **result)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
gfc_symbol *sym, *dt_sym = NULL;
gfc_expr *expr;
match m;
locus old_loc;
@ -366,15 +366,19 @@ match_data_constant (gfc_expr **result)
if (gfc_find_symbol (name, NULL, 1, &sym))
return MATCH_ERROR;
if (sym && sym->attr.generic)
dt_sym = gfc_find_dt_in_generic (sym);
if (sym == NULL
|| (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
|| (sym->attr.flavor != FL_PARAMETER
&& (!dt_sym || dt_sym->attr.flavor != FL_DERIVED)))
{
gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
name);
return MATCH_ERROR;
}
else if (sym->attr.flavor == FL_DERIVED)
return gfc_match_structure_constructor (sym, result, false);
else if (dt_sym && dt_sym->attr.flavor == FL_DERIVED)
return gfc_match_structure_constructor (dt_sym, result);
/* Check to see if the value is an initialization array expression. */
if (sym->value->expr_type == EXPR_ARRAY)
@ -1954,10 +1958,10 @@ variable_decl (int elem)
st = gfc_find_symtree (gfc_current_ns->sym_root, current_ts.u.derived->name);
if (!(current_ts.u.derived->attr.imported
&& st != NULL
&& st->n.sym == current_ts.u.derived)
&& gfc_find_dt_in_generic (st->n.sym) == current_ts.u.derived)
&& !gfc_current_ns->has_import_set)
{
gfc_error ("the type of '%s' at %C has not been declared within the "
gfc_error ("The type of '%s' at %C has not been declared within the "
"interface", name);
m = MATCH_ERROR;
goto cleanup;
@ -2501,10 +2505,11 @@ match
gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
{
char name[GFC_MAX_SYMBOL_LEN + 1];
gfc_symbol *sym;
gfc_symbol *sym, *dt_sym;
match m;
char c;
bool seen_deferred_kind, matched_type;
const char *dt_name;
/* A belt and braces check that the typespec is correctly being treated
as a deferred characteristic association. */
@ -2668,40 +2673,96 @@ gfc_match_decl_type_spec (gfc_typespec *ts, int implicit_flag)
ts->u.derived = NULL;
if (gfc_current_state () != COMP_INTERFACE
&& !gfc_find_symbol (name, NULL, 1, &sym) && sym)
ts->u.derived = sym;
{
sym = gfc_find_dt_in_generic (sym);
ts->u.derived = sym;
}
return MATCH_YES;
}
/* Search for the name but allow the components to be defined later. If
type = -1, this typespec has been seen in a function declaration but
the type could not be accessed at that point. */
the type could not be accessed at that point. The actual derived type is
stored in a symtree with the first letter of the name captialized; the
symtree with the all lower-case name contains the associated
generic function. */
dt_name = gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) name[0]),
(const char*)&name[1]);
sym = NULL;
if (ts->kind != -1 && gfc_get_ha_symbol (name, &sym))
dt_sym = NULL;
if (ts->kind != -1)
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
gfc_get_ha_symbol (name, &sym);
if (sym->generic && gfc_find_symbol (dt_name, NULL, 0, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym->generic && !dt_sym)
dt_sym = gfc_find_dt_in_generic (sym);
}
else if (ts->kind == -1)
{
int iface = gfc_state_stack->previous->state != COMP_INTERFACE
|| gfc_current_ns->has_import_set;
if (gfc_find_symbol (name, NULL, iface, &sym))
gfc_find_symbol (name, NULL, iface, &sym);
if (sym && sym->generic && gfc_find_symbol (dt_name, NULL, 1, &dt_sym))
{
gfc_error ("Type name '%s' at %C is ambiguous", name);
return MATCH_ERROR;
}
if (sym && sym->generic && !dt_sym)
dt_sym = gfc_find_dt_in_generic (sym);
ts->kind = 0;
if (sym == NULL)
return MATCH_NO;
}
if (sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if ((sym->attr.flavor != FL_UNKNOWN
&& !(sym->attr.flavor == FL_PROCEDURE && sym->attr.generic))
|| sym->attr.subroutine)
{
gfc_error ("Type name '%s' at %C conflicts with previously declared "
"entity at %L, which has the same name", name,
&sym->declared_at);
return MATCH_ERROR;
}
gfc_set_sym_referenced (sym);
ts->u.derived = sym;
if (!sym->attr.generic
&& gfc_add_generic (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (!sym->attr.function
&& gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (!dt_sym)
{
gfc_interface *intr, *head;
/* Use upper case to save the actual derived-type symbol. */
gfc_get_symbol (dt_name, NULL, &dt_sym);
dt_sym->name = gfc_get_string (sym->name);
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;
}
gfc_set_sym_referenced (dt_sym);
if (dt_sym->attr.flavor != FL_DERIVED
&& gfc_add_flavor (&dt_sym->attr, FL_DERIVED, sym->name, NULL)
== FAILURE)
return MATCH_ERROR;
ts->u.derived = dt_sym;
return MATCH_YES;
@ -3053,6 +3114,20 @@ gfc_match_import (void)
sym->refs++;
sym->attr.imported = 1;
if (sym->attr.generic && (sym = gfc_find_dt_in_generic (sym)))
{
/* The actual derived type is stored in a symtree with the first
letter of the name captialized; the symtree with the all
lower-case name contains the associated generic function. */
st = gfc_new_symtree (&gfc_current_ns->sym_root,
gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) sym->name[0]),
&sym->name[1]));
st->n.sym = sym;
sym->refs++;
sym->attr.imported = 1;
}
goto next_item;
case MATCH_NO:
@ -6475,7 +6550,7 @@ access_attr_decl (gfc_statement st)
char name[GFC_MAX_SYMBOL_LEN + 1];
interface_type type;
gfc_user_op *uop;
gfc_symbol *sym;
gfc_symbol *sym, *dt_sym;
gfc_intrinsic_op op;
match m;
@ -6505,6 +6580,13 @@ access_attr_decl (gfc_statement st)
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (sym->attr.generic && (dt_sym = gfc_find_dt_in_generic (sym))
&& gfc_add_access (&dt_sym->attr,
(st == ST_PUBLIC) ? ACCESS_PUBLIC
: ACCESS_PRIVATE,
sym->name, NULL) == FAILURE)
return MATCH_ERROR;
break;
case INTERFACE_INTRINSIC_OP:
@ -7175,6 +7257,8 @@ check_extended_derived_type (char *name)
return NULL;
}
extended = gfc_find_dt_in_generic (extended);
if (extended->attr.flavor != FL_DERIVED)
{
gfc_error ("'%s' in EXTENDS expression at %C is not a "
@ -7277,11 +7361,12 @@ gfc_match_derived_decl (void)
char name[GFC_MAX_SYMBOL_LEN + 1];
char parent[GFC_MAX_SYMBOL_LEN + 1];
symbol_attribute attr;
gfc_symbol *sym;
gfc_symbol *sym, *gensym;
gfc_symbol *extended;
match m;
match is_type_attr_spec = MATCH_NO;
bool seen_attr = false;
gfc_interface *intr = NULL, *head;
if (gfc_current_state () == COMP_DERIVED)
return MATCH_NO;
@ -7327,16 +7412,50 @@ gfc_match_derived_decl (void)
return MATCH_ERROR;
}
if (gfc_get_symbol (name, NULL, &sym))
if (gfc_get_symbol (name, NULL, &gensym))
return MATCH_ERROR;
if (sym->ts.type != BT_UNKNOWN)
if (!gensym->attr.generic && gensym->ts.type != BT_UNKNOWN)
{
gfc_error ("Derived type name '%s' at %C already has a basic type "
"of %s", sym->name, gfc_typename (&sym->ts));
"of %s", gensym->name, gfc_typename (&gensym->ts));
return MATCH_ERROR;
}
if (!gensym->attr.generic
&& gfc_add_generic (&gensym->attr, gensym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (!gensym->attr.function
&& gfc_add_function (&gensym->attr, gensym->name, NULL) == FAILURE)
return MATCH_ERROR;
sym = gfc_find_dt_in_generic (gensym);
if (sym && (sym->components != NULL || sym->attr.zero_comp))
{
gfc_error ("Derived type definition of '%s' at %C has already been "
"defined", sym->name);
return MATCH_ERROR;
}
if (!sym)
{
/* Use upper case to save the actual derived-type symbol. */
gfc_get_symbol (gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) gensym->name[0]),
&gensym->name[1]), NULL, &sym);
sym->name = gfc_get_string (gensym->name);
head = gensym->generic;
intr = gfc_get_interface ();
intr->sym = sym;
intr->where = gfc_current_locus;
intr->sym->declared_at = gfc_current_locus;
intr->next = head;
gensym->generic = intr;
gensym->attr.if_source = IFSRC_DECL;
}
/* The symbol may already have the derived attribute without the
components. The ways this can happen is via a function
definition, an INTRINSIC statement or a subtype in another
@ -7346,16 +7465,18 @@ gfc_match_derived_decl (void)
&& gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
if (sym->components != NULL || sym->attr.zero_comp)
{
gfc_error ("Derived type definition of '%s' at %C has already been "
"defined", sym->name);
return MATCH_ERROR;
}
if (attr.access != ACCESS_UNKNOWN
&& gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
return MATCH_ERROR;
else if (sym->attr.access == ACCESS_UNKNOWN
&& gensym->attr.access != ACCESS_UNKNOWN
&& gfc_add_access (&sym->attr, gensym->attr.access, sym->name, NULL)
== FAILURE)
return MATCH_ERROR;
if (sym->attr.access != ACCESS_UNKNOWN
&& gensym->attr.access == ACCESS_UNKNOWN)
gensym->attr.access = sym->attr.access;
/* See if the derived type was labeled as bind(c). */
if (attr.is_bind_c != 0)

4
gcc/fortran/gfortran.h
View File

@ -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 *);

26
gcc/fortran/interface.c
View File

@ -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)

3
gcc/fortran/match.c
View File

@ -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;

2
gcc/fortran/match.h
View File

@ -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 **);

116
gcc/fortran/module.c
View File

@ -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,16 +5646,33 @@ 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. */

6
gcc/fortran/parse.c
View File

@ -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

357
gcc/fortran/primary.c
View File

@ -2315,171 +2315,162 @@ build_actual_constructor (gfc_structure_ctor_component **comp_head,
return SUCCESS;
}
match
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
bool parent)
gfc_try
gfc_convert_to_structure_constructor (gfc_expr *e, gfc_symbol *sym, gfc_expr **cexpr,
gfc_actual_arglist **arglist,
bool parent)
{
gfc_actual_arglist *actual;
gfc_structure_ctor_component *comp_tail, *comp_head, *comp_iter;
gfc_constructor_base ctor_head = NULL;
gfc_component *comp; /* Is set NULL when named component is first seen */
gfc_expr *e;
locus where;
match m;
const char* last_name = NULL;
locus old_locus;
gfc_expr *expr;
expr = parent ? *cexpr : e;
old_locus = gfc_current_locus;
if (parent)
; /* gfc_current_locus = *arglist->expr ? ->where;*/
else
gfc_current_locus = expr->where;
comp_tail = comp_head = NULL;
if (!parent && gfc_match_char ('(') != MATCH_YES)
goto syntax;
where = gfc_current_locus;
gfc_find_component (sym, NULL, false, true);
/* Check that we're not about to construct an ABSTRACT type. */
if (!parent && sym->attr.abstract)
{
gfc_error ("Can't construct ABSTRACT type '%s' at %C", sym->name);
return MATCH_ERROR;
gfc_error ("Can't construct ABSTRACT type '%s' at %L",
sym->name, &expr->where);
goto cleanup;
}
/* Match the component list and store it in a list together with the
corresponding component names. Check for empty argument list first. */
if (gfc_match_char (')') != MATCH_YES)
comp = sym->components;
actual = parent ? *arglist : expr->value.function.actual;
for ( ; actual; )
{
comp = sym->components;
do
gfc_component *this_comp = NULL;
if (!comp_head)
comp_tail = comp_head = gfc_get_structure_ctor_component ();
else
{
gfc_component *this_comp = NULL;
if (comp == sym->components && sym->attr.extension
&& comp->ts.type == BT_DERIVED
&& comp->ts.u.derived->attr.zero_comp)
/* Skip empty parents. */
comp = comp->next;
if (!comp_head)
comp_tail = comp_head = gfc_get_structure_ctor_component ();
else
{
comp_tail->next = gfc_get_structure_ctor_component ();
comp_tail = comp_tail->next;
}
comp_tail->name = XCNEWVEC (char, GFC_MAX_SYMBOL_LEN + 1);
comp_tail->val = NULL;
comp_tail->where = gfc_current_locus;
/* Try matching a component name. */
if (gfc_match_name (comp_tail->name) == MATCH_YES
&& gfc_match_char ('=') == MATCH_YES)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
" constructor with named arguments at %C")
== FAILURE)
goto cleanup;
last_name = comp_tail->name;
comp = NULL;
}
else
{
/* Components without name are not allowed after the first named
component initializer! */
if (!comp)
{
if (last_name)
gfc_error ("Component initializer without name after"
" component named %s at %C!", last_name);
else if (!parent)
gfc_error ("Too many components in structure constructor at"
" %C!");
goto cleanup;
}
gfc_current_locus = comp_tail->where;
strncpy (comp_tail->name, comp->name, GFC_MAX_SYMBOL_LEN + 1);
}
/* Find the current component in the structure definition and check
its access is not private. */
if (comp)
this_comp = gfc_find_component (sym, comp->name, false, false);
else
{
this_comp = gfc_find_component (sym,
(const char *)comp_tail->name,
false, false);
comp = NULL; /* Reset needed! */
}
/* Here we can check if a component name is given which does not
correspond to any component of the defined structure. */
if (!this_comp)
comp_tail->next = gfc_get_structure_ctor_component ();
comp_tail = comp_tail->next;
}
if (actual->name)
{
if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
" constructor with named arguments at %C")
== FAILURE)
goto cleanup;
/* Check if this component is already given a value. */
for (comp_iter = comp_head; comp_iter != comp_tail;
comp_iter = comp_iter->next)
comp_tail->name = xstrdup (actual->name);
last_name = comp_tail->name;
comp = NULL;
}
else
{
/* Components without name are not allowed after the first named
component initializer! */
if (!comp)
{
gcc_assert (comp_iter);
if (!strcmp (comp_iter->name, comp_tail->name))
{
gfc_error ("Component '%s' is initialized twice in the"
" structure constructor at %C!", comp_tail->name);
goto cleanup;
}
}
/* Match the current initializer expression. */
if (this_comp->attr.proc_pointer)
gfc_matching_procptr_assignment = 1;
m = gfc_match_expr (&comp_tail->val);
gfc_matching_procptr_assignment = 0;
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
/* F2008, R457/C725, for PURE C1283. */
if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
{
gfc_error ("Coindexed expression to pointer component '%s' in "
"structure constructor at %C!", comp_tail->name);
if (last_name)
gfc_error ("Component initializer without name after component"
" named %s at %L!", last_name,
actual->expr ? &actual->expr->where
: &gfc_current_locus);
else
gfc_error ("Too many components in structure constructor at "
"%L!", actual->expr ? &actual->expr->where
: &gfc_current_locus);
goto cleanup;
}
/* If not explicitly a parent constructor, gather up the components
and build one. */
if (comp && comp == sym->components
&& sym->attr.extension
&& (comp_tail->val->ts.type != BT_DERIVED
||
comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
{
gfc_current_locus = where;
gfc_free_expr (comp_tail->val);
comp_tail->val = NULL;
m = gfc_match_structure_constructor (comp->ts.u.derived,
&comp_tail->val, true);
if (m == MATCH_NO)
goto syntax;
if (m == MATCH_ERROR)
goto cleanup;
}
if (comp)
comp = comp->next;
if (parent && !comp)
break;
comp_tail->name = xstrdup (comp->name);
}
while (gfc_match_char (',') == MATCH_YES);
/* Find the current component in the structure definition and check
its access is not private. */
if (comp)
this_comp = gfc_find_component (sym, comp->name, false, false);
else
{
this_comp = gfc_find_component (sym, (const char *)comp_tail->name,
false, false);
comp = NULL; /* Reset needed! */
}
if (!parent && gfc_match_char (')') != MATCH_YES)
goto syntax;
/* Here we can check if a component name is given which does not
correspond to any component of the defined structure. */
if (!this_comp)
goto cleanup;
comp_tail->val = actual->expr;
if (actual->expr != NULL)
comp_tail->where = actual->expr->where;
actual->expr = NULL;
/* Check if this component is already given a value. */
for (comp_iter = comp_head; comp_iter != comp_tail;
comp_iter = comp_iter->next)
{
gcc_assert (comp_iter);
if (!strcmp (comp_iter->name, comp_tail->name))
{
gfc_error ("Component '%s' is initialized twice in the structure"
" constructor at %L!", comp_tail->name,
comp_tail->val ? &comp_tail->where
: &gfc_current_locus);
goto cleanup;
}
}
/* F2008, R457/C725, for PURE C1283. */
if (this_comp->attr.pointer && comp_tail->val
&& gfc_is_coindexed (comp_tail->val))
{
gfc_error ("Coindexed expression to pointer component '%s' in "
"structure constructor at %L!", comp_tail->name,
&comp_tail->where);
goto cleanup;
}
/* If not explicitly a parent constructor, gather up the components
and build one. */
if (comp && comp == sym->components
&& sym->attr.extension
&& comp_tail->val
&& (comp_tail->val->ts.type != BT_DERIVED
||
comp_tail->val->ts.u.derived != this_comp->ts.u.derived))
{
gfc_try m;
gfc_actual_arglist *arg_null = NULL;
actual->expr = comp_tail->val;
comp_tail->val = NULL;
m = gfc_convert_to_structure_constructor (NULL,
comp->ts.u.derived, &comp_tail->val,
comp->ts.u.derived->attr.zero_comp
? &arg_null : &actual, true);
if (m == FAILURE)
goto cleanup;
if (comp->ts.u.derived->attr.zero_comp)
{
comp = comp->next;
continue;
}
}
if (comp)
comp = comp->next;
if (parent && !comp)
break;
actual = actual->next;
}
if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
@ -2488,9 +2479,8 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
/* No component should be left, as this should have caused an error in the
loop constructing the component-list (name that does not correspond to any
component in the structure definition). */
if (comp_head)
if (comp_head && sym->attr.extension)
{
gcc_assert (sym->attr.extension);
for (comp_iter = comp_head; comp_iter; comp_iter = comp_iter->next)
{
gfc_error ("component '%s' at %L has already been set by a "
@ -2499,18 +2489,33 @@ gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result,
}
goto cleanup;
}
else
gcc_assert (!comp_head);
e = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &where);
e->ts.u.derived = sym;
e->value.constructor = ctor_head;
if (parent)
{
expr = gfc_get_structure_constructor_expr (BT_DERIVED, 0, &gfc_current_locus);
expr->ts.u.derived = sym;
expr->value.constructor = ctor_head;
*cexpr = expr;
}
else
{
expr->ts.u.derived = sym;
expr->ts.kind = 0;
expr->ts.type = BT_DERIVED;
expr->value.constructor = ctor_head;
expr->expr_type = EXPR_STRUCTURE;
}
*result = e;
return MATCH_YES;
gfc_current_locus = old_locus;
if (parent)
*arglist = actual;
return SUCCESS;
syntax:
gfc_error ("Syntax error in structure constructor at %C");
cleanup:
gfc_current_locus = old_locus;
cleanup:
for (comp_iter = comp_head; comp_iter; )
{
gfc_structure_ctor_component *next = comp_iter->next;
@ -2518,7 +2523,45 @@ cleanup:
comp_iter = next;
}
gfc_constructor_free (ctor_head);
return MATCH_ERROR;
return FAILURE;
}
match
gfc_match_structure_constructor (gfc_symbol *sym, gfc_expr **result)
{
match m;
gfc_expr *e;
gfc_symtree *symtree;
gfc_get_sym_tree (sym->name, NULL, &symtree, false); /* Can't fail */
e = gfc_get_expr ();
e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
gcc_assert (sym->attr.flavor == FL_DERIVED
&& symtree->n.sym->attr.flavor == FL_PROCEDURE);
e->value.function.esym = sym;
e->symtree->n.sym->attr.generic = 1;
m = gfc_match_actual_arglist (0, &e->value.function.actual);
if (m != MATCH_YES)
{
gfc_free_expr (e);
return m;
}
if (gfc_convert_to_structure_constructor (e, sym, NULL, NULL, false)
!= SUCCESS)
{
gfc_free_expr (e);
return MATCH_ERROR;
}
*result = e;
return MATCH_YES;
}
@ -2715,7 +2758,7 @@ gfc_match_rvalue (gfc_expr **result)
if (sym == NULL)
m = MATCH_ERROR;
else
m = gfc_match_structure_constructor (sym, &e, false);
goto generic_function;
break;
/* If we're here, then the name is known to be the name of a
@ -2989,6 +3032,12 @@ gfc_match_rvalue (gfc_expr **result)
e->symtree = symtree;
e->expr_type = EXPR_FUNCTION;
if (sym->attr.flavor == FL_DERIVED)
{
e->value.function.esym = sym;
e->symtree->n.sym->attr.generic = 1;
}
m = gfc_match_actual_arglist (0, &e->value.function.actual);
break;

107
gcc/fortran/resolve.c
View File

@ -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.

230
gcc/fortran/symbol.c
View File

@ -1949,6 +1949,9 @@ gfc_use_derived (gfc_symbol *sym)
if (!sym)
return NULL;
if (sym->attr.generic)
sym = gfc_find_dt_in_generic (sym);
if (sym->components != NULL || sym->attr.zero_comp)
return sym; /* Already defined. */
@ -2880,7 +2883,15 @@ gfc_undo_symbols (void)
}
}
gfc_delete_symtree (&p->ns->sym_root, p->name);
/* The derived type is saved in the symtree with the first
letter capitalized; the all lower-case version to the
derived type contains its associated generic function. */
if (p->attr.flavor == FL_DERIVED)
gfc_delete_symtree (&p->ns->sym_root, gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) p->name[0]),
&p->name[1]));
else
gfc_delete_symtree (&p->ns->sym_root, p->name);
gfc_release_symbol (p);
continue;
@ -3773,15 +3784,15 @@ gen_special_c_interop_ptr (int ptr_id, const char *ptr_name,
that has arg(s) of the missing type. In this case, a
regular version of the thing should have been put in the
current ns. */
generate_isocbinding_symbol (module_name, ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR,
(const char *) (ptr_id == ISOCBINDING_NULL_PTR
? "_gfortran_iso_c_binding_c_ptr"
: "_gfortran_iso_c_binding_c_funptr"));
? "c_ptr"
: "c_funptr"));
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
get_iso_c_binding_dt (ptr_id == ISOCBINDING_NULL_PTR
? ISOCBINDING_PTR : ISOCBINDING_FUNPTR);
}
/* Module name is some mangled version of iso_c_binding. */
@ -3859,9 +3870,9 @@ gen_cptr_param (gfc_formal_arglist **head,
const char *c_ptr_type = NULL;
if (iso_c_sym_id == ISOCBINDING_F_PROCPOINTER)
c_ptr_type = "_gfortran_iso_c_binding_c_funptr";
c_ptr_type = "c_funptr";
else
c_ptr_type = "_gfortran_iso_c_binding_c_ptr";
c_ptr_type = "c_ptr";
if(c_ptr_name == NULL)
c_ptr_in = "gfc_cptr__";
@ -4338,19 +4349,31 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
: c_interop_kinds_table[s].name;
gfc_symtree *tmp_symtree = NULL;
gfc_symbol *tmp_sym = NULL;
gfc_dt_list **dt_list_ptr = NULL;
gfc_component *tmp_comp = NULL;
char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
int index;
if (gfc_notification_std (std_for_isocbinding_symbol (s)) == ERROR)
return;
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root, name);
/* Already exists in this scope so don't re-add it.
TODO: we should probably check that it's really the same symbol. */
if (tmp_symtree != NULL)
return;
/* Already exists in this scope so don't re-add it. */
if (tmp_symtree != NULL && (tmp_sym = tmp_symtree->n.sym) != NULL
&& (!tmp_sym->attr.generic
|| (tmp_sym = gfc_find_dt_in_generic (tmp_sym)) != NULL)
&& tmp_sym->from_intmod == INTMOD_ISO_C_BINDING)
{
if (tmp_sym->attr.flavor == FL_DERIVED
&& !get_iso_c_binding_dt (tmp_sym->intmod_sym_id))
{
gfc_dt_list *dt_list;
dt_list = gfc_get_dt_list ();
dt_list->derived = tmp_sym;
dt_list->next = gfc_derived_types;
gfc_derived_types = dt_list;
}
return;
}
/* Create the sym tree in the current ns. */
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
@ -4443,64 +4466,112 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
{
gfc_interface *intr, *head;
gfc_symbol *dt_sym;
const char *hidden_name;
gfc_dt_list **dt_list_ptr = NULL;
gfc_component *tmp_comp = NULL;
char comp_name[(GFC_MAX_SYMBOL_LEN * 2) + 1];
/* Initialize an integer constant expression node. */
tmp_sym->attr.flavor = FL_DERIVED;
tmp_sym->ts.is_c_interop = 1;
tmp_sym->attr.is_c_interop = 1;
tmp_sym->attr.is_iso_c = 1;
tmp_sym->ts.is_iso_c = 1;
tmp_sym->ts.type = BT_DERIVED;
hidden_name = gfc_get_string ("%c%s",
(char) TOUPPER ((unsigned char) tmp_sym->name[0]),
&tmp_sym->name[1]);
/* A derived type must have the bind attribute to be
interoperable (J3/04-007, Section 15.2.3), even though
the binding label is not used. */
tmp_sym->attr.is_bind_c = 1;
/* Generate real derived type. */
tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
hidden_name);
tmp_sym->attr.referenced = 1;
if (tmp_symtree != NULL)
gcc_unreachable ();
gfc_get_sym_tree (hidden_name, gfc_current_ns, &tmp_symtree, false);
if (tmp_symtree)
dt_sym = tmp_symtree->n.sym;
else
gcc_unreachable ();
tmp_sym->ts.u.derived = tmp_sym;
/* Generate an artificial generic function. */
dt_sym->name = gfc_get_string (tmp_sym->name);
head = tmp_sym->generic;
intr = gfc_get_interface ();
intr->sym = dt_sym;
intr->where = gfc_current_locus;
intr->next = head;
tmp_sym->generic = intr;
/* Add the symbol created for the derived type to the current ns. */
dt_list_ptr = &(gfc_derived_types);
while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
dt_list_ptr = &((*dt_list_ptr)->next);
if (!tmp_sym->attr.generic
&& gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
return;
/* There is already at least one derived type in the list, so append
the one we're currently building for c_ptr or c_funptr. */
if (*dt_list_ptr != NULL)
dt_list_ptr = &((*dt_list_ptr)->next);
(*dt_list_ptr) = gfc_get_dt_list ();
(*dt_list_ptr)->derived = tmp_sym;
(*dt_list_ptr)->next = NULL;
if (!tmp_sym->attr.function
&& gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
== FAILURE)
return;
/* Set up the component of the derived type, which will be
an integer with kind equal to c_ptr_size. Mangle the name of
the field for the c_address to prevent the curious user from
trying to access it from Fortran. */
sprintf (comp_name, "__%s_%s", tmp_sym->name, "c_address");
gfc_add_component (tmp_sym, comp_name, &tmp_comp);
if (tmp_comp == NULL)
/* Say what module this symbol belongs to. */
dt_sym->module = gfc_get_string (mod_name);
dt_sym->from_intmod = INTMOD_ISO_C_BINDING;
dt_sym->intmod_sym_id = s;
/* Initialize an integer constant expression node. */
dt_sym->attr.flavor = FL_DERIVED;
dt_sym->ts.is_c_interop = 1;
dt_sym->attr.is_c_interop = 1;
dt_sym->attr.is_iso_c = 1;
dt_sym->ts.is_iso_c = 1;
dt_sym->ts.type = BT_DERIVED;
/* A derived type must have the bind attribute to be
interoperable (J3/04-007, Section 15.2.3), even though
the binding label is not used. */
dt_sym->attr.is_bind_c = 1;
dt_sym->attr.referenced = 1;
dt_sym->ts.u.derived = dt_sym;
/* Add the symbol created for the derived type to the current ns. */
dt_list_ptr = &(gfc_derived_types);
while (*dt_list_ptr != NULL && (*dt_list_ptr)->next != NULL)
dt_list_ptr = &((*dt_list_ptr)->next);
/* There is already at least one derived type in the list, so append
the one we're currently building for c_ptr or c_funptr. */
if (*dt_list_ptr != NULL)
dt_list_ptr = &((*dt_list_ptr)->next);
(*dt_list_ptr) = gfc_get_dt_list ();
(*dt_list_ptr)->derived = dt_sym;
(*dt_list_ptr)->next = NULL;
/* Set up the component of the derived type, which will be
an integer with kind equal to c_ptr_size. Mangle the name of
the field for the c_address to prevent the curious user from
trying to access it from Fortran. */
sprintf (comp_name, "__%s_%s", dt_sym->name, "c_address");
gfc_add_component (dt_sym, comp_name, &tmp_comp);
if (tmp_comp == NULL)
gfc_internal_error ("generate_isocbinding_symbol(): Unable to "
"create component for c_address");
tmp_comp->ts.type = BT_INTEGER;
tmp_comp->ts.type = BT_INTEGER;
/* Set this because the module will need to read/write this field. */
tmp_comp->ts.f90_type = BT_INTEGER;
/* Set this because the module will need to read/write this field. */
tmp_comp->ts.f90_type = BT_INTEGER;
/* The kinds for c_ptr and c_funptr are the same. */
index = get_c_kind ("c_ptr", c_interop_kinds_table);
tmp_comp->ts.kind = c_interop_kinds_table[index].value;
/* The kinds for c_ptr and c_funptr are the same. */
index = get_c_kind ("c_ptr", c_interop_kinds_table);
tmp_comp->ts.kind = c_interop_kinds_table[index].value;
tmp_comp->attr.pointer = 0;
tmp_comp->attr.dimension = 0;
tmp_comp->attr.pointer = 0;
tmp_comp->attr.dimension = 0;
/* Mark the component as C interoperable. */
tmp_comp->ts.is_c_interop = 1;
/* Mark the component as C interoperable. */
tmp_comp->ts.is_c_interop = 1;
/* Make it use associated (iso_c_binding module). */
dt_sym->attr.use_assoc = 1;
}
/* Make it use associated (iso_c_binding module). */
tmp_sym->attr.use_assoc = 1;
break;
case ISOCBINDING_NULL_PTR:
@ -4550,21 +4621,20 @@ generate_isocbinding_symbol (const char *mod_name, iso_c_binding_symbol s,
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (ISOCBINDING_FUNPTR);
if (tmp_sym->ts.u.derived == NULL)
{
if (tmp_sym->ts.u.derived == NULL)
{
/* Create the necessary derived type so we can continue
processing the file. */
generate_isocbinding_symbol
generate_isocbinding_symbol
(mod_name, s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
(const char *)(s == ISOCBINDING_FUNLOC
? "_gfortran_iso_c_binding_c_funptr"
: "_gfortran_iso_c_binding_c_ptr"));
? ISOCBINDING_FUNPTR : ISOCBINDING_PTR,
(const char *)(s == ISOCBINDING_FUNLOC
? "c_funptr" : "c_ptr"));
tmp_sym->ts.u.derived =
get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR);
}
get_iso_c_binding_dt (s == ISOCBINDING_FUNLOC
? ISOCBINDING_FUNPTR
: ISOCBINDING_PTR);
}
/* The function result is itself (no result clause). */
tmp_sym->result = tmp_sym;
@ -4712,6 +4782,9 @@ gfc_get_typebound_proc (gfc_typebound_proc *tb0)
gfc_symbol*
gfc_get_derived_super_type (gfc_symbol* derived)
{
if (derived && derived->attr.generic)
derived = gfc_find_dt_in_generic (derived);
if (!derived->attr.extension)
return NULL;
@ -4719,6 +4792,9 @@ gfc_get_derived_super_type (gfc_symbol* derived)
gcc_assert (derived->components->ts.type == BT_DERIVED);
gcc_assert (derived->components->ts.u.derived);
if (derived->components->ts.u.derived->attr.generic)
return gfc_find_dt_in_generic (derived->components->ts.u.derived);
return derived->components->ts.u.derived;
}
@ -4814,3 +4890,19 @@ gfc_is_associate_pointer (gfc_symbol* sym)
return true;
}
gfc_symbol *
gfc_find_dt_in_generic (gfc_symbol *sym)
{
gfc_interface *intr = NULL;
if (!sym || sym->attr.flavor == FL_DERIVED)
return sym;
if (sym->attr.generic)
for (intr = (sym ? sym->generic : NULL); intr; intr = intr->next)
if (intr->sym->attr.flavor == FL_DERIVED)
break;
return intr ? intr->sym : NULL;
}

5
gcc/fortran/trans-array.c
View File

@ -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:

25
gcc/fortran/trans-decl.c
View File

@ -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). */

4
gcc/fortran/trans-types.c
View File

@ -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. */

23
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,24 @@
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.

88
gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90 Normal file
View File

@ -0,0 +1,88 @@
! { 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" } }

35
gcc/testsuite/gfortran.dg/c_ptr_tests_18.f90 Normal file
View File

@ -0,0 +1,35 @@
! { 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" } }

42
gcc/testsuite/gfortran.dg/constructor_1.f90 Normal file
View File

@ -0,0 +1,42 @@
! { 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" } }

73
gcc/testsuite/gfortran.dg/constructor_2.f90 Normal file
View File

@ -0,0 +1,73 @@
! { 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" } }

47
gcc/testsuite/gfortran.dg/constructor_3.f90 Normal file
View File

@ -0,0 +1,47 @@
! { 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" } }

33
gcc/testsuite/gfortran.dg/constructor_4.f90 Normal file
View File

@ -0,0 +1,33 @@
! { 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

34
gcc/testsuite/gfortran.dg/constructor_5.f90 Normal file
View File

@ -0,0 +1,34 @@
! { 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" } }

171
gcc/testsuite/gfortran.dg/constructor_6.f90 Normal file
View File

@ -0,0 +1,171 @@
! { 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" } }

2
gcc/testsuite/gfortran.dg/function_types_3.f90
View File

@ -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

7
gcc/testsuite/gfortran.dg/result_1.f90
View File

@ -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

2
gcc/testsuite/gfortran.dg/structure_constructor_3.f03
View File

@ -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

2
gcc/testsuite/gfortran.dg/structure_constructor_4.f03
View File

@ -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

7
gcc/testsuite/gfortran.dg/type_decl_3.f90 Normal file
View File

@ -0,0 +1,7 @@
! { 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

38
gcc/testsuite/gfortran.dg/use_only_5.f90 Normal file
View File

@ -0,0 +1,38 @@
! { 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" } }

17
gcc/testsuite/gfortran.dg/used_types_25.f90 Normal file
View File

@ -0,0 +1,17 @@
! { 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" } }

22
gcc/testsuite/gfortran.dg/used_types_26.f90 Normal file
View File

@ -0,0 +1,22 @@
! { 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" } }