OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

re PR fortran/25818 ([4.1 only] Problem with handling optional and entry master arguments)

Browse Source 
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
This commit is contained in:
Paul Thomas 2006-12-22 20:49:00 +00:00
parent 2b0017242d
commit 54129a64cd
8 changed files with 181 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
gcc/fortran/ChangeLog
View File

@ -1,3 +1,21 @@
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

2
gcc/fortran/gfortran.h
View File

@ -480,7 +480,7 @@ typedef struct
/* 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. */

62
gcc/fortran/module.c
View File

@ -2194,27 +2194,9 @@ mio_symtree_ref (gfc_symtree ** stp)
{
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);
}
else
{
require_atom (ATOM_INTEGER);
@ -2554,6 +2536,48 @@ static const mstring intrinsics[] =
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. */
@ -2598,6 +2622,8 @@ mio_expr (gfc_expr ** ep)
mio_typespec (&e->ts);
mio_integer (&e->rank);
fix_mio_expr (e);
switch (e->expr_type)
{
case EXPR_OP:

32
gcc/fortran/resolve.c
View File

@ -342,6 +342,33 @@ merge_argument_lists (gfc_symbol *proc, gfc_formal_arglist *new_args)
}
/* 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. */
@ -541,6 +568,11 @@ resolve_entries (gfc_namespace * ns)
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;

13
gcc/fortran/trans-array.c
View File

@ -3767,6 +3767,7 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
locus loc;
tree offset;
tree tmp;
tree stmt;
stmtblock_t block;
gfc_get_backend_locus (&loc);
@ -3796,13 +3797,21 @@ gfc_trans_g77_array (gfc_symbol * sym, tree body)
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);

8
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,11 @@
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

31
gcc/testsuite/gfortran.dg/entry_array_specs_2.f Normal file
View File

@ -0,0 +1,31 @@
! { 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

35
gcc/testsuite/gfortran.dg/nested_modules_6.f90 Normal file
View File

@ -0,0 +1,35 @@
! { 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" } }