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

re PR fortran/22571 (Reject derived types for dummy arguments declared in the subroutine unless they are SEQUENCE)

Browse Source 
2009-03-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/22571
	PR fortran/26227
	PR fortran/24886
	* symbol.c : Add gfc_global_ns_list.
	* decl.c (add_global_entry): Set the namespace ('ns') field.
	* gfortran.h : Add the resolved field to gfc_namespace. Add the
	namespace ('ns') field to gfc_gsymbol.  Add flag_whole_file to
	gfc_option_t.  Add the prototype for gfc_free_dt_list.
	* lang.opt : Add the whole-file option.
	* invoke.texi : Document the whole-file option.
	* resolve.c (resolve_global_procedure): If the fwhole-file
	option is set, reorder gsymbols to ensure that translation is
	in the right order.  Resolve the gsymbol's namespace if that
	has not occurred and then check interfaces.
	(resolve_function): Move call to resolve_global_procedure.
	(resolve_call): The same.
	(resolve_codes): Store the current labels_obstack.
	(gfc_resolve) : Return if the namespace is already resolved.
	trans-decl.c (gfc_get_extern_function_decl): If the whole_file
	option is selected, use the backend_decl of a gsymbol, if it is
	available.
	parse.c (add_global_procedure, add_global_program): If the flag
	whole-file is set, add the namespace to the gsymbol.
	(gfc_parse_file): On -fwhole-file, put procedure namespaces on
	the global namespace list.  Rearrange to do resolution of all
	the procedures in a file, followed by their translation.
	* options.c (gfc_init_options): Add -fwhole-file.
	(gfc_handle_option): The same.

2009-03-30  Paul Thomas  <pault@gcc.gnu.org>

	PR fortran/22571
	* gfortran.dg/whole_file_1.f90: New test.
	PR fortran/26227
	* gfortran.dg/whole_file_2.f90: New test.
	* gfortran.dg/whole_file_3.f90: New test.
	PR fortran/24886
	* gfortran.dg/whole_file_4.f90: New test.

From-SVN: r145314
This commit is contained in:
Paul Thomas 2009-03-30 19:35:14 +00:00
parent 5b0c0b2c05
commit 71a7778cd9
16 changed files with 357 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
gcc/fortran/ChangeLog
View File

@ -1,3 +1,34 @@
2009-03-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/22571
PR fortran/26227
PR fortran/24886
* symbol.c : Add gfc_global_ns_list.
* decl.c (add_global_entry): Set the namespace ('ns') field.
* gfortran.h : Add the resolved field to gfc_namespace. Add the
namespace ('ns') field to gfc_gsymbol. Add flag_whole_file to
gfc_option_t. Add the prototype for gfc_free_dt_list.
* lang.opt : Add the whole-file option.
* invoke.texi : Document the whole-file option.
* resolve.c (resolve_global_procedure): If the fwhole-file
option is set, reorder gsymbols to ensure that translation is
in the right order. Resolve the gsymbol's namespace if that
has not occurred and then check interfaces.
(resolve_function): Move call to resolve_global_procedure.
(resolve_call): The same.
(resolve_codes): Store the current labels_obstack.
(gfc_resolve) : Return if the namespace is already resolved.
trans-decl.c (gfc_get_extern_function_decl): If the whole_file
option is selected, use the backend_decl of a gsymbol, if it is
available.
parse.c (add_global_procedure, add_global_program): If the flag
whole-file is set, add the namespace to the gsymbol.
(gfc_parse_file): On -fwhole-file, put procedure namespaces on
the global namespace list. Rearrange to do resolution of all
the procedures in a file, followed by their translation.
* options.c (gfc_init_options): Add -fwhole-file.
(gfc_handle_option): The same.
2009-03-30 Ulrich Weigand <Ulrich.Weigand@de.ibm.com>
* f95-lang.c (gfc_init_builtin_functions): Define BUILT_IN_HUGE_VAL

1
gcc/fortran/decl.c
View File

@ -4530,6 +4530,7 @@ add_global_entry (const char *name, int sub)
s->type = type;
s->where = gfc_current_locus;
s->defined = 1;
s->ns = gfc_current_ns;
return true;
}
return false;

8
gcc/fortran/gfortran.h
View File

@ -1306,10 +1306,14 @@ typedef struct gfc_namespace
/* Set to 1 if namespace is an interface body with "IMPORT" used. */
int has_import_set;
/* Set to 1 if resolved has been called for this namespace. */
int resolved;
}
gfc_namespace;
extern gfc_namespace *gfc_current_ns;
extern gfc_namespace *gfc_global_ns_list;
/* Global symbols are symbols of global scope. Currently we only use
this to detect collisions already when parsing.
@ -1328,6 +1332,7 @@ typedef struct gfc_gsymbol
int defined, used;
locus where;
gfc_namespace *ns;
}
gfc_gsymbol;
@ -2027,6 +2032,7 @@ typedef struct
int flag_init_character;
char flag_init_character_value;
int flag_align_commons;
int flag_whole_file;
int fpe;
int rtcheck;
@ -2354,6 +2360,8 @@ void gfc_traverse_user_op (gfc_namespace *, void (*)(gfc_user_op *));
void gfc_save_all (gfc_namespace *);
void gfc_symbol_state (void);
void gfc_free_dt_list (void);
gfc_gsymbol *gfc_get_gsymbol (const char *);
gfc_gsymbol *gfc_find_gsymbol (gfc_gsymbol *, const char *);

15
gcc/fortran/invoke.texi
View File

@ -164,7 +164,7 @@ and warnings}.
@item Code Generation Options
@xref{Code Gen Options,,Options for code generation conventions}.
@gccoptlist{-fno-automatic -ff2c -fno-underscoring @gol
-fsecond-underscore @gol
-fwhole-file -fsecond-underscore @gol
-fbounds-check -fcheck-array-temporaries -fmax-array-constructor =@var{n} @gol
-fcheck=@var{<all|bounds|array-temps>}
-fmax-stack-var-size=@var{n} @gol
@ -1158,6 +1158,19 @@ in the source, even if the names as seen by the linker are mangled to
prevent accidental linking between procedures with incompatible
interfaces.
@item -fwhole-file
@opindex @code{fwhole-file}
By default, GNU Fortran parses, resolves and translates each procedure
in a file separately. Using this option modifies this such that the
whole file is parsed and placed in a single front-end tree. During
resolution, in addition to all the usual checks and fixups, references
to external procedures that are in the same file effect resolution of
that procedure, if not already done, and a check of the interfaces. The
dependences are resolved by changing the order in which the file is
translated into the backend tree. Thus, a procedure that is referenced
is translated before the reference and the duplication of backend tree
declarations eliminated.
@item -fsecond-underscore
@opindex @code{fsecond-underscore}
@cindex underscore

4
gcc/fortran/lang.opt
View File

@ -360,6 +360,10 @@ funderscoring
Fortran
Append underscores to externally visible names
fwhole-file
Fortran
Compile all program units at once and check all interfaces
fworking-directory
Fortran
; Documented in C

5
gcc/fortran/options.c
View File

@ -93,6 +93,7 @@ gfc_init_options (unsigned int argc, const char **argv)
gfc_option.flag_default_real = 0;
gfc_option.flag_dollar_ok = 0;
gfc_option.flag_underscoring = 1;
gfc_option.flag_whole_file = 0;
gfc_option.flag_f2c = 0;
gfc_option.flag_second_underscore = -1;
gfc_option.flag_implicit_none = 0;
@ -673,6 +674,10 @@ gfc_handle_option (size_t scode, const char *arg, int value)
gfc_option.flag_underscoring = value;
break;
case OPT_fwhole_file:
gfc_option.flag_whole_file = 1;
break;
case OPT_fsecond_underscore:
gfc_option.flag_second_underscore = value;
break;

67
gcc/fortran/parse.c
View File

@ -3715,6 +3715,7 @@ add_global_procedure (int sub)
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
s->defined = 1;
s->ns = gfc_current_ns;
}
}
@ -3737,6 +3738,7 @@ add_global_program (void)
s->type = GSYM_PROGRAM;
s->where = gfc_current_locus;
s->defined = 1;
s->ns = gfc_current_ns;
}
}
@ -3750,6 +3752,7 @@ gfc_parse_file (void)
gfc_state_data top, s;
gfc_statement st;
locus prog_locus;
gfc_namespace *next;
gfc_start_source_files ();
@ -3768,6 +3771,10 @@ gfc_parse_file (void)
if (setjmp (eof_buf))
return FAILURE; /* Come here on unexpected EOF */
/* Prepare the global namespace that will contain the
program units. */
gfc_global_ns_list = next = NULL;
seen_program = 0;
/* Exit early for empty files. */
@ -3794,6 +3801,8 @@ loop:
accept_statement (st);
add_global_program ();
parse_progunit (ST_NONE);
if (gfc_option.flag_whole_file)
goto prog_units;
break;
case ST_SUBROUTINE:
@ -3801,6 +3810,8 @@ loop:
push_state (&s, COMP_SUBROUTINE, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
if (gfc_option.flag_whole_file)
goto prog_units;
break;
case ST_FUNCTION:
@ -3808,6 +3819,8 @@ loop:
push_state (&s, COMP_FUNCTION, gfc_new_block);
accept_statement (st);
parse_progunit (ST_NONE);
if (gfc_option.flag_whole_file)
goto prog_units;
break;
case ST_BLOCK_DATA:
@ -3834,9 +3847,12 @@ loop:
push_state (&s, COMP_PROGRAM, gfc_new_block);
main_program_symbol (gfc_current_ns, "MAIN__");
parse_progunit (st);
if (gfc_option.flag_whole_file)
goto prog_units;
break;
}
/* Handle the non-program units. */
gfc_current_ns->code = s.head;
gfc_resolve (gfc_current_ns);
@ -3862,7 +3878,56 @@ loop:
gfc_done_2 ();
goto loop;
done:
prog_units:
/* The main program and non-contained procedures are put
in the global namespace list, so that they can be processed
later and all their interfaces resolved. */
gfc_current_ns->code = s.head;
if (next)
next->sibling = gfc_current_ns;
else
gfc_global_ns_list = gfc_current_ns;
next = gfc_current_ns;
pop_state ();
goto loop;
done:
if (!gfc_option.flag_whole_file)
goto termination;
/* Do the resolution. */
gfc_current_ns = gfc_global_ns_list;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
gfc_current_locus = gfc_current_ns->proc_name->declared_at;
gfc_resolve (gfc_current_ns);
}
/* Do the parse tree dump. */
gfc_current_ns = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
gfc_dump_parse_tree (gfc_current_ns, stdout);
fputs ("-----------------------------------------\n\n", stdout);
}
gfc_current_ns = gfc_global_ns_list;
gfc_get_errors (NULL, &errors);
/* Do the translation. This could be in a different order to
resolution if there are forward references in the file. */
for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
{
gfc_current_locus = gfc_current_ns->proc_name->declared_at;
gfc_generate_code (gfc_current_ns);
}
termination:
gfc_free_dt_list ();
gfc_end_source_files ();
return SUCCESS;

63
gcc/fortran/resolve.c
View File

@ -1582,12 +1582,19 @@ find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual)
reference being resolved must correspond to the type of gsymbol.
Otherwise, the new symbol is equipped with the attributes of the
reference. The corresponding code that is called in creating
global entities is parse.c. */
global entities is parse.c.
In addition, for all but -std=legacy, the gsymbols are used to
check the interfaces of external procedures from the same file.
The namespace of the gsymbol is resolved and then, once this is
done the interface is checked. */
static void
resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
resolve_global_procedure (gfc_symbol *sym, locus *where,
gfc_actual_arglist **actual, int sub)
{
gfc_gsymbol * gsym;
gfc_namespace *ns;
unsigned int type;
type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
@ -1597,6 +1604,32 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, int sub)
if ((gsym->type != GSYM_UNKNOWN && gsym->type != type))
gfc_global_used (gsym, where);
if (gfc_option.flag_whole_file
&& gsym->type != GSYM_UNKNOWN
&& gsym->ns
&& gsym->ns->proc_name
&& gsym->ns->proc_name->formal)
{
/* Make sure that translation for the gsymbol occurs before
the procedure currently being resolved. */
ns = gsym->ns->resolved ? NULL : gfc_global_ns_list;
for (; ns && ns != gsym->ns; ns = ns->sibling)
{
if (ns->sibling == gsym->ns)
{
ns->sibling = gsym->ns->sibling;
gsym->ns->sibling = gfc_global_ns_list;
gfc_global_ns_list = gsym->ns;
break;
}
}
if (!gsym->ns->resolved)
gfc_resolve (gsym->ns);
gfc_procedure_use (gsym->ns->proc_name, actual, where);
}
if (gsym->type == GSYM_UNKNOWN)
{
gsym->type = type;
@ -2310,10 +2343,6 @@ resolve_function (gfc_expr *expr)
return FAILURE;
}
/* If the procedure is external, check for usage. */
if (sym && is_external_proc (sym))
resolve_global_procedure (sym, &expr->where, 0);
/* Switch off assumed size checking and do this again for certain kinds
of procedure, once the procedure itself is resolved. */
need_full_assumed_size++;
@ -2342,6 +2371,11 @@ resolve_function (gfc_expr *expr)
/* Resume assumed_size checking. */
need_full_assumed_size--;
/* If the procedure is external, check for usage. */
if (sym && is_external_proc (sym))
resolve_global_procedure (sym, &expr->where,
&expr->value.function.actual, 0);
if (sym && sym->ts.type == BT_CHARACTER
&& sym->ts.cl
&& sym->ts.cl->length == NULL
@ -2931,10 +2965,6 @@ resolve_call (gfc_code *c)
}
}
/* If external, check for usage. */
if (csym && is_external_proc (csym))
resolve_global_procedure (csym, &c->loc, 1);
/* Subroutines without the RECURSIVE attribution are not allowed to
* call themselves. */
if (csym && is_illegal_recursion (csym, gfc_current_ns))
@ -2965,6 +2995,10 @@ resolve_call (gfc_code *c)
/* Resume assumed_size checking. */
need_full_assumed_size--;
/* If external, check for usage. */
if (csym && is_external_proc (csym))
resolve_global_procedure (csym, &c->loc, &c->ext.actual, 1);
t = SUCCESS;
if (c->resolved_sym == NULL)
{
@ -10559,6 +10593,7 @@ static void
resolve_codes (gfc_namespace *ns)
{
gfc_namespace *n;
bitmap_obstack old_obstack;
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);
@ -10568,9 +10603,13 @@ resolve_codes (gfc_namespace *ns)
/* Set to an out of range value. */
current_entry_id = -1;
old_obstack = labels_obstack;
bitmap_obstack_initialize (&labels_obstack);
resolve_code (ns->code, ns);
bitmap_obstack_release (&labels_obstack);
labels_obstack = old_obstack;
}
@ -10585,10 +10624,14 @@ gfc_resolve (gfc_namespace *ns)
{
gfc_namespace *old_ns;
if (ns->resolved)
return;
old_ns = gfc_current_ns;
resolve_types (ns);
resolve_codes (ns);
gfc_current_ns = old_ns;
ns->resolved = 1;
}

3
gcc/fortran/symbol.c
View File

@ -93,6 +93,7 @@ static int next_dummy_order = 1;
gfc_namespace *gfc_current_ns;
gfc_namespace *gfc_global_ns_list;
gfc_gsymbol *gfc_gsym_root = NULL;
@ -2938,7 +2939,7 @@ free_sym_tree (gfc_symtree *sym_tree)
/* Free the derived type list. */
static void
void
gfc_free_dt_list (void)
{
gfc_dt_list *dt, *n;

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

@ -4741,6 +4741,8 @@ get_array_charlen (gfc_expr *expr, gfc_se *se)
{
get_array_charlen (expr->value.op.op2, se);
gcc_assert (expr->value.op.op == INTRINSIC_CONCAT);
/* Add the string lengths and assign them to the expression
string length backend declaration. */
gfc_add_modify (&se->pre, expr->ts.cl->backend_decl,

36
gcc/fortran/trans-decl.c
View File

@ -1221,6 +1221,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
char s[GFC_MAX_SYMBOL_LEN + 23]; /* "_gfortran_f2c_specific" and '\0'. */
tree name;
tree mangled_name;
gfc_gsymbol *gsym;
if (sym->backend_decl)
return sym->backend_decl;
@ -1233,6 +1234,41 @@ gfc_get_extern_function_decl (gfc_symbol * sym)
if (sym->attr.proc_pointer)
return get_proc_pointer_decl (sym);
/* See if this is an external procedure from the same file. If so,
return the backend_decl. */
gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name);
if (gfc_option.flag_whole_file
&& !sym->backend_decl
&& gsym && gsym->ns
&& ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION))
&& gsym->ns->proc_name->backend_decl)
{
/* If the namespace has entries, the proc_name is the
entry master. Find the entry and use its backend_decl.
otherwise, use the proc_name backend_decl. */
if (gsym->ns->entries)
{
gfc_entry_list *entry = gsym->ns->entries;
for (; entry; entry = entry->next)
{
if (strcmp (gsym->name, entry->sym->name) == 0)
{
sym->backend_decl = entry->sym->backend_decl;
break;
}
}
}
else
{
sym->backend_decl = gsym->ns->proc_name->backend_decl;
}
if (sym->backend_decl)
return sym->backend_decl;
}
if (sym->attr.intrinsic)
{
/* Call the resolution function to get the actual name. This is

10
gcc/testsuite/ChangeLog
View File

@ -1,3 +1,13 @@
2009-03-30 Paul Thomas <pault@gcc.gnu.org>
PR fortran/22571
* gfortran.dg/whole_file_1.f90: New test.
PR fortran/26227
* gfortran.dg/whole_file_2.f90: New test.
* gfortran.dg/whole_file_3.f90: New test.
PR fortran/24886
* gfortran.dg/whole_file_4.f90: New test.
2009-03-30 Jakub Jelinek <jakub@redhat.com>
* gfortran.dg/bind_c_usage_19.f90: New test.

60
gcc/testsuite/gfortran.dg/whole_file_1.f90 Normal file
View File

@ -0,0 +1,60 @@
! { dg-do compile }
! { dg-options "-fwhole-file" }
! Tests the fix for PR22571 in which the derived types in a, b
! c and d were not detected to be different. In e and f, they
! are the same because they are sequence types.
!
! Contributed by Joost VandeVondele <jv244@cam.ac.uk>
!
subroutine a(p)
type t
integer :: t1
end type
type(t) :: p
p%t1 = 42
end subroutine
subroutine b
type u
integer :: u1
end type
type (u) :: q
call a(q) ! { dg-error "Type mismatch" }
print *, q%u1
end subroutine
subroutine c(p)
type u
integer :: u1
end type
type(u) :: p
p%u1 = 42
end subroutine
subroutine d
type u
integer :: u1
end type
type (u) :: q
call c(q) ! { dg-error "Type mismatch" }
print *, q%u1
end subroutine
subroutine e(p)
type u
sequence
integer :: u1
end type
type(u) :: p
p%u1 = 42
end subroutine
subroutine f
type u
sequence
integer :: u1
end type
type (u) :: q
call e(q) ! This is OK because the types are sequence.
print *, q%u1
end subroutine

25
gcc/testsuite/gfortran.dg/whole_file_2.f90 Normal file
View File

@ -0,0 +1,25 @@
! { dg-do compile }
! { dg-options "-fwhole-file" }
! Tests the fix for PR26227 in which the interface mismatches
! below were not detected.
!
! Contributed by Andrew Pinski <pinskia@gcc.gnu.org>
!
function a(b)
REAL ::b
b = 2.0
a = 1.0
end function
program gg
real :: h
character (5) :: chr = 'hello'
h = a(); ! { dg-error "Missing actual argument" }
call test ([chr]) ! { dg-error "Rank mismatch" }
end program gg
subroutine test (a)
character (5) :: a
if (a .ne. 'hello') call abort
end subroutine test

21
gcc/testsuite/gfortran.dg/whole_file_3.f90 Normal file
View File

@ -0,0 +1,21 @@
! { dg-do compile }
! { dg-options "-fwhole-file" }
! Tests the fix for PR26227 in which the interface mismatches
! below were not detected.
!
! Contributed by Andrew Pinski <pinskia@gcc.gnu.org>
!
SUBROUTINE PHLOAD (READER,*)
IMPLICIT NONE
EXTERNAL READER
CALL READER (*1)
1 RETURN 1
END SUBROUTINE
program test
EXTERNAL R
call PHLOAD (R, 1) ! { dg-error "Missing alternate return spec" }
CALL PHLOAD (R, 2) ! { dg-error "Missing alternate return spec" }
CALL PHLOAD (R, *999) ! This one is OK
999 continue
END program test

19
gcc/testsuite/gfortran.dg/whole_file_4.f90 Normal file
View File

@ -0,0 +1,19 @@
! { dg-do compile }
! { dg-options "-fwhole-file -std=legacy" }
! Tests the fix for PR24886 in which the mismatch between the
! character lengths of the actual and formal arguments of
! 'foo' was not detected.
!
! Contributed by Uttam Pawar <uttamp@us.ibm.com>
!
subroutine foo(y)
character(len=20) :: y
y = 'hello world'
end
program test
character(len=10) :: x
call foo(x) ! { dg-warning "actual argument shorter" }
write(*,*) 'X=',x
pause
end