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
+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
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)
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];
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]);
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)
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);
}
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]);
}
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? */
/* 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;
}
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;
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)
&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. */
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;
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)
}
}
- /* 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;
}
}
+/* 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. */
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;
}
-/* 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
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]);
/* 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;
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);
}
}
/* 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;
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);
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)
}
+/* 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. */
{
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)
}
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
{
}
-/* 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. */
}
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);
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;
}
+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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
projects / gcc.git / commitdiff