+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
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;
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)
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;
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. */
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;
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:
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;
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:
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 "
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;
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
&& 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)
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;
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 *);
{
/* 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",
}
/* 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;
}
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",
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)
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;
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 **);
/* 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. */
}
+/* 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. */
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;
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;
}
typedef struct true_name
{
BBT_HEADER (true_name);
+ const char *name;
gfc_symbol *sym;
}
true_name;
if (c != 0)
return c;
- return strcmp (t1->sym->name, t2->sym->name);
+ return strcmp (t1->name, t2->name);
}
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
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);
}
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);
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. */
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);
{
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);
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
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)
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)
gfc_get_sym_tree (name, gfc_current_ns, &tmp_symtree, false);
sym = tmp_symtree->n.sym;
-
sym->module = gfc_get_string (modname);
sym->from_intmod = module;
sym->intmod_sym_id = id;
- sym->attr.flavor = FL_DERIVED;
- sym->attr.private_comp = 1;
- sym->attr.zero_comp = 1;
- sym->attr.use_assoc = 1;
+ sym->attr.flavor = FL_PROCEDURE;
+ sym->attr.function = 1;
+ sym->attr.generic = 1;
+
+ gfc_get_sym_tree (dt_upper_string (sym->name),
+ gfc_current_ns, &tmp_symtree, false);
+ dt_sym = tmp_symtree->n.sym;
+ dt_sym->name = gfc_get_string (sym->name);
+ dt_sym->attr.flavor = FL_DERIVED;
+ dt_sym->attr.private_comp = 1;
+ dt_sym->attr.zero_comp = 1;
+ dt_sym->attr.use_assoc = 1;
+ dt_sym->module = gfc_get_string (modname);
+ dt_sym->from_intmod = module;
+ dt_sym->intmod_sym_id = id;
+
+ head = sym->generic;
+ intr = gfc_get_interface ();
+ intr->sym = dt_sym;
+ intr->where = gfc_current_locus;
+ intr->next = head;
+ sym->generic = intr;
+ sym->attr.if_source = IFSRC_DECL;
}
-
/* USE the ISO_FORTRAN_ENV intrinsic module. */
static void
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
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;
- comp_tail = comp_head = NULL;
-
- if (!parent && gfc_match_char ('(') != MATCH_YES)
- goto syntax;
-
- where = gfc_current_locus;
+ expr = parent ? *cexpr : e;
+ old_locus = gfc_current_locus;
+ if (parent)
+ ; /* gfc_current_locus = *arglist->expr ? ->where;*/
+ else
+ gfc_current_locus = expr->where;
- gfc_find_component (sym, NULL, false, true);
+ comp_tail = comp_head = NULL;
- /* 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 == sym->components && sym->attr.extension
- && comp->ts.type == BT_DERIVED
- && comp->ts.u.derived->attr.zero_comp)
- /* Skip empty parents. */
- comp = comp->next;
+ gfc_component *this_comp = NULL;
- 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;
+ 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;
+ }
+ if (actual->name)
+ {
+ if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Structure"
+ " constructor with named arguments at %C")
+ == FAILURE)
+ goto cleanup;
- /* Try matching a component name. */
- if (gfc_match_name (comp_tail->name) == MATCH_YES
- && gfc_match_char ('=') == MATCH_YES)
+ 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)
{
- 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;
+ 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;
}
- 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);
- }
+ comp_tail->name = xstrdup (comp->name);
+ }
- /* Find the current component in the structure definition and check
+ /* 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)
- goto cleanup;
+ 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! */
+ }
- /* 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 %C!", comp_tail->name);
- goto cleanup;
- }
- }
+ /* 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;
- /* 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;
+ comp_tail->val = actual->expr;
+ if (actual->expr != NULL)
+ comp_tail->where = actual->expr->where;
+ actual->expr = NULL;
- /* F2008, R457/C725, for PURE C1283. */
- if (this_comp->attr.pointer && gfc_is_coindexed (comp_tail->val))
+ /* 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 ("Coindexed expression to pointer component '%s' in "
- "structure constructor at %C!", 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->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;
+ /* 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;
- 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;
- }
+ actual->expr = comp_tail->val;
+ comp_tail->val = NULL;
- if (comp)
- comp = comp->next;
+ 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 (parent && !comp)
- break;
- }
+ if (comp->ts.u.derived->attr.zero_comp)
+ {
+ comp = comp->next;
+ continue;
+ }
+ }
- while (gfc_match_char (',') == MATCH_YES);
+ if (comp)
+ comp = comp->next;
+ if (parent && !comp)
+ break;
- if (!parent && gfc_match_char (')') != MATCH_YES)
- goto syntax;
+ actual = actual->next;
}
if (build_actual_constructor (&comp_head, &ctor_head, sym) == FAILURE)
/* 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 "
}
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;
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;
}
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
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;
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);
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. */
&& 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;
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);
{
gfc_symbol *sym;
match m;
+ gfc_interface *intr = NULL;
sym = expr->symtree->n.sym;
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);
/* 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,
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)
{
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 "
}
}
+ 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)
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. */
}
}
+ 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
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', "
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.
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. */
}
}
- 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;
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. */
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__";
: 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);
case ISOCBINDING_PTR:
case ISOCBINDING_FUNPTR:
-
- /* 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;
-
- /* 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;
-
- tmp_sym->attr.referenced = 1;
-
- tmp_sym->ts.u.derived = tmp_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 = tmp_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", tmp_sym->name, "c_address");
- gfc_add_component (tmp_sym, comp_name, &tmp_comp);
- if (tmp_comp == NULL)
+ {
+ 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];
+
+ hidden_name = gfc_get_string ("%c%s",
+ (char) TOUPPER ((unsigned char) tmp_sym->name[0]),
+ &tmp_sym->name[1]);
+
+ /* Generate real derived type. */
+ tmp_symtree = gfc_find_symtree (gfc_current_ns->sym_root,
+ hidden_name);
+
+ 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 ();
+
+ /* 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;
+
+ if (!tmp_sym->attr.generic
+ && gfc_add_generic (&tmp_sym->attr, tmp_sym->name, NULL)
+ == FAILURE)
+ return;
+
+ if (!tmp_sym->attr.function
+ && gfc_add_function (&tmp_sym->attr, tmp_sym->name, NULL)
+ == FAILURE)
+ return;
+
+ /* 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:
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;
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;
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;
}
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;
+}
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:
}
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);
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). */
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. */
+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
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.
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
! 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
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
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
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
--- /dev/null
+! { 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
--- /dev/null
+! { 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" } }
--- /dev/null
+! { 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" } }
+
--- /dev/null
+! { 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" } }
OSDN Git Service
