Commit 3e978d30 by Paul Thomas

re PR fortran/28601 (ICE on reexport of renamed type)

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

From-SVN: r116268
parent 84572ba5
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> 2006-08-19 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25217 PR fortran/25217
......
...@@ -875,12 +875,6 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp, ...@@ -875,12 +875,6 @@ add_init_expr_to_sym (const char *name, gfc_expr ** initp,
sym->ts.cl = gfc_get_charlen (); sym->ts.cl = gfc_get_charlen ();
sym->ts.cl->next = gfc_current_ns->cl_list; sym->ts.cl->next = gfc_current_ns->cl_list;
gfc_current_ns->cl_list = sym->ts.cl; 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. */ /* Update initializer character length according symbol. */
else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT) else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
......
...@@ -1014,6 +1014,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) ...@@ -1014,6 +1014,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
int rank; int rank;
int d; int d;
long unsigned one = 1; long unsigned one = 1;
mpz_t start[GFC_MAX_DIMENSIONS];
mpz_t end[GFC_MAX_DIMENSIONS]; mpz_t end[GFC_MAX_DIMENSIONS];
mpz_t stride[GFC_MAX_DIMENSIONS]; mpz_t stride[GFC_MAX_DIMENSIONS];
mpz_t delta[GFC_MAX_DIMENSIONS]; mpz_t delta[GFC_MAX_DIMENSIONS];
...@@ -1052,6 +1053,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) ...@@ -1052,6 +1053,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
for (d = 0; d < rank; d++) for (d = 0; d < rank; d++)
{ {
mpz_init (delta[d]); mpz_init (delta[d]);
mpz_init (start[d]);
mpz_init (end[d]); mpz_init (end[d]);
mpz_init (ctr[d]); mpz_init (ctr[d]);
mpz_init (stride[d]); mpz_init (stride[d]);
...@@ -1085,15 +1087,16 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) ...@@ -1085,15 +1087,16 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
mpz_set_ui (stride[d], one); mpz_set_ui (stride[d], one);
/* Obtain the start value for the index. */ /* Obtain the start value for the index. */
if (begin->value.integer) if (begin)
mpz_set (ctr[d], begin->value.integer); mpz_set (start[d], begin->value.integer);
else else
{ {
if (mpz_cmp_si (stride[d], 0) < 0) if (mpz_cmp_si (stride[d], 0) < 0)
mpz_set (ctr[d], upper->value.integer); mpz_set (start[d], upper->value.integer);
else 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. */ /* Obtain the end value for the index. */
if (finish) if (finish)
...@@ -1171,7 +1174,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref) ...@@ -1171,7 +1174,7 @@ find_array_section (gfc_expr *expr, gfc_ref *ref)
if (mpz_cmp_ui (stride[d], 0) > 0 ? if (mpz_cmp_ui (stride[d], 0) > 0 ?
mpz_cmp (ctr[d], tmp_mpz) > 0 : mpz_cmp (ctr[d], tmp_mpz) > 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 else
mpz_set_ui (stop, 0); mpz_set_ui (stop, 0);
} }
...@@ -1205,6 +1208,7 @@ cleanup: ...@@ -1205,6 +1208,7 @@ cleanup:
for (d = 0; d < rank; d++) for (d = 0; d < rank; d++)
{ {
mpz_clear (delta[d]); mpz_clear (delta[d]);
mpz_clear (start[d]);
mpz_clear (end[d]); mpz_clear (end[d]);
mpz_clear (ctr[d]); mpz_clear (ctr[d]);
mpz_clear (stride[d]); mpz_clear (stride[d]);
......
...@@ -927,17 +927,6 @@ typedef struct gfc_symtree ...@@ -927,17 +927,6 @@ typedef struct gfc_symtree
} }
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 /* A namespace describes the contents of procedure, module or
interface block. */ interface block. */
/* ??? Anything else use these? */ /* ??? Anything else use these? */
...@@ -1000,9 +989,6 @@ typedef struct gfc_namespace ...@@ -1000,9 +989,6 @@ typedef struct gfc_namespace
/* A list of all alternate entry points to this procedure (or NULL). */ /* A list of all alternate entry points to this procedure (or NULL). */
gfc_entry_list *entries; 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. */ /* Set to 1 if namespace is a BLOCK DATA program unit. */
int is_block_data; int is_block_data;
} }
......
...@@ -1798,6 +1798,9 @@ gfc_match_allocate (void) ...@@ -1798,6 +1798,9 @@ gfc_match_allocate (void)
goto cleanup; 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) if (gfc_match_char (',') != MATCH_YES)
break; break;
......
...@@ -2295,6 +2295,10 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag) ...@@ -2295,6 +2295,10 @@ match_variable (gfc_expr ** result, int equiv_flag, int host_flag)
case FL_VARIABLE: case FL_VARIABLE:
break; break;
case FL_PROGRAM:
return MATCH_NO;
break;
case FL_UNKNOWN: case FL_UNKNOWN:
if (gfc_add_flavor (&sym->attr, FL_VARIABLE, if (gfc_add_flavor (&sym->attr, FL_VARIABLE,
sym->name, NULL) == FAILURE) sym->name, NULL) == FAILURE)
......
...@@ -858,6 +858,13 @@ resolve_actual_arglist (gfc_actual_arglist * arg) ...@@ -858,6 +858,13 @@ resolve_actual_arglist (gfc_actual_arglist * arg)
&e->where); &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 /* If the symbol is the function that names the current (or
parent) scope, then we really have a variable reference. */ parent) scope, then we really have a variable reference. */
...@@ -2883,10 +2890,10 @@ resolve_variable (gfc_expr * e) ...@@ -2883,10 +2890,10 @@ resolve_variable (gfc_expr * e)
t = SUCCESS; t = SUCCESS;
if (e->ref && resolve_ref (e) == FAILURE) if (e->symtree == NULL)
return FAILURE; return FAILURE;
if (e->symtree == NULL) if (e->ref && resolve_ref (e) == FAILURE)
return FAILURE; return FAILURE;
sym = e->symtree->n.sym; sym = e->symtree->n.sym;
...@@ -5360,7 +5367,6 @@ static try ...@@ -5360,7 +5367,6 @@ static try
resolve_fl_derived (gfc_symbol *sym) resolve_fl_derived (gfc_symbol *sym)
{ {
gfc_component *c; gfc_component *c;
gfc_dt_list * dt_list;
int i; int i;
for (c = sym->components; c != NULL; c = c->next) for (c = sym->components; c != NULL; c = c->next)
...@@ -5423,12 +5429,6 @@ resolve_fl_derived (gfc_symbol *sym) ...@@ -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; return SUCCESS;
} }
......
...@@ -1364,6 +1364,33 @@ gfc_add_component (gfc_symbol * sym, const char *name, gfc_component ** componen ...@@ -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 /* Recursive function to switch derived types of all symbol in a
namespace. */ namespace. */
...@@ -1408,14 +1435,31 @@ gfc_use_derived (gfc_symbol * sym) ...@@ -1408,14 +1435,31 @@ gfc_use_derived (gfc_symbol * sym)
gfc_symbol *s; gfc_symbol *s;
gfc_typespec *t; gfc_typespec *t;
gfc_symtree *st; gfc_symtree *st;
gfc_component *c;
int i; int i;
if (sym->components != NULL)
return sym; /* Already defined. */
if (sym->ns->parent == NULL) 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)) if (gfc_find_symbol (sym->name, sym->ns->parent, 1, &s))
{ {
gfc_error ("Symbol '%s' at %C is ambiguous", sym->name); gfc_error ("Symbol '%s' at %C is ambiguous", sym->name);
...@@ -1423,6 +1467,37 @@ gfc_use_derived (gfc_symbol * sym) ...@@ -1423,6 +1467,37 @@ gfc_use_derived (gfc_symbol * sym)
} }
if (s == NULL || s->attr.flavor != FL_DERIVED) 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; goto bad;
/* Get rid of symbol sym, translating all references to s. */ /* Get rid of symbol sym, translating all references to s. */
...@@ -2440,21 +2515,6 @@ free_sym_tree (gfc_symtree * sym_tree) ...@@ -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. */ /* Free the gfc_equiv_info's. */
static void static void
...@@ -2517,8 +2577,6 @@ gfc_free_namespace (gfc_namespace * ns) ...@@ -2517,8 +2577,6 @@ gfc_free_namespace (gfc_namespace * ns)
gfc_free_equiv (ns->equiv); gfc_free_equiv (ns->equiv);
gfc_free_equiv_lists (ns->equiv_lists); gfc_free_equiv_lists (ns->equiv_lists);
gfc_free_dt_list (ns->derived_types);
for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++) for (i = GFC_INTRINSIC_BEGIN; i != GFC_INTRINSIC_END; i++)
gfc_free_interface (ns->operator[i]); gfc_free_interface (ns->operator[i]);
......
...@@ -728,6 +728,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy) ...@@ -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 /* 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 qualified type. Reset sym->backend decl or this will just return the
old type. */ old type. */
DECL_ARTIFICIAL (sym->backend_decl) = 1;
sym->backend_decl = NULL_TREE; sym->backend_decl = NULL_TREE;
type = gfc_sym_type (sym); type = gfc_sym_type (sym);
packed = 2; packed = 2;
...@@ -884,7 +885,15 @@ gfc_get_symbol_decl (gfc_symbol * sym) ...@@ -884,7 +885,15 @@ gfc_get_symbol_decl (gfc_symbol * sym)
if (TREE_CODE (length) == VAR_DECL if (TREE_CODE (length) == VAR_DECL
&& DECL_CONTEXT (length) == NULL_TREE) && 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); gfc_defer_symbol_init (sym);
} }
} }
...@@ -892,8 +901,11 @@ gfc_get_symbol_decl (gfc_symbol * sym) ...@@ -892,8 +901,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
/* Use a copy of the descriptor for dummy arrays. */ /* Use a copy of the descriptor for dummy arrays. */
if (sym->attr.dimension && !TREE_USED (sym->backend_decl)) if (sym->attr.dimension && !TREE_USED (sym->backend_decl))
{ {
sym->backend_decl = decl = gfc_build_dummy_array_decl (sym, sym->backend_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; TREE_USED (sym->backend_decl) = 1;
...@@ -1284,6 +1296,7 @@ create_function_arglist (gfc_symbol * sym) ...@@ -1284,6 +1296,7 @@ create_function_arglist (gfc_symbol * sym)
DECL_ARG_TYPE (parm) = type; DECL_ARG_TYPE (parm) = type;
TREE_READONLY (parm) = 1; TREE_READONLY (parm) = 1;
gfc_finish_decl (parm, NULL_TREE); gfc_finish_decl (parm, NULL_TREE);
DECL_ARTIFICIAL (parm) = 1;
arglist = chainon (arglist, parm); arglist = chainon (arglist, parm);
typelist = TREE_CHAIN (typelist); typelist = TREE_CHAIN (typelist);
...@@ -1603,6 +1616,7 @@ build_entry_thunks (gfc_namespace * ns) ...@@ -1603,6 +1616,7 @@ build_entry_thunks (gfc_namespace * ns)
if (thunk_formal) if (thunk_formal)
{ {
/* Pass the argument. */ /* Pass the argument. */
DECL_ARTIFICIAL (thunk_formal->sym->backend_decl) = 1;
args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl, args = tree_cons (NULL_TREE, thunk_formal->sym->backend_decl,
args); args);
if (formal->sym->ts.type == BT_CHARACTER) if (formal->sym->ts.type == BT_CHARACTER)
...@@ -2743,6 +2757,112 @@ gfc_generate_contained_functions (gfc_namespace * parent) ...@@ -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 /* Generate decls for all local variables. We do this to ensure correct
handling of expressions which only appear in the specification of handling of expressions which only appear in the specification of
other functions. */ other functions. */
...@@ -2752,6 +2872,14 @@ generate_local_decl (gfc_symbol * sym) ...@@ -2752,6 +2872,14 @@ generate_local_decl (gfc_symbol * sym)
{ {
if (sym->attr.flavor == FL_VARIABLE) 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) if (sym->attr.referenced)
gfc_get_symbol_decl (sym); gfc_get_symbol_decl (sym);
else if (sym->attr.dummy && warn_unused_parameter) else if (sym->attr.dummy && warn_unused_parameter)
......
...@@ -2669,9 +2669,19 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr) ...@@ -2669,9 +2669,19 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr)
} }
else if (expr->ts.type == BT_DERIVED) else if (expr->ts.type == BT_DERIVED)
{ {
/* Nested derived type. */ if (expr->expr_type != EXPR_STRUCTURE)
tmp = gfc_trans_structure_assign (dest, expr); {
gfc_add_expr_to_block (&block, tmp); 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 else
{ {
......
...@@ -1411,59 +1411,15 @@ gfc_add_field_to_struct (tree *fieldlist, tree context, ...@@ -1411,59 +1411,15 @@ gfc_add_field_to_struct (tree *fieldlist, tree context,
} }
/* Copy the backend_decl and component backend_decls if /* Build a tree node for a derived type. */
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. */
static tree static tree
gfc_get_derived_type (gfc_symbol * derived) gfc_get_derived_type (gfc_symbol * derived)
{ {
tree typenode, field, field_type, fieldlist; tree typenode, field, field_type, fieldlist;
gfc_component *c; 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 /* derived->backend_decl != 0 means we saw it before, but its
components' backend_decl may have not been built. */ components' backend_decl may have not been built. */
...@@ -1477,29 +1433,6 @@ gfc_get_derived_type (gfc_symbol * derived) ...@@ -1477,29 +1433,6 @@ gfc_get_derived_type (gfc_symbol * derived)
} }
else 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. */ /* We see this derived type first time, so build the type node. */
typenode = make_node (RECORD_TYPE); typenode = make_node (RECORD_TYPE);
TYPE_NAME (typenode) = get_identifier (derived->name); TYPE_NAME (typenode) = get_identifier (derived->name);
...@@ -1578,12 +1511,6 @@ gfc_get_derived_type (gfc_symbol * derived) ...@@ -1578,12 +1511,6 @@ gfc_get_derived_type (gfc_symbol * derived)
derived->backend_decl = typenode; 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; return derived->backend_decl;
} }
......
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> 2006-08-19 Erik Edelmann <eedelman@gcc.gnu.org>
PR fortran/25217 PR fortran/25217
! { 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
! { 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
! { 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
! { 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
! { 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
! { 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
! { 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
! { 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
! { 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
! { 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
! { 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
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment