diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog
index c922b8d94d86edb77caee7fb64a04a589b9c1d52..bbcee7a9f4c595bbd28563e14d536da0c45dcbc2 100644
--- a/gcc/fortran/ChangeLog
+++ b/gcc/fortran/ChangeLog
@@ -1,3 +1,73 @@
+2006-08-20 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/28601
+ PR fortran/28630
+ * gfortran.h : Eliminate gfc_dt_list structure and reference
+ to it in gfc_namespace.
+ * resolve.c (resolve_fl_derived): Remove the building of the
+ list of derived types for the current namespace.
+ * symbol.c (find_renamed_type): New function to find renamed
+ derived types by symbol name rather than symtree name.
+ (gfc_use_derived): Search parent namespace for identical
+ derived type and use it, even if local version is complete,
+ except in interface bodies. Ensure that renamed derived types
+ are found by call to find_renamed_type. Recurse for derived
+ type components.
+ (gfc_free_dt_list): Remove.
+ (gfc_free_namespace): Remove call to previous.
+ * trans-types.c (copy_dt_decls_ifequal): Remove.
+ (gfc_get_derived_type): Remove all the paraphenalia for
+ association of derived types, including calls to previous.
+ * match.c (gfc_match_allocate): Call gfc_use_derived to
+ associate any derived types that are being allocated.
+
+ PR fortran/20886
+ * resolve.c (resolve_actual_arglist): The passing of
+ a generic procedure name as an actual argument is an
+ error.
+
+ PR fortran/28735
+ * resolve.c (resolve_variable): Check for a symtree before
+ resolving references.
+
+ PR fortran/28762
+ * primary.c (match_variable): Return MATCH_NO if the symbol
+ is that of the program.
+
+ PR fortran/28425
+ * trans-expr.c (gfc_trans_subcomponent_assign): Translate
+ derived type component expressions other than another derived
+ type constructor.
+
+ PR fortran/28496
+ * expr.c (find_array_section): Correct errors in
+ the handling of a missing start value for the
+ index triplet in an array reference.
+
+ PR fortran/18111
+ * trans-decl.c (gfc_build_dummy_array_decl): Before resetting
+ reference to backend_decl, set it DECL_ARTIFICIAL.
+ (gfc_get_symbol_decl): Likewise for original dummy decl, when
+ a copy is made of an array.
+ (create_function_arglist): Likewise for the _entry paramter
+ in entry_masters.
+ (build_entry_thunks): Likewise for dummies in entry thunks.
+
+ PR fortran/28600
+ * trans-decl.c (gfc_get_symbol_decl): Ensure that the
+ DECL_CONTEXT of the length of a character dummy is the
+ same as that of the symbol declaration.
+
+ PR fortran/28771
+ * decl.c (add_init_expr_to_sym): Remove setting of charlen for
+ an initializer of an assumed charlen variable.
+
+ PR fortran/28660
+ * trans-decl.c (generate_expr_decls): New function.
+ (generate_dependency_declarations): New function.
+ (generate_local_decl): Call previous if not either a dummy or
+ a declaration in an entry master.
+
2006-08-19 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25217
diff --git a/gcc/fortran/decl.c b/gcc/fortran/decl.c
index fb980d63451b6e9cf1181e85a0396ff2c03027dc..79310e9dfbead117f58822230795a5323e8beb0d 100644
--- a/gcc/fortran/decl.c
+++ b/gcc/fortran/decl.c
@@ -875,12 +875,6 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
sym->ts.cl = gfc_get_charlen ();
sym->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = sym->ts.cl;
-
- if (init->expr_type == EXPR_CONSTANT)
- sym->ts.cl->length =
- gfc_int_expr (init->value.character.length);
- else if (init->expr_type == EXPR_ARRAY)
- sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
}
/* Update initializer character length according symbol. */
else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
diff --git a/gcc/fortran/expr.c b/gcc/fortran/expr.c
index 4b037983616f56769a021ead2287499bb862be16..b1f064d0720c542d893504c51492527b04979f3c 100644
--- a/gcc/fortran/expr.c
+++ b/gcc/fortran/expr.c
@@ -1014,6 +1014,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
int rank;
int d;
long unsigned one = 1;
+ mpz_t start[GFC_MAX_DIMENSIONS];
mpz_t end[GFC_MAX_DIMENSIONS];
mpz_t stride[GFC_MAX_DIMENSIONS];
mpz_t delta[GFC_MAX_DIMENSIONS];
@@ -1052,6 +1053,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
for (d = 0; d < rank; d++)
{
mpz_init (delta[d]);
+ mpz_init (start[d]);
mpz_init (end[d]);
mpz_init (ctr[d]);
mpz_init (stride[d]);
@@ -1085,15 +1087,16 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
mpz_set_ui (stride[d], one);
/* Obtain the start value for the index. */
- if (begin->value.integer)
- mpz_set (ctr[d], begin->value.integer);
+ if (begin)
+ mpz_set (start[d], begin->value.integer);
else
{
if (mpz_cmp_si (stride[d], 0) < 0)
- mpz_set (ctr[d], upper->value.integer);
+ mpz_set (start[d], upper->value.integer);
else
- mpz_set (ctr[d], lower->value.integer);
+ mpz_set (start[d], lower->value.integer);
}
+ mpz_set (ctr[d], start[d]);
/* Obtain the end value for the index. */
if (finish)
@@ -1171,7 +1174,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
if (mpz_cmp_ui (stride[d], 0) > 0 ?
mpz_cmp (ctr[d], tmp_mpz) > 0 :
mpz_cmp (ctr[d], tmp_mpz) < 0)
- mpz_set (ctr[d], ref->u.ar.start[d]->value.integer);
+ mpz_set (ctr[d], start[d]);
else
mpz_set_ui (stop, 0);
}
@@ -1205,6 +1208,7 @@ cleanup:
for (d = 0; d < rank; d++)
{
mpz_clear (delta[d]);
+ mpz_clear (start[d]);
mpz_clear (end[d]);
mpz_clear (ctr[d]);
mpz_clear (stride[d]);
diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index 01bcf976e54686275cc805184bc19af17ae729f9..14e2ce6bdb0c97d7f6453f3026090bc03a543a0e 100644
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -927,17 +927,6 @@ typedef struct gfc_symtree
}
gfc_symtree;
-/* A linked list of derived types in the namespace. */
-typedef struct gfc_dt_list
-{
- struct gfc_symbol *derived;
- struct gfc_dt_list *next;
-}
-gfc_dt_list;
-
-#define gfc_get_dt_list() gfc_getmem(sizeof(gfc_dt_list))
-
-
/* A namespace describes the contents of procedure, module or
interface block. */
/* ??? Anything else use these? */
@@ -1000,9 +989,6 @@ typedef struct gfc_namespace
/* A list of all alternate entry points to this procedure (or NULL). */
gfc_entry_list *entries;
- /* A list of all derived types in this procedure (or NULL). */
- gfc_dt_list *derived_types;
-
/* Set to 1 if namespace is a BLOCK DATA program unit. */
int is_block_data;
}
diff --git a/gcc/fortran/match.c b/gcc/fortran/match.c
index 77594cbf5672fa6209bd63013c964ee4b43a3408..e6a7689b0189b786dc404cbcc20856f206ede9f1 100644
--- a/gcc/fortran/match.c
+++ b/gcc/fortran/match.c
@@ -1798,6 +1798,9 @@ gfc_match_allocate (void)
goto cleanup;
}
+ if (tail->expr->ts.type == BT_DERIVED)
+ tail->expr->ts.derived = gfc_use_derived (tail->expr->ts.derived);
+
if (gfc_match_char (',') != MATCH_YES)
break;
diff --git a/gcc/fortran/primary.c b/gcc/fortran/primary.c
index ad569fcf6b643f69b78bf9758bec6be2e80c91c1..c0ed3643a40d0f5947a544ab02878ea66474e6eb 100644
--- a/gcc/fortran/primary.c
+++ b/gcc/fortran/primary.c
@@ -2295,6 +2295,10 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
case FL_VARIABLE:
break;
+ case FL_PROGRAM:
+ return MATCH_NO;
+ break;
+
case FL_UNKNOWN:
if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE)
diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c
index 5c9786b74100c03c85fe4d6be78f7545970da0f0..3924dc69aa91add6be9dce29517ebd59563e37cd 100644
--- a/gcc/fortran/resolve.c
+++ b/gcc/fortran/resolve.c
@@ -858,6 +858,13 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
&e->where);
}
+ if (sym->attr.generic)
+ {
+ gfc_error ("GENERIC non-INTRINSIC procedure '%s' is not "
+ "allowed as an actual argument at %L", sym->name,
+ &e->where);
+ }
+
/* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */
@@ -2883,10 +2890,10 @@ resolve_variable (gfc_expr * e)
t = SUCCESS;
- if (e->ref && resolve_ref (e) == FAILURE)
+ if (e->symtree == NULL)
return FAILURE;
- if (e->symtree == NULL)
+ if (e->ref && resolve_ref (e) == FAILURE)
return FAILURE;
sym = e->symtree->n.sym;
@@ -5360,7 +5367,6 @@ static try
resolve_fl_derived (gfc_symbol *sym)
{
gfc_component *c;
- gfc_dt_list * dt_list;
int i;
for (c = sym->components; c != NULL; c = c->next)
@@ -5423,12 +5429,6 @@ resolve_fl_derived (gfc_symbol *sym)
}
}
- /* Add derived type to the derived type list. */
- dt_list = gfc_get_dt_list ();
- dt_list->next = sym->ns->derived_types;
- dt_list->derived = sym;
- sym->ns->derived_types = dt_list;
-
return SUCCESS;
}
diff --git a/gcc/fortran/symbol.c b/gcc/fortran/symbol.c
index 63e45ecb5fe7ae58fcf7800ff941afd6836305c2..801e85acec0ec4941ea48f42a2472ef2cc2c90f0 100644
--- a/gcc/fortran/symbol.c
+++ b/gcc/fortran/symbol.c
@@ -1364,6 +1364,33 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen
}
+/* Recursive search for a renamed derived type. */
+
+static gfc_symbol *
+find_renamed_type (gfc_symbol * der, gfc_symtree * st)
+{
+ gfc_symbol *sym = NULL;
+
+ if (st == NULL)
+ return NULL;
+
+ sym = find_renamed_type (der, st->left);
+ if (sym != NULL)
+ return sym;
+
+ sym = find_renamed_type (der, st->right);
+ if (sym != NULL)
+ return sym;
+
+ if (strcmp (der->name, st->n.sym->name) == 0
+ && st->n.sym->attr.use_assoc
+ && st->n.sym->attr.flavor == FL_DERIVED
+ && gfc_compare_derived_types (der, st->n.sym))
+ sym = st->n.sym;
+
+ return sym;
+}
+
/* Recursive function to switch derived types of all symbol in a
namespace. */
@@ -1408,20 +1435,68 @@ gfc_use_derived (gfc_symbol * sym)
gfc_symbol *s;
gfc_typespec *t;
gfc_symtree *st;
+ gfc_component *c;
int i;
- if (sym->components != NULL)
- return sym; /* Already defined. */
-
if (sym->ns->parent == NULL)
- goto bad;
+ {
+ /* Already defined in highest possible namespace. */
+ if (sym->components != NULL)
+ return sym;
+
+ /* There is no scope for finding a definition elsewhere. */
+ else
+ goto bad;
+ }
+ else
+ {
+ /* This type can only be locally associated. */
+ if (!(sym->attr.use_assoc || sym->attr.sequence))
+ return sym;
+
+ /* Derived types must be defined within an interface. */
+ if (gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY)
+ return sym;
+ }
+ /* Look in parent namespace for a derived type of the same name. */
if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
{
gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
return NULL;
}
+ if (s == NULL || s->attr.flavor != FL_DERIVED)
+ {
+ /* Check to see if type has been renamed in parent namespace.
+ Leave cleanup of local symbols until the end of the
+ compilation because doing it here is complicated by
+ multiple association with the same type. */
+ s = find_renamed_type (sym, sym->ns->parent->sym_root);
+ if (s != NULL)
+ {
+ switch_types (sym->ns->sym_root, sym, s);
+ return s;
+ }
+
+ /* The local definition is all that there is. */
+ if (sym->components != NULL)
+ {
+ /* Non-pointer derived type components have already been checked
+ but pointer types need to be correctly associated. */
+ for (c = sym->components; c; c = c->next)
+ if (c->ts.type == BT_DERIVED && c->pointer)
+ c->ts.derived = gfc_use_derived (c->ts.derived);
+
+ return sym;
+ }
+ }
+
+ /* Although the parent namespace has a derived type of the same name, it is
+ not an identical derived type and so cannot be used. */
+ if (s != NULL && sym->components != NULL && !gfc_compare_derived_types (s, sym))
+ return sym;
+
if (s == NULL || s->attr.flavor != FL_DERIVED)
goto bad;
@@ -2440,21 +2515,6 @@ free_sym_tree (gfc_symtree * sym_tree)
}
-/* Free a derived type list. */
-
-static void
-gfc_free_dt_list (gfc_dt_list * dt)
-{
- gfc_dt_list *n;
-
- for (; dt; dt = n)
- {
- n = dt->next;
- gfc_free (dt);
- }
-}
-
-
/* Free the gfc_equiv_info's. */
static void
@@ -2517,8 +2577,6 @@ gfc_free_namespace (gfc_namespace * ns)
gfc_free_equiv (ns->equiv);
gfc_free_equiv_lists (ns->equiv_lists);
- gfc_free_dt_list (ns->derived_types);
-
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
gfc_free_interface (ns->operator[i]);
diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c
index 7398e16423763ac945ea31ec6b79eec522b95a48..855c98216c56c537a3275ef83a6d07caf8800f73 100644
--- a/gcc/fortran/trans-decl.c
+++ b/gcc/fortran/trans-decl.c
@@ -728,6 +728,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
/* We now have an expression for the element size, so create a fully
qualified type. Reset sym->backend decl or this will just return the
old type. */
+ DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = NULL_TREE;
type = gfc_sym_type (sym);
packed = 2;
@@ -884,7 +885,15 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE)
{
- gfc_add_decl_to_function (length);
+ /* Add the string length to the same context as the symbol. */
+ if (DECL_CONTEXT (sym->backend_decl) == current_function_decl)
+ gfc_add_decl_to_function (length);
+ else
+ gfc_add_decl_to_parent_function (length);
+
+ gcc_assert (DECL_CONTEXT (sym->backend_decl) ==
+ DECL_CONTEXT (length));
+
gfc_defer_symbol_init (sym);
}
}
@@ -892,8 +901,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
/* Use a copy of the descriptor for dummy arrays. */
if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
{
- sym->backend_decl =
- gfc_build_dummy_array_decl (sym, sym->backend_decl);
+ decl = gfc_build_dummy_array_decl (sym, sym->backend_decl);
+ /* Prevent the dummy from being detected as unused if it is copied. */
+ if (sym->backend_decl != NULL && decl != sym->backend_decl)
+ DECL_ARTIFICIAL (sym->backend_decl) = 1;
+ sym->backend_decl = decl;
}
TREE_USED (sym->backend_decl) = 1;
@@ -1284,6 +1296,7 @@ create_function_arglist (gfc_symbol * sym)
DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1;
gfc_finish_decl (parm, NULL_TREE);
+ DECL_ARTIFICIAL (parm) = 1;
arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist);
@@ -1603,6 +1616,7 @@ build_entry_thunks (gfc_namespace * ns)
if (thunk_formal)
{
/* Pass the argument. */
+ DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
args);
if (formal->sym->ts.type == BT_CHARACTER)
@@ -2743,6 +2757,112 @@ gfc_generate_contained_functions (gfc_namespace * parent)
}
+/* Drill down through expressions for the array specification bounds and
+ character length calling generate_local_decl for all those variables
+ that have not already been declared. */
+
+static void
+generate_local_decl (gfc_symbol *);
+
+static void
+generate_expr_decls (gfc_symbol *sym, gfc_expr *e)
+{
+ gfc_actual_arglist *arg;
+ gfc_ref *ref;
+ int i;
+
+ if (e == NULL)
+ return;
+
+ switch (e->expr_type)
+ {
+ case EXPR_FUNCTION:
+ for (arg = e->value.function.actual; arg; arg = arg->next)
+ generate_expr_decls (sym, arg->expr);
+ break;
+
+ /* If the variable is not the same as the dependent, 'sym', and
+ it is not marked as being declared and it is in the same
+ namespace as 'sym', add it to the local declarations. */
+ case EXPR_VARIABLE:
+ if (sym == e->symtree->n.sym
+ || e->symtree->n.sym->mark
+ || e->symtree->n.sym->ns != sym->ns)
+ return;
+
+ generate_local_decl (e->symtree->n.sym);
+ break;
+
+ case EXPR_OP:
+ generate_expr_decls (sym, e->value.op.op1);
+ generate_expr_decls (sym, e->value.op.op2);
+ break;
+
+ default:
+ break;
+ }
+
+ if (e->ref)
+ {
+ for (ref = e->ref; ref; ref = ref->next)
+ {
+ switch (ref->type)
+ {
+ case REF_ARRAY:
+ for (i = 0; i < ref->u.ar.dimen; i++)
+ {
+ generate_expr_decls (sym, ref->u.ar.start[i]);
+ generate_expr_decls (sym, ref->u.ar.end[i]);
+ generate_expr_decls (sym, ref->u.ar.stride[i]);
+ }
+ break;
+
+ case REF_SUBSTRING:
+ generate_expr_decls (sym, ref->u.ss.start);
+ generate_expr_decls (sym, ref->u.ss.end);
+ break;
+
+ case REF_COMPONENT:
+ if (ref->u.c.component->ts.type == BT_CHARACTER
+ && ref->u.c.component->ts.cl->length->expr_type
+ != EXPR_CONSTANT)
+ generate_expr_decls (sym, ref->u.c.component->ts.cl->length);
+
+ if (ref->u.c.component->as)
+ for (i = 0; i < ref->u.c.component->as->rank; i++)
+ {
+ generate_expr_decls (sym, ref->u.c.component->as->lower[i]);
+ generate_expr_decls (sym, ref->u.c.component->as->upper[i]);
+ }
+ break;
+ }
+ }
+ }
+}
+
+
+/* Check for dependencies in the character length and array spec. */
+
+static void
+generate_dependency_declarations (gfc_symbol *sym)
+{
+ int i;
+
+ if (sym->ts.type == BT_CHARACTER
+ && sym->ts.cl->length->expr_type != EXPR_CONSTANT)
+ generate_expr_decls (sym, sym->ts.cl->length);
+
+ if (sym->as && sym->as->rank)
+ {
+ for (i = 0; i < sym->as->rank; i++)
+ {
+ generate_expr_decls (sym, sym->as->lower[i]);
+ generate_expr_decls (sym, sym->as->upper[i]);
+ }
+ }
+}
+
+
/* Generate decls for all local variables. We do this to ensure correct
handling of expressions which only appear in the specification of
other functions. */
@@ -2752,6 +2872,14 @@ generate_local_decl (gfc_symbol * sym)
{
if (sym->attr.flavor == FL_VARIABLE)
{
+ /* Check for dependencies in the array specification and string
+ length, adding the necessary declarations to the function. We
+ mark the symbol now, as well as in traverse_ns, to prevent
+ getting stuck in a circular dependency. */
+ sym->mark = 1;
+ if (!sym->attr.dummy && !sym->ns->proc_name->attr.entry_master)
+ generate_dependency_declarations (sym);
+
if (sym->attr.referenced)
gfc_get_symbol_decl (sym);
else if (sym->attr.dummy && warn_unused_parameter)
diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 4225b6930c3481fdc865a5425ecb39ec61c7e989..b1bd2170638729e5ff44101dd9f6c54431fa267b 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -2669,9 +2669,19 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
}
else if (expr->ts.type == BT_DERIVED)
{
- /* Nested derived type. */
- tmp = gfc_trans_structure_assign (dest, expr);
- gfc_add_expr_to_block (&block, tmp);
+ if (expr->expr_type != EXPR_STRUCTURE)
+ {
+ gfc_init_se (&se, NULL);
+ gfc_conv_expr (&se, expr);
+ gfc_add_modify_expr (&block, dest,
+ fold_convert (TREE_TYPE (dest), se.expr));
+ }
+ else
+ {
+ /* Nested constructors. */
+ tmp = gfc_trans_structure_assign (dest, expr);
+ gfc_add_expr_to_block (&block, tmp);
+ }
}
else
{
diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c
index ca93adbf968e8fd11c4c7efdc53fd5d0edf4eb69..3eb1f2cc06d11a3016eef8d64cd6dbb8e5c05870 100644
--- a/gcc/fortran/trans-types.c
+++ b/gcc/fortran/trans-types.c
@@ -1411,59 +1411,15 @@ gfc_add_field_to_struct (tree *fieldlist, tree context,
}
-/* Copy the backend_decl and component backend_decls if
- the two derived type symbols are "equal", as described
- in 4.4.2 and resolved by gfc_compare_derived_types. */
-
-static int
-copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to)
-{
- gfc_component *to_cm;
- gfc_component *from_cm;
-
- if (from->backend_decl == NULL
- || !gfc_compare_derived_types (from, to))
- return 0;
-
- to->backend_decl = from->backend_decl;
-
- to_cm = to->components;
- from_cm = from->components;
-
- /* Copy the component declarations. If a component is itself
- a derived type, we need a copy of its component declarations.
- This is done by recursing into gfc_get_derived_type and
- ensures that the component's component declarations have
- been built. If it is a character, we need the character
- length, as well. */
- for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next)
- {
- to_cm->backend_decl = from_cm->backend_decl;
- if (from_cm->ts.type == BT_DERIVED)
- gfc_get_derived_type (to_cm->ts.derived);
-
- else if (from_cm->ts.type == BT_CHARACTER)
- to_cm->ts.cl->backend_decl = from_cm->ts.cl->backend_decl;
- }
-
- return 1;
-}
-
-
-/* Build a tree node for a derived type. If there are equal
- derived types, with different local names, these are built
- at the same time. If an equal derived type has been built
- in a parent namespace, this is used. */
+/* Build a tree node for a derived type. */
static tree
gfc_get_derived_type (gfc_symbol * derived)
{
tree typenode, field, field_type, fieldlist;
gfc_component *c;
- gfc_dt_list *dt;
- gfc_namespace * ns;
- gcc_assert (derived && derived->attr.flavor == FL_DERIVED);
+ gcc_assert (derived);
/* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */
@@ -1477,29 +1433,6 @@ gfc_get_derived_type (gfc_symbol * derived)
}
else
{
- /* In a module, if an equal derived type is already available in the
- specification block, use its backend declaration and those of its
- components, rather than building anew so that potential dummy and
- actual arguments use the same TREE_TYPE. Non-module structures,
- need to be built, if found, because the order of visits to the
- namespaces is different. */
-
- for (ns = derived->ns->parent; ns; ns = ns->parent)
- {
- for (dt = ns->derived_types; dt; dt = dt->next)
- {
- if (derived->module == NULL
- && dt->derived->backend_decl == NULL
- && gfc_compare_derived_types (dt->derived, derived))
- gfc_get_derived_type (dt->derived);
-
- if (copy_dt_decls_ifequal (dt->derived, derived))
- break;
- }
- if (derived->backend_decl)
- goto other_equal_dts;
- }
-
/* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name);
@@ -1578,12 +1511,6 @@ gfc_get_derived_type (gfc_symbol * derived)
derived->backend_decl = typenode;
-other_equal_dts:
- /* Add this backend_decl to all the other, equal derived types and
- their components in this namespace. */
- for (dt = derived->ns->derived_types; dt; dt = dt->next)
- copy_dt_decls_ifequal (derived, dt->derived);
-
return derived->backend_decl;
}
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index 6f8ae4dd29bf866861ae1d6000ce0025fabbd24f..ad646c5613cae457a6182c8a2bbf5d5fd839688d 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,38 @@
+2006-08-20 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/28630
+ * gfortran.dg/used_types_2.f90: New test.
+
+ PR fortran/28601
+ * gfortran.dg/used_types_3.f90: New test.
+
+ PR fortran/20886
+ * gfortran.dg/generic_actual_arg.f90: New test.
+
+ PR fortran/28735
+ * gfortran.dg/module_private_array_refs_1.f90: New test.
+
+ PR fortran/28762
+ * gfortran.dg/program_name_1.f90: New test.
+
+ PR fortran/28425
+ * gfortran.dg/derived_constructor_comps_1.f90: New test.
+
+ PR fortran/28496
+ * gfortran.dg/array_initializer_2.f90: New test.
+
+ PR fortran/18111
+ * gfortran.dg/unused_artificial_dummies_1.f90: New test.
+
+ PR fortran/28600
+ * gfortran.dg/assumed_charlen_function_4.f90: New test.
+
+ PR fortran/28771
+ * gfortran.dg/assumed_charlen_in_main.f90: New test.
+
+ PR fortran/28660
+ * gfortran.dg/dependent_decls_1.f90: New test.
+
2006-08-19 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25217
diff --git a/gcc/testsuite/gfortran.dg/array_initializer_2.f90 b/gcc/testsuite/gfortran.dg/array_initializer_2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a1a5bdf024a361c14974ec644b5c74bde121ca44
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/array_initializer_2.f90
@@ -0,0 +1,17 @@
+! { dg-do run }
+! Tests the fix for PR28496 in which initializer array constructors with
+! a missing initial array index would cause an ICE.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+! Based on original test case from Samir Nordin <snordin_ng@yahoo.fr>
+!
+ integer, dimension(3), parameter :: a=(/1,2,3/)
+ integer, dimension(3), parameter :: b=(/a(:)/)
+ integer, dimension(3,3), parameter :: c=reshape ((/(i, i = 1,9)/),(/3,3/))
+ integer, dimension(2,3), parameter :: d=reshape ((/c(:2:-1,:)/),(/2,3/))
+ integer, dimension(3,3), parameter :: e=reshape ((/a(:),a(:)+3,a(:)+6/),(/3,3/))
+ integer, dimension(2,3), parameter :: f=reshape ((/c(2:1:-1,:)/),(/2,3/))
+ if (any (b .ne. (/1,2,3/))) call abort ()
+ if (any (reshape(d,(/6/)) .ne. (/3, 2, 6, 5, 9, 8/))) call abort ()
+ if (any (reshape(f,(/6/)) .ne. (/2, 1, 5, 4, 8, 7/))) call abort ()
+end
diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_function_4.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_function_4.f90
new file mode 100644
index 0000000000000000000000000000000000000000..9c96ba4d69fa705a9395fb3abcd76ffd64fb5124
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_charlen_function_4.f90
@@ -0,0 +1,17 @@
+! { dg-do compile }
+! Tests the fix for PR28600 in which the declaration for the
+! character length n, would be given the DECL_CONTEXT of 'gee'
+! thus causing an ICE.
+!
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+!
+subroutine bar(s, n)
+ integer n
+ character s*(n)
+ character*3, dimension(:), pointer :: m
+ s = ""
+contains
+ subroutine gee
+ m(1) = s(1:3)
+ end subroutine gee
+end subroutine bar
diff --git a/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90 b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
new file mode 100644
index 0000000000000000000000000000000000000000..a29bdb9d5d023036f909c4b80312be288709a405
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/assumed_charlen_in_main.f90
@@ -0,0 +1,13 @@
+! { dg-do compile }
+! Tests the fix for PR28771 in which an assumed character length variable with an initializer could
+! survive in the main program without causing an error.
+!
+! Contributed by Martin Reinecke <martin@mpa-garching.mpg.de>
+!
+program test
+ character(len=*), parameter :: foo = 'test' ! Parameters must work.
+ character(len=4) :: bar = foo
+ character(len=*) :: foobar = 'This should fail' ! { dg-error "must be a dummy" }
+ print *, bar
+end
+
diff --git a/gcc/testsuite/gfortran.dg/dependent_decls_1.f90 b/gcc/testsuite/gfortran.dg/dependent_decls_1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..675c4a0d00d6ef45bec36657c87b350d1dfa9b7f
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/dependent_decls_1.f90
@@ -0,0 +1,39 @@
+! { dg-do run }
+! Tests the fix for pr28660 in which the order of dependent declarations
+! would get scrambled in the compiled code.
+!
+! Contributed by Erik Edelmann <erik.edelmann@iki.fi>
+!
+program bar
+ implicit none
+ real :: x(10)
+ call foo1 (x)
+ call foo2 (x)
+ call foo3 (x)
+contains
+ subroutine foo1 (xmin)
+ real, intent(inout) :: xmin(:)
+ real :: x(size(xmin)+1) ! The declaration for r would be added
+ real :: r(size(x)-2) ! to the function before that of x
+ xmin = r
+ if (size(r) .ne. 9) call abort ()
+ if (size(x) .ne. 11) call abort ()
+ end subroutine foo1
+ subroutine foo2 (xmin) ! This version was OK because of the
+ real, intent(inout) :: xmin(:) ! renaming of r which pushed it up
+ real :: x(size(xmin)+3) ! the symtree.
+ real :: zr(size(x)-6)
+ xmin = zr
+ if (size(zr) .ne. 7) call abort ()
+ if (size(x) .ne. 13) call abort ()
+ end subroutine foo2
+ subroutine foo3 (xmin)
+ real, intent(inout) :: xmin(:)
+ character(size(x)+2) :: y ! host associated x
+ character(len(y)+3) :: z ! This did not work for any combination
+ real :: r(len(z)-10) ! of names.
+ xmin = r
+ if (size(r) .ne. 5) call abort ()
+ if (len(z) .ne. 15) call abort ()
+ end subroutine foo3
+end program bar
diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_comps_1.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_comps_1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..1c02a31c7a319855d0d8317b8b8f78dbef73a7c0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/derived_constructor_comps_1.f90
@@ -0,0 +1,56 @@
+! { dg-do run }
+!
+! Tests fix for PR28425 in which anything other than a constructor would
+! not work for derived type components in a structure constructor.
+!
+! Original version sent by Vivek Rao on 18 Jan 06
+! Modified by Steve Kargl to remove IO
+!
+module foo_mod
+
+ implicit none
+
+ type :: date_m
+ integer :: month
+ end type date_m
+
+ type :: file_info
+ type(date_m) :: date
+ end type file_info
+
+end module foo_mod
+
+program prog
+
+ use foo_mod
+
+ implicit none
+ type(date_m) :: dat
+ type(file_info) :: xx
+
+ type(date_m), parameter :: christmas = date_m (12)
+
+ dat = date_m(1)
+
+ xx = file_info(date_m(-1)) ! This always worked - a constructor
+ if (xx%date%month /= -1) call abort
+
+ xx = file_info(dat) ! This was the original PR - a variable
+ if (xx%date%month /= 1) call abort
+
+ xx = file_info(foo(2)) ! ...functions were also broken
+ if (xx%date%month /= 2) call abort
+
+ xx = file_info(christmas) ! ...and parameters
+ if (xx%date%month /= 12) call abort
+
+
+contains
+
+ function foo (i) result (ans)
+ integer :: i
+ type(date_m) :: ans
+ ans = date_m(i)
+ end function foo
+
+end program prog
diff --git a/gcc/testsuite/gfortran.dg/generic_actual_arg.f90 b/gcc/testsuite/gfortran.dg/generic_actual_arg.f90
new file mode 100644
index 0000000000000000000000000000000000000000..93a6588592fa8770edef60806f1f8982b83fffe0
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/generic_actual_arg.f90
@@ -0,0 +1,25 @@
+! { dg-do compile }
+! Tests fix for PR20886 in which the passing of a generic procedure as
+! an actual argument was not detected.
+!
+! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
+!
+MODULE TEST
+INTERFACE CALCULATION
+ MODULE PROCEDURE C1,C2
+END INTERFACE
+CONTAINS
+SUBROUTINE C1(r)
+ INTEGER :: r
+END SUBROUTINE
+SUBROUTINE C2(r)
+ REAL :: r
+END SUBROUTINE
+END MODULE TEST
+
+USE TEST
+CALL F(CALCULATION) ! { dg-error "GENERIC non-INTRINSIC procedure" }
+END
+
+SUBROUTINE F()
+END SUBROUTINE
\ No newline at end of file
diff --git a/gcc/testsuite/gfortran.dg/module_private_array_refs_1.f90 b/gcc/testsuite/gfortran.dg/module_private_array_refs_1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..2b239747b63a1d461e8f68038a5b32706c8fe4c4
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/module_private_array_refs_1.f90
@@ -0,0 +1,51 @@
+! { dg-do compile }
+! This tests the fix for PR28735 in which an ICE would be triggered in resolve_ref
+! because the references to 'a' and 'b' in the dummy arguments of mysub have
+! no symtrees in module bar, being private there.
+!
+! Contributed by Andrew Sampson <adsspamtrap01@yahoo.com>
+!
+!-- foo.F -----------------------------------------------
+module foo
+ implicit none
+ public
+ integer, allocatable :: a(:), b(:)
+end module foo
+
+!-- bar.F ---------------------------------------------
+module bar
+ use foo
+ implicit none
+ private ! This triggered the ICE
+ public :: mysub ! since a and b are not public
+
+contains
+
+ subroutine mysub(n, parray1)
+ integer, intent(in) :: n
+ real, dimension(a(n):b(n)) :: parray1
+ if ((n == 1) .and. size(parray1, 1) /= 10) call abort ()
+ if ((n == 2) .and. size(parray1, 1) /= 42) call abort ()
+ end subroutine mysub
+end module bar
+
+!-- sub.F -------------------------------------------------------
+subroutine sub()
+
+ use foo
+ use bar
+ real :: z(100)
+ allocate (a(2), b(2))
+ a = (/1, 6/)
+ b = (/10, 47/)
+ call mysub (1, z)
+ call mysub (2, z)
+
+ return
+end
+
+!-- MAIN ------------------------------------------------------
+ use bar
+ call sub ()
+end
+
diff --git a/gcc/testsuite/gfortran.dg/program_name_1.f90 b/gcc/testsuite/gfortran.dg/program_name_1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..6d6c79bb06d9e87489ceefafd616376792af514b
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/program_name_1.f90
@@ -0,0 +1,11 @@
+! { dg-do compile }
+! Tests the fix for PR28762 in which the program name would cause
+! the compiler to test the write statement as a variable thereby generating
+! an "Expecting VARIABLE" error.
+!
+! Contributed by David Ham <David@ham.dropbear.id.au>
+!
+program write
+ integer :: debuglevel = 1
+ if (0 < debuglevel) write (*,*) "Hello World"
+end program write
diff --git a/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90 b/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90
new file mode 100644
index 0000000000000000000000000000000000000000..68ceee7af331844b3d0bd5af96fdaae08d056861
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/unused_artificial_dummies_1.f90
@@ -0,0 +1,49 @@
+! { dg-do compile }
+! { dg-options "-Wunused-variable -Wunused-parameter" }
+! This tests the fix for PR18111 in which some artificial declarations
+! were being listed as unused parameters:
+! (i) Array dummies, where a copy is made;
+! (ii) The dummies of "entry thunks" (ie. the articial procedures that
+! represent ENTRYs and call the "entry_master" function; and
+! (iii) The __entry parameter of the entry_master function, which
+! indentifies the calling entry thunk.
+! All of these have DECL_ARTIFICIAL (tree) set.
+!
+! Contributed by Paul Thomas <pault@gcc.gnu.org>
+!
+module foo
+ implicit none
+contains
+
+!This is the original problem
+
+ subroutine bar(arg1, arg2, arg3, arg4, arg5)
+ character(len=80), intent(in) :: arg1
+ character(len=80), dimension(:), intent(in) :: arg2
+ integer, dimension(arg4), intent(in) :: arg3
+ integer, intent(in) :: arg4
+ character(len=arg4), intent(in) :: arg5
+ print *, arg1, arg2, arg3, arg4, arg5
+ end subroutine bar
+
+! This ICED with the first version of the fix because gfc_build_dummy_array_decl
+! sometimes NULLS sym->backend_decl; taken from aliasing_dummy_1.f90
+
+ subroutine foo1 (slist, i)
+ character(*), dimension(*) :: slist
+ integer i
+ write (slist(i), '(2hi=,i3)') i
+ end subroutine foo1
+
+! This tests the additions to the fix that prevent the dummies of entry thunks
+! and entry_master __entry parameters from being listed as unused.
+
+ function f1 (a)
+ integer, dimension (2, 2) :: a, b, f1, e1
+ f1 (:, :) = 15 + a
+ return
+ entry e1 (b)
+ e1 (:, :) = 42 + b
+ end function
+
+end module foo
diff --git a/gcc/testsuite/gfortran.dg/used_types_2.f90 b/gcc/testsuite/gfortran.dg/used_types_2.f90
new file mode 100644
index 0000000000000000000000000000000000000000..167323c0cb14658a6234a83e429dca0020a8d813
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_types_2.f90
@@ -0,0 +1,33 @@
+! { dg-do compile }
+! Tests the fix for PR28630, in which a contained,
+! derived type function caused an ICE if its definition
+! was both host and use associated.
+!
+! Contributed by Mark Hesselink <mhesseli@alumni.caltech.edu>
+!
+MODULE types
+ TYPE :: t
+ INTEGER :: i
+ END TYPE
+END MODULE types
+
+MODULE foo
+ USE types
+CONTAINS
+ FUNCTION bar (x) RESULT(r)
+ USE types
+ REAL, INTENT(IN) :: x
+ TYPE(t) :: r
+ r = t(0)
+ END FUNCTION bar
+END MODULE
+
+
+LOGICAL FUNCTION foobar (x)
+ USE foo
+ REAL, INTENT(IN) :: x
+ TYPE(t) :: c
+ foobar = .FALSE.
+ c = bar (x)
+END FUNCTION foobar
+
diff --git a/gcc/testsuite/gfortran.dg/used_types_3.f90 b/gcc/testsuite/gfortran.dg/used_types_3.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8273ee420ea20d477c936e3b90e537b6f4d8eb3c
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/used_types_3.f90
@@ -0,0 +1,57 @@
+! { dg-do compile }
+! Test the fix for PR28601 in which line 55 would produce an ICE
+! because the rhs and lhs derived times were not identically
+! associated and so could not be cast.
+!
+! Contributed by Francois-Xavier Coudert <fxcoudert@gcc.gnu.org>
+!
+module modA
+implicit none
+save
+private
+
+type, public :: typA
+integer :: i
+end type typA
+
+type, public :: atom
+type(typA), pointer :: ofTypA(:,:)
+end type atom
+end module modA
+
+!!! re-name and re-export typA as typB:
+module modB
+use modA, only: typB => typA
+implicit none
+save
+private
+
+public typB
+end module modB
+
+!!! mixed used of typA and typeB:
+module modC
+use modB
+implicit none
+save
+private
+contains
+
+subroutine buggy(a)
+use modA, only: atom
+! use modB, only: typB
+! use modA, only: typA
+implicit none
+type(atom),intent(inout) :: a
+target :: a
+! *** end of interface ***
+
+type(typB), pointer :: ofTypB(:,:)
+! type(typA), pointer :: ofTypB(:,:)
+integer :: i,j,k
+
+ofTypB => a%ofTypA
+
+a%ofTypA(i,j) = ofTypB(k,j)
+end subroutine buggy
+end module modC