2006-12-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25818
* trans-array.c (gfc_trans_g77_array): If the variable is
optional or not always present, make the statement conditional
on presence of the argument.
* gfortran.h : Add symbol_attribute not_always_present.
* resolve.c (check_argument_lists): New function to check if
arguments are not present in all entries.
PR fortran/30084
* module.c (mio_component_ref): Move treatment of unique name
variables, during output, to fix_mio_expr.
(fix_mio_expr): New function that fixes defective expressions
before they are written to the module file.
(mio_expr): Call the new function.
(resolve_entries): Call check_argument_lists.
2006-12-22 Paul Thomas <pault@gcc.gnu.org>
PR fortran/25818
* gfortran.dg/entry_array_specs_2.f: New test.
PR fortran/30084
* gfortran.dg/nested_modules_6.f90: New test.
From-SVN: r120155
+2006-12-22 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/25818
+ * trans-array.c (gfc_trans_g77_array): If the variable is
+ optional or not always present, make the statement conditional
+ on presence of the argument.
+ * gfortran.h : Add symbol_attribute not_always_present.
+ * resolve.c (check_argument_lists): New function to check if
+ arguments are not present in all entries.
+
+ PR fortran/30084
+ * module.c (mio_component_ref): Move treatment of unique name
+ variables, during output, to fix_mio_expr.
+ (fix_mio_expr): New function that fixes defective expressions
+ before they are written to the module file.
+ (mio_expr): Call the new function.
+ (resolve_entries): Call check_argument_lists.
+
2006-12-21 Roger Sayle <roger@eyesopen.com>
* trans-array.c (gfc_trans_create_temp_array): When the size is known
/* Variable attributes. */
unsigned allocatable:1, dimension:1, external:1, intrinsic:1,
optional:1, pointer:1, save:1, target:1, value:1, volatile_:1,
- dummy:1, result:1, assign:1, threadprivate:1;
+ dummy:1, result:1, assign:1, threadprivate:1, not_always_present:1;
unsigned data:1, /* Symbol is named in a DATA statement. */
protected:1, /* Symbol has been marked as protected. */
{
pointer_info *p;
fixup_t *f;
- gfc_symtree * ns_st = NULL;
if (iomode == IO_OUTPUT)
- {
- /* If this is a symtree for a symbol that came from a contained module
- namespace, it has a unique name and we should look in the current
- namespace to see if the required, non-contained symbol is available
- yet. If so, the latter should be written. */
- if ((*stp)->n.sym && check_unique_name((*stp)->name))
- ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
- (*stp)->n.sym->name);
-
- /* On the other hand, if the existing symbol is the module name or the
- new symbol is a dummy argument, do not do the promotion. */
- if (ns_st && ns_st->n.sym
- && ns_st->n.sym->attr.flavor != FL_MODULE
- && !(*stp)->n.sym->attr.dummy)
- mio_symbol_ref (&ns_st->n.sym);
- else
- mio_symbol_ref (&(*stp)->n.sym);
- }
+ mio_symbol_ref (&(*stp)->n.sym);
else
{
require_atom (ATOM_INTEGER);
minit (NULL, -1)
};
+
+/* Remedy a couple of situations where the gfc_expr's can be defective. */
+
+static void
+fix_mio_expr (gfc_expr *e)
+{
+ gfc_symtree *ns_st = NULL;
+ const char *fname;
+
+ if (iomode != IO_OUTPUT)
+ return;
+
+ if (e->symtree)
+ {
+ /* If this is a symtree for a symbol that came from a contained module
+ namespace, it has a unique name and we should look in the current
+ namespace to see if the required, non-contained symbol is available
+ yet. If so, the latter should be written. */
+ if (e->symtree->n.sym && check_unique_name(e->symtree->name))
+ ns_st = gfc_find_symtree (gfc_current_ns->sym_root,
+ e->symtree->n.sym->name);
+
+ /* On the other hand, if the existing symbol is the module name or the
+ new symbol is a dummy argument, do not do the promotion. */
+ if (ns_st && ns_st->n.sym
+ && ns_st->n.sym->attr.flavor != FL_MODULE
+ && !e->symtree->n.sym->attr.dummy)
+ e->symtree = ns_st;
+ }
+ else if (e->expr_type == EXPR_FUNCTION && e->value.function.name)
+ {
+ /* In some circumstances, a function used in an initialization
+ expression, in one use associated module, can fail to be
+ coupled to its symtree when used in a specification
+ expression in another module. */
+ fname = e->value.function.esym ? e->value.function.esym->name :
+ e->value.function.isym->name;
+ e->symtree = gfc_find_symtree (gfc_current_ns->sym_root, fname);
+ }
+}
+
+
/* Read and write expressions. The form "()" is allowed to indicate a
NULL expression. */
mio_typespec (&e->ts);
mio_integer (&e->rank);
+ fix_mio_expr (e);
+
switch (e->expr_type)
{
case EXPR_OP:
}
+/* Flag the arguments that are not present in all entries. */
+
+static void
+check_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
+{
+ gfc_formal_arglist *f, *head;
+ head = new_args;
+
+ for (f = proc->formal; f; f = f->next)
+ {
+ if (f->sym == NULL)
+ continue;
+
+ for (new_args = head; new_args; new_args = new_args->next)
+ {
+ if (new_args->sym == f->sym)
+ break;
+ }
+
+ if (new_args)
+ continue;
+
+ f->sym->attr.not_always_present = 1;
+ }
+}
+
+
/* Resolve alternate entry points. If a symbol has multiple entry points we
create a new master symbol for the main routine, and turn the existing
symbol into an entry point. */
for (el = ns->entries; el; el = el->next)
merge_argument_lists (proc, el->sym->formal);
+ /* Check the master formal arguments for any that are not
+ present in all entry points. */
+ for (el = ns->entries; el; el = el->next)
+ check_argument_lists (proc, el->sym->formal);
+
/* Use the master function for the function body. */
ns->proc_name = proc;
locus loc;
tree offset;
tree tmp;
+ tree stmt;
stmtblock_t block;
gfc_get_backend_locus (&loc);
tmp = convert (TREE_TYPE (parm), GFC_DECL_SAVED_DESCRIPTOR (parm));
gfc_add_modify_expr (&block, parm, tmp);
}
- tmp = gfc_finish_block (&block);
+ stmt = gfc_finish_block (&block);
gfc_set_backend_locus (&loc);
gfc_start_block (&block);
+
/* Add the initialization code to the start of the function. */
- gfc_add_expr_to_block (&block, tmp);
+
+ if (sym->attr.optional || sym->attr.not_always_present)
+ {
+ tmp = gfc_conv_expr_present (sym);
+ stmt = build3_v (COND_EXPR, tmp, stmt, build_empty_stmt ());
+ }
+
+ gfc_add_expr_to_block (&block, stmt);
gfc_add_expr_to_block (&block, body);
return gfc_finish_block (&block);
+2006-12-22 Paul Thomas <pault@gcc.gnu.org>
+
+ PR fortran/25818
+ * gfortran.dg/entry_array_specs_2.f: New test.
+
+ PR fortran/30084
+ * gfortran.dg/nested_modules_6.f90: New test.
+
2006-12-22 Manuel Lopez-Ibanez <manu@gcc.gnu.org>
PR middle-end/7651
--- /dev/null
+! { dg-do run }
+! Tests the patch for PR30025, aka 25818, in which the initialization
+! code for the array a, was causing a segfault in runtime for a call
+! to x, since n is missing.
+!
+! COntributed by Elizabeth Yip <elizabeth.l.yip@boeing.com>
+ program test_entry
+ common // j
+ real a(10)
+ a(1) = 999.
+ call x
+ if (j .ne. 1) call abort ()
+ call y(a,10)
+ if (j .ne. 2) call abort ()
+ stop
+ end
+ subroutine x
+ common // j
+ real a(n)
+ j = 1
+ return
+ entry y(a,n)
+ call foo(a(1))
+ end
+ subroutine foo(a)
+ common // j
+ real a
+ j = 2
+ return
+ end
+
--- /dev/null
+! { dg-do compile }
+! Test the patch for PR30084 in which the reference to SIZE
+! in function diag caused a segfault in module.c.
+!
+! Contributed by Troban Trumsko <trumsko@yahoo.com>
+! and reduced by Steve Kargl <kargl@gcc.gnu.org>
+!
+module tao_random_numbers
+ integer, dimension(10) :: s_buffer
+ integer :: s_last = size (s_buffer)
+end module tao_random_numbers
+
+module linalg
+ contains
+ function diag (a) result (d)
+ real, dimension(:,:), intent(in) :: a
+ real, dimension(min(size(a,dim=1),size(a,dim=2))) :: d
+ integer :: i
+ do i = 1, min(size(a, dim = 1), size(a, dim = 2))
+ d(i) = a(i,i)
+ end do
+ end function diag
+end module linalg
+
+module vamp_rest
+ use tao_random_numbers
+ use linalg
+end module vamp_rest
+
+ use vamp_rest
+ real :: x(2, 2) = reshape ([1.,2.,3.,4.], [2,2]) ! { dg-warning "nonstandard" }
+ print *, s_last
+ print *, diag (x)
+end
+! { dg-final { cleanup-modules "tao_random_numbers linalg vamp_rest" } }
projects / thirdparty / gcc.git / commitdiff
