This is the mail archive of the
fortran@gcc.gnu.org
mailing list for the GNU Fortran project.
Re: whole file compilation
Dear All,
I have chickened out and put the patch behind a -fwhole-file. I think
that we should let it shake itself down before it become the default
and we require a -fno-whole-file.
You will note that with the option selected that the double
declaration business is fixed. My next step will be to check if this
allows same-file, external procedures to be inlined.
With best regards
Paul
Index: gcc/fortran/symbol.c
===================================================================
--- gcc/fortran/symbol.c (revision 144163)
+++ gcc/fortran/symbol.c (working copy)
@@ -93,6 +93,7 @@
gfc_namespace *gfc_current_ns;
+gfc_namespace *gfc_global_ns_list;
gfc_gsymbol *gfc_gsym_root = NULL;
@@ -2938,7 +2939,7 @@
/* Free the derived type list. */
-static void
+void
gfc_free_dt_list (void)
{
gfc_dt_list *dt, *n;
Index: gcc/fortran/decl.c
===================================================================
--- gcc/fortran/decl.c (revision 144163)
+++ gcc/fortran/decl.c (working copy)
@@ -4530,6 +4530,7 @@
s->type = type;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
return true;
}
return false;
Index: gcc/fortran/gfortran.h
===================================================================
--- gcc/fortran/gfortran.h (revision 144163)
+++ gcc/fortran/gfortran.h (working copy)
@@ -1305,10 +1305,14 @@
/* 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.
@@ -1327,6 +1331,7 @@
int defined, used;
locus where;
+ gfc_namespace *ns;
}
gfc_gsymbol;
@@ -2024,6 +2029,7 @@
int flag_init_character;
char flag_init_character_value;
int flag_align_commons;
+ int flag_whole_file;
int fpe;
@@ -2350,7 +2356,9 @@
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 *);
Index: gcc/fortran/lang.opt
===================================================================
--- gcc/fortran/lang.opt (revision 144163)
+++ gcc/fortran/lang.opt (working copy)
@@ -356,6 +356,10 @@
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
Index: gcc/fortran/invoke.texi
===================================================================
--- gcc/fortran/invoke.texi (revision 144163)
+++ gcc/fortran/invoke.texi (working copy)
@@ -164,7 +164,7 @@
@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
-fmax-stack-var-size=@var{n} @gol
-fpack-derived -frepack-arrays -fshort-enums -fexternal-blas @gol
@@ -1157,6 +1157,19 @@
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
Index: gcc/fortran/resolve.c
===================================================================
--- gcc/fortran/resolve.c (revision 144163)
+++ gcc/fortran/resolve.c (working copy)
@@ -1581,12 +1581,19 @@
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;
@@ -1596,6 +1603,32 @@
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;
@@ -2309,10 +2342,6 @@
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++;
@@ -2341,6 +2370,11 @@
/* 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
@@ -2930,10 +2964,6 @@
}
}
- /* 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))
@@ -2964,6 +2994,10 @@
/* 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)
{
@@ -10444,6 +10478,7 @@
resolve_codes (gfc_namespace *ns)
{
gfc_namespace *n;
+ bitmap_obstack old_obstack;
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);
@@ -10453,9 +10488,13 @@
/* 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;
}
@@ -10470,10 +10509,14 @@
{
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;
}
Index: gcc/fortran/trans-decl.c
===================================================================
--- gcc/fortran/trans-decl.c (revision 144163)
+++ gcc/fortran/trans-decl.c (working copy)
@@ -1221,6 +1221,7 @@
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 @@
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
Index: gcc/fortran/parse.c
===================================================================
--- gcc/fortran/parse.c (revision 144163)
+++ gcc/fortran/parse.c (working copy)
@@ -3717,6 +3717,7 @@
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
}
}
@@ -3739,6 +3740,7 @@
s->type = GSYM_PROGRAM;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
}
}
@@ -3752,6 +3754,7 @@
gfc_state_data top, s;
gfc_statement st;
locus prog_locus;
+ gfc_namespace *next;
gfc_start_source_files ();
@@ -3770,6 +3773,10 @@
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. */
@@ -3796,6 +3803,8 @@
accept_statement (st);
add_global_program ();
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_SUBROUTINE:
@@ -3803,6 +3812,8 @@
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:
@@ -3810,6 +3821,8 @@
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:
@@ -3836,9 +3849,12 @@
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);
@@ -3864,7 +3880,56 @@
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;
Index: gcc/fortran/options.c
===================================================================
--- gcc/fortran/options.c (revision 144163)
+++ gcc/fortran/options.c (working copy)
@@ -91,6 +91,7 @@
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;
@@ -623,6 +624,10 @@
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;
Index: gcc/testsuite/gfortran.dg/whole_file_1.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_1.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_1.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/whole_file_2.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_2.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_2.f90 (revision 0)
@@ -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
+
Index: gcc/testsuite/gfortran.dg/whole_file_3.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_3.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_3.f90 (revision 0)
@@ -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
Index: gcc/testsuite/gfortran.dg/whole_file_4.f90
===================================================================
--- gcc/testsuite/gfortran.dg/whole_file_4.f90 (revision 0)
+++ gcc/testsuite/gfortran.dg/whole_file_4.f90 (revision 0)
@@ -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