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
+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
s->type = type;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
return true;
}
return false;
/* 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.
int defined, used;
locus where;
+ gfc_namespace *ns;
}
gfc_gsymbol;
int flag_init_character;
char flag_init_character_value;
int flag_align_commons;
+ int flag_whole_file;
int fpe;
int rtcheck;
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 *);
@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
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
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
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;
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;
s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
}
}
s->type = GSYM_PROGRAM;
s->where = gfc_current_locus;
s->defined = 1;
+ s->ns = gfc_current_ns;
}
}
gfc_state_data top, s;
gfc_statement st;
locus prog_locus;
+ gfc_namespace *next;
gfc_start_source_files ();
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. */
accept_statement (st);
add_global_program ();
parse_progunit (ST_NONE);
+ if (gfc_option.flag_whole_file)
+ goto prog_units;
break;
case ST_SUBROUTINE:
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:
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:
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);
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;
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;
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;
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++;
/* 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
}
}
- /* 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))
/* 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)
{
resolve_codes (gfc_namespace *ns)
{
gfc_namespace *n;
+ bitmap_obstack old_obstack;
for (n = ns->contained; n; n = n->sibling)
resolve_codes (n);
/* 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;
}
{
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;
}
gfc_namespace *gfc_current_ns;
+gfc_namespace *gfc_global_ns_list;
gfc_gsymbol *gfc_gsym_root = NULL;
/* Free the derived type list. */
-static void
+void
gfc_free_dt_list (void)
{
gfc_dt_list *dt, *n;
{
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,
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;
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
+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.
--- /dev/null
+! { 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
--- /dev/null
+! { 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
+
--- /dev/null
+! { 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
--- /dev/null
+! { 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
git://gcc.gnu.org / gcc.git / commitdiff