diff options
| -rw-r--r-- | gcc/fortran/ChangeLog | 48 | ||||
| -rw-r--r-- | gcc/fortran/error.c | 39 | ||||
| -rw-r--r-- | gcc/fortran/gfortran.h | 6 | ||||
| -rw-r--r-- | gcc/fortran/options.c | 3 | ||||
| -rw-r--r-- | gcc/fortran/parse.c | 113 | ||||
| -rw-r--r-- | gcc/fortran/resolve.c | 85 | ||||
| -rw-r--r-- | gcc/fortran/trans-decl.c | 47 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 18 | ||||
| -rw-r--r-- | gcc/fortran/trans-types.c | 70 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 12 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_10.f90 | 32 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_11.f90 | 37 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_12.f90 | 33 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_13.f90 | 28 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_14.f90 | 28 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_7.f90 | 34 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_8.f90 | 36 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/whole_file_9.f90 | 46 |
18 files changed, 685 insertions, 30 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index f89a8af..d812f9d 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,51 @@ +2009-08-01 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/40011 + * error.c : Add static flag 'warnings_not_errors'. + (gfc_error): If 'warnings_not_errors' is set, branch to code + from gfc_warning. + (gfc_clear_error): Reset 'warnings_not_errors'. + (gfc_errors_to_warnings): New function. + * options.c (gfc_post_options): If pedantic and flag_whole_file + change the latter to a value of 2. + * parse.c (parse_module): Add module namespace to gsymbol. + (resolve_all_program_units): New function. + (clean_up_modules): New function. + (translate_all_program_units): New function. + (gfc_parse_file): If whole_file, do not clean up module right + away and add derived types to namespace derived types. In + addition, call the three new functions above. + * resolve.c (not_in_recursive): New function. + (not_entry_self_reference): New function. + (resolve_global_procedure): Symbol must not be IFSRC_UNKNOWN, + procedure must not be in the course of being resolved and + must return false for the two new functions. Pack away the + current derived type list before calling gfc_resolve for the + gsymbol namespace. It is unconditionally an error if the ranks + of the reference and ther procedure do not match. Convert + errors to warnings during call to gfc_procedure_use if not + pedantic or legacy. + (gfc_resolve): Set namespace resolved flag to -1 during + resolution and store current cs_base. + * trans-decl.c (gfc_get_symbol_decl): If whole_file compilation + substitute a use associated variable, if it is available in a + gsymbolnamespace. + (gfc_get_extern_function_decl): If the procedure is use assoc, + do not attempt to find it in a gsymbol because it could be an + interface. If the symbol exists in a module namespace, return + its backend_decl. + * trans-expr.c (gfc_trans_scalar_assign): If a derived type + assignment, set the rhs TYPE_MAIN_VARIANT to that of the rhs. + * trans-types.c (copy_dt_decls_ifequal): Add 'from_gsym' as a + boolean argument. Copy component backend_decls directly if the + components are derived types and from_gsym is true. + (gfc_get_derived_type): If whole_file copy the derived type from + the module if it is use associated, otherwise, if can be found + in another gsymbol namespace, use the existing derived type as + the TYPE_CANONICAL and build normally. + * gfortran.h : Add derived_types and resolved fields to + gfc_namespace. Include prototype for gfc_errors_to_warnings. + 2009-07-29 Tobias Burnus <burnus@net-b.de> PR fortran/40898 diff --git a/gcc/fortran/error.c b/gcc/fortran/error.c index 7cb23dd..9d5453e 100644 --- a/gcc/fortran/error.c +++ b/gcc/fortran/error.c @@ -32,6 +32,8 @@ along with GCC; see the file COPYING3. If not see static int suppress_errors = 0; +static int warnings_not_errors = 0; + static int terminal_width, buffer_flag, errors, warnings; static gfc_error_buf error_buffer, warning_buffer, *cur_error_buffer; @@ -863,6 +865,9 @@ gfc_error (const char *nocmsgid, ...) { va_list argp; + if (warnings_not_errors) + goto warning; + if (suppress_errors) return; @@ -878,6 +883,30 @@ gfc_error (const char *nocmsgid, ...) if (buffer_flag == 0) gfc_increment_error_count(); + + return; + +warning: + + if (inhibit_warnings) + return; + + warning_buffer.flag = 1; + warning_buffer.index = 0; + cur_error_buffer = &warning_buffer; + + va_start (argp, nocmsgid); + error_print (_("Warning:"), _(nocmsgid), argp); + va_end (argp); + + error_char ('\0'); + + if (buffer_flag == 0) + { + warnings++; + if (warnings_are_errors) + gfc_increment_error_count(); + } } @@ -955,6 +984,7 @@ void gfc_clear_error (void) { error_buffer.flag = 0; + warnings_not_errors = 0; } @@ -1042,3 +1072,12 @@ gfc_get_errors (int *w, int *e) if (e != NULL) *e = errors; } + + +/* Switch errors into warnings. */ + +void +gfc_errors_to_warnings (int f) +{ + warnings_not_errors = (f == 1) ? 1 : 0; +} diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h index 7792cfa..da3d5f0 100644 --- a/gcc/fortran/gfortran.h +++ b/gcc/fortran/gfortran.h @@ -1329,6 +1329,8 @@ typedef struct gfc_namespace gfc_charlen *cl_list, *old_cl_list; + gfc_dt_list *derived_types; + int save_all, seen_save, seen_implicit_none; /* Normally we don't need to refcount namespaces. However when we read @@ -1350,6 +1352,9 @@ typedef struct gfc_namespace /* Set to 1 if resolved has been called for this namespace. */ int resolved; + + /* Set to 1 if code has been generated for this namespace. */ + int translated; } gfc_namespace; @@ -2288,6 +2293,7 @@ void gfc_pop_error (gfc_error_buf *); void gfc_free_error (gfc_error_buf *); void gfc_get_errors (int *, int *); +void gfc_errors_to_warnings (int); /* arith.c */ void gfc_arith_init_1 (void); diff --git a/gcc/fortran/options.c b/gcc/fortran/options.c index ff0a809..3e20f8e 100644 --- a/gcc/fortran/options.c +++ b/gcc/fortran/options.c @@ -371,6 +371,9 @@ gfc_post_options (const char **pfilename) gfc_option.warn_tabs = 0; } + if (pedantic && gfc_option.flag_whole_file) + gfc_option.flag_whole_file = 2; + gfc_cpp_post_options (); /* FIXME: return gfc_cpp_preprocess_only (); diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index da16c2b..e4463bd 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -3760,6 +3760,8 @@ loop: st = next_statement (); goto loop; } + + s->ns = gfc_current_ns; } @@ -3809,6 +3811,76 @@ add_global_program (void) } +/* Resolve all the program units when whole file scope option + is active. */ +static void +resolve_all_program_units (gfc_namespace *gfc_global_ns_list) +{ + gfc_free_dt_list (); + 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); + gfc_current_ns->derived_types = gfc_derived_types; + gfc_derived_types = NULL; + } +} + + +static void +clean_up_modules (gfc_gsymbol *gsym) +{ + if (gsym == NULL) + return; + + clean_up_modules (gsym->left); + clean_up_modules (gsym->right); + + if (gsym->type != GSYM_MODULE || !gsym->ns) + return; + + gfc_current_ns = gsym->ns; + gfc_derived_types = gfc_current_ns->derived_types; + gfc_done_2 (); + gsym->ns = NULL; + return; +} + + +/* Translate all the program units when whole file scope option + is active. This could be in a different order to resolution if + there are forward references in the file. */ +static void +translate_all_program_units (gfc_namespace *gfc_global_ns_list) +{ + int errors; + + gfc_current_ns = gfc_global_ns_list; + gfc_get_errors (NULL, &errors); + + for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) + { + gfc_current_locus = gfc_current_ns->proc_name->declared_at; + gfc_derived_types = gfc_current_ns->derived_types; + gfc_generate_code (gfc_current_ns); + gfc_current_ns->translated = 1; + } + + /* Clean up all the namespaces after translation. */ + gfc_current_ns = gfc_global_ns_list; + for (;gfc_current_ns;) + { + gfc_namespace *ns = gfc_current_ns->sibling; + gfc_derived_types = gfc_current_ns->derived_types; + gfc_done_2 (); + gfc_current_ns = ns; + } + + clean_up_modules (gfc_gsym_root); +} + + /* Top level parser. */ gfc_try @@ -3933,15 +4005,24 @@ loop: gfc_dump_module (s.sym->name, errors_before == errors); if (errors == 0) gfc_generate_module_code (gfc_current_ns); + pop_state (); + if (!gfc_option.flag_whole_file) + gfc_done_2 (); + else + { + gfc_current_ns->derived_types = gfc_derived_types; + gfc_derived_types = NULL; + gfc_current_ns = NULL; + } } else { if (errors == 0) gfc_generate_code (gfc_current_ns); + pop_state (); + gfc_done_2 (); } - pop_state (); - gfc_done_2 (); goto loop; prog_units: @@ -3964,35 +4045,23 @@ prog_units: 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 resolution. */ + resolve_all_program_units (gfc_global_ns_list); /* Do the parse tree dump. */ - gfc_current_ns = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL; + 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); + 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); - } + /* Do the translation. */ + translate_all_program_units (gfc_global_ns_list); termination: - gfc_free_dt_list (); gfc_end_source_files (); return SUCCESS; diff --git a/gcc/fortran/resolve.c b/gcc/fortran/resolve.c index 053ec83..6202a2d 100644 --- a/gcc/fortran/resolve.c +++ b/gcc/fortran/resolve.c @@ -1652,6 +1652,47 @@ find_noncopying_intrinsics (gfc_symbol *fnsym, gfc_actual_arglist *actual) The namespace of the gsymbol is resolved and then, once this is done the interface is checked. */ + +static bool +not_in_recursive (gfc_symbol *sym, gfc_namespace *gsym_ns) +{ + if (!gsym_ns->proc_name->attr.recursive) + return true; + + if (sym->ns == gsym_ns) + return false; + + if (sym->ns->parent && sym->ns->parent == gsym_ns) + return false; + + return true; +} + +static bool +not_entry_self_reference (gfc_symbol *sym, gfc_namespace *gsym_ns) +{ + if (gsym_ns->entries) + { + gfc_entry_list *entry = gsym_ns->entries; + + for (; entry; entry = entry->next) + { + if (strcmp (sym->name, entry->sym->name) == 0) + { + if (strcmp (gsym_ns->proc_name->name, + sym->ns->proc_name->name) == 0) + return false; + + if (sym->ns->parent + && strcmp (gsym_ns->proc_name->name, + sym->ns->parent->proc_name->name) == 0) + return false; + } + } + } + return true; +} + static void resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_actual_arglist **actual, int sub) @@ -1668,9 +1709,13 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, gfc_global_used (gsym, where); if (gfc_option.flag_whole_file + && sym->attr.if_source == IFSRC_UNKNOWN && gsym->type != GSYM_UNKNOWN && gsym->ns - && gsym->ns->proc_name) + && gsym->ns->resolved != -1 + && gsym->ns->proc_name + && not_in_recursive (sym, gsym->ns) + && not_entry_self_reference (sym, gsym->ns)) { /* Make sure that translation for the gsymbol occurs before the procedure currently being resolved. */ @@ -1687,9 +1732,41 @@ resolve_global_procedure (gfc_symbol *sym, locus *where, } if (!gsym->ns->resolved) - gfc_resolve (gsym->ns); + { + gfc_dt_list *old_dt_list; + + /* Stash away derived types so that the backend_decls do not + get mixed up. */ + old_dt_list = gfc_derived_types; + gfc_derived_types = NULL; + + gfc_resolve (gsym->ns); + + /* Store the new derived types with the global namespace. */ + if (gfc_derived_types) + gsym->ns->derived_types = gfc_derived_types; + + /* Restore the derived types of this namespace. */ + gfc_derived_types = old_dt_list; + } + + if (gsym->ns->proc_name->attr.function + && gsym->ns->proc_name->as + && gsym->ns->proc_name->as->rank + && (!sym->as || sym->as->rank != gsym->ns->proc_name->as->rank)) + gfc_error ("The reference to function '%s' at %L either needs an " + "explicit INTERFACE or the rank is incorrect", sym->name, + where); + + if (gfc_option.flag_whole_file == 1 + || ((gfc_option.warn_std & GFC_STD_LEGACY) + && + !(gfc_option.warn_std & GFC_STD_GNU))) + gfc_errors_to_warnings (1); gfc_procedure_use (gsym->ns->proc_name, actual, where); + + gfc_errors_to_warnings (0); } if (gsym->type == GSYM_UNKNOWN) @@ -11134,15 +11211,19 @@ void gfc_resolve (gfc_namespace *ns) { gfc_namespace *old_ns; + code_stack *old_cs_base; if (ns->resolved) return; + ns->resolved = -1; old_ns = gfc_current_ns; + old_cs_base = cs_base; resolve_types (ns); resolve_codes (ns); gfc_current_ns = old_ns; + cs_base = old_cs_base; ns->resolved = 1; } diff --git a/gcc/fortran/trans-decl.c b/gcc/fortran/trans-decl.c index 783c8f8..70b78ed 100644 --- a/gcc/fortran/trans-decl.c +++ b/gcc/fortran/trans-decl.c @@ -1098,6 +1098,32 @@ gfc_get_symbol_decl (gfc_symbol * sym) if (sym->backend_decl) return sym->backend_decl; + /* If use associated and whole file compilation, use the module + declaration. This is only needed for intrinsic types because + they are substituted for one another during optimization. */ + if (gfc_option.flag_whole_file + && sym->attr.flavor == FL_VARIABLE + && sym->ts.type != BT_DERIVED + && sym->attr.use_assoc + && sym->module) + { + gfc_gsymbol *gsym; + + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); + if (gsym && gsym->ns && gsym->type == GSYM_MODULE) + { + gfc_symbol *s; + s = NULL; + gfc_find_symbol (sym->name, gsym->ns, 0, &s); + if (s && s->backend_decl) + { + if (sym->ts.type == BT_CHARACTER) + sym->ts.cl->backend_decl = s->ts.cl->backend_decl; + return s->backend_decl; + } + } + } + /* Catch function declarations. Only used for actual parameters and procedure pointers. */ if (sym->attr.flavor == FL_PROCEDURE) @@ -1341,6 +1367,7 @@ gfc_get_extern_function_decl (gfc_symbol * sym) gsym = gfc_find_gsymbol (gfc_gsym_root, sym->name); if (gfc_option.flag_whole_file + && !sym->attr.use_assoc && !sym->backend_decl && gsym && gsym->ns && ((gsym->type == GSYM_SUBROUTINE) || (gsym->type == GSYM_FUNCTION)) @@ -1371,6 +1398,26 @@ gfc_get_extern_function_decl (gfc_symbol * sym) return sym->backend_decl; } + /* See if this is a module procedure from the same file. If so, + return the backend_decl. */ + if (sym->module) + gsym = gfc_find_gsymbol (gfc_gsym_root, sym->module); + + if (gfc_option.flag_whole_file + && gsym && gsym->ns + && gsym->type == GSYM_MODULE) + { + gfc_symbol *s; + + s = NULL; + gfc_find_symbol (sym->name, gsym->ns, 0, &s); + if (s && s->backend_decl) + { + sym->backend_decl = s->backend_decl; + return sym->backend_decl; + } + } + if (sym->attr.intrinsic) { /* Call the resolution function to get the actual name. This is diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 9bec2e1..7352db8 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -4436,8 +4436,24 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts, gfc_add_block_to_block (&block, &lse->pre); gfc_add_block_to_block (&block, &rse->pre); + /* TODO This is rather obviously the wrong place to do this. + However, a number of testcases, such as function_kinds_1 + and function_types_2 fail without it, by ICEing at + fold_const: 2710 (fold_convert_loc). */ + if (ts.type == BT_DERIVED + && gfc_option.flag_whole_file + && (TYPE_MAIN_VARIANT (TREE_TYPE (rse->expr)) + != TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr)))) + { + tmp = gfc_evaluate_now (rse->expr, &block); + TYPE_MAIN_VARIANT (TREE_TYPE (tmp)) + = TYPE_MAIN_VARIANT (TREE_TYPE (lse->expr)); + } + else + tmp = rse->expr; + gfc_add_modify (&block, lse->expr, - fold_convert (TREE_TYPE (lse->expr), rse->expr)); + fold_convert (TREE_TYPE (lse->expr), tmp)); } gfc_add_block_to_block (&block, &lse->post); diff --git a/gcc/fortran/trans-types.c b/gcc/fortran/trans-types.c index 7b84236..92373e1 100644 --- a/gcc/fortran/trans-types.c +++ b/gcc/fortran/trans-types.c @@ -1853,7 +1853,8 @@ gfc_add_field_to_struct (tree *fieldlist, tree context, in 4.4.2 and resolved by gfc_compare_derived_types. */ static int -copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to) +copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to, + bool from_gsym) { gfc_component *to_cm; gfc_component *from_cm; @@ -1876,7 +1877,8 @@ copy_dt_decls_ifequal (gfc_symbol *from, gfc_symbol *to) for (; to_cm; to_cm = to_cm->next, from_cm = from_cm->next) { to_cm->backend_decl = from_cm->backend_decl; - if (!from_cm->attr.pointer && from_cm->ts.type == BT_DERIVED) + if ((!from_cm->attr.pointer || from_gsym) + && from_cm->ts.type == BT_DERIVED) gfc_get_derived_type (to_cm->ts.derived); else if (from_cm->ts.type == BT_CHARACTER) @@ -1916,8 +1918,12 @@ static tree gfc_get_derived_type (gfc_symbol * derived) { tree typenode = NULL, field = NULL, field_type = NULL, fieldlist = NULL; + tree canonical = NULL_TREE; + bool got_canonical = false; gfc_component *c; gfc_dt_list *dt; + gfc_namespace *ns; + gfc_gsymbol *gsym; gcc_assert (derived && derived->attr.flavor == FL_DERIVED); @@ -1949,7 +1955,59 @@ gfc_get_derived_type (gfc_symbol * derived) return derived->backend_decl; } - + +/* If use associated, use the module type for this one. */ + if (gfc_option.flag_whole_file + && derived->backend_decl == NULL + && derived->attr.use_assoc + && derived->module) + { + gsym = gfc_find_gsymbol (gfc_gsym_root, derived->module); + if (gsym && gsym->ns && gsym->type == GSYM_MODULE) + { + gfc_symbol *s; + s = NULL; + gfc_find_symbol (derived->name, gsym->ns, 0, &s); + if (s && s->backend_decl) + { + copy_dt_decls_ifequal (s, derived, true); + goto copy_derived_types; + } + } + } + + /* If a whole file compilation, the derived types from an earlier + namespace can be used as the the canonical type. */ + if (gfc_option.flag_whole_file + && derived->backend_decl == NULL + && !derived->attr.use_assoc + && gfc_global_ns_list) + { + for (ns = gfc_global_ns_list; + ns->translated && !got_canonical; + ns = ns->sibling) + { + dt = ns->derived_types; + for (; dt && !canonical; dt = dt->next) + { + copy_dt_decls_ifequal (dt->derived, derived, true); + if (derived->backend_decl) + got_canonical = true; + } + } + } + + /* Store up the canonical type to be added to this one. */ + if (got_canonical) + { + if (TYPE_CANONICAL (derived->backend_decl)) + canonical = TYPE_CANONICAL (derived->backend_decl); + else + canonical = derived->backend_decl; + + derived->backend_decl = NULL_TREE; + } + /* derived->backend_decl != 0 means we saw it before, but its components' backend_decl may have not been built. */ if (derived->backend_decl) @@ -2065,6 +2123,7 @@ gfc_get_derived_type (gfc_symbol * derived) /* Now we have the final fieldlist. Record it, then lay out the derived type, including the fields. */ TYPE_FIELDS (typenode) = fieldlist; + TYPE_CANONICAL (typenode) = canonical; gfc_finish_type (typenode); gfc_set_decl_location (TYPE_STUB_DECL (typenode), &derived->declared_at); @@ -2083,9 +2142,10 @@ gfc_get_derived_type (gfc_symbol * derived) derived->backend_decl = typenode; - /* Add this backend_decl to all the other, equal derived types. */ +copy_derived_types: + for (dt = gfc_derived_types; dt; dt = dt->next) - copy_dt_decls_ifequal (derived, dt->derived); + copy_dt_decls_ifequal (derived, dt->derived, false); return derived->backend_decl; } diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 31ef702..cb3b647 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,15 @@ +2009-08-01 Paul Thomas <pault@gcc.gnu.org> + + PR fortran/40011 + * gfortran.dg/whole_file_7.f90: New test. + * gfortran.dg/whole_file_8.f90: New test. + * gfortran.dg/whole_file_9.f90: New test. + * gfortran.dg/whole_file_10.f90: New test. + * gfortran.dg/whole_file_11.f90: New test. + * gfortran.dg/whole_file_12.f90: New test. + * gfortran.dg/whole_file_13.f90: New test. + * gfortran.dg/whole_file_14.f90: New test. + 2009-07-31 Jason Merrill <jason@redhat.com> * g++.dg/cpp0x/initlist22.C: Adjust for new rvalue reference diff --git a/gcc/testsuite/gfortran.dg/whole_file_10.f90 b/gcc/testsuite/gfortran.dg/whole_file_10.f90 new file mode 100644 index 0000000..fb100bb --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_10.f90 @@ -0,0 +1,32 @@ +! { dg-do compile } +! { dg-options "-fwhole-file" } +! Test the fix for the fifth problem in PR40011, where the +! entries were not resolved, resulting in a segfault. +! +! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr> +! +recursive function fac(i) result (res) + integer :: i, j, k, res + k = 1 + goto 100 +entry bifac(i,j) result (res) + k = j +100 continue + if (i < k) then + res = 1 + else + res = i * bifac(i-k,k) + end if +end function + +program test + external fac + external bifac + integer :: fac, bifac + print *, fac(5) + print *, bifac(5,2) + print*, fac(6) + print *, bifac(6,2) + print*, fac(0) + print *, bifac(1,2) +end program test diff --git a/gcc/testsuite/gfortran.dg/whole_file_11.f90 b/gcc/testsuite/gfortran.dg/whole_file_11.f90 new file mode 100644 index 0000000..d01b210 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_11.f90 @@ -0,0 +1,37 @@ +! { dg-do compile } +! { dg-options "-fwhole-file" } +! +! Tests the fix PR40011 comment 16 in which the derived type lists in +! different program units were getting mixed up. +! +! Contributed by Daniel Franck <dfranke@gcc.gnu.org> +! +MODULE module_foo + TYPE :: foo_node + TYPE(foo_node_private), POINTER :: p + END TYPE + + TYPE :: foo_node_private + TYPE(foo_node), DIMENSION(-1:1) :: link + END TYPE + + TYPE :: foo + TYPE(foo_node) :: root + END TYPE +END MODULE + +FUNCTION foo_insert() + USE module_foo, ONLY: foo, foo_node + + INTEGER :: foo_insert + TYPE(foo_node) :: parent, current + INTEGER :: cmp + + parent = current + current = current%p%link(cmp) +END FUNCTION + +FUNCTION foo_count() + USE module_foo, ONLY: foo + INTEGER :: foo_count +END FUNCTION diff --git a/gcc/testsuite/gfortran.dg/whole_file_12.f90 b/gcc/testsuite/gfortran.dg/whole_file_12.f90 new file mode 100644 index 0000000..150ac5f --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_12.f90 @@ -0,0 +1,33 @@ +! { dg-do compile } +! { dg-options "-fwhole-file" } +! +! Tests the fix PR40011 comment 17 in which the explicit interface was +! being ignored and the missing argument was not correctly handled, which +! led to an ICE. +! +! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr +! + Implicit None + call sub(1,2) + call sub(1,2,3) + + contains + + subroutine sub(i,j,k) + Implicit None + Integer, Intent( In ) :: i + Integer, Intent( In ) :: j + Integer, Intent( In ), Optional :: k + intrinsic present + write(*,*)' 3 presence flag ',present(k) + write(*,*)' 1st arg ',i + write(*,*)' 2nd arg ',j + if (present(k)) then + write(*,*)' 3rd arg ',k + else + write(*,*)' 3rd arg is absent' + endif + return + end subroutine + + end diff --git a/gcc/testsuite/gfortran.dg/whole_file_13.f90 b/gcc/testsuite/gfortran.dg/whole_file_13.f90 new file mode 100644 index 0000000..99e3cee --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_13.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fwhole-file -O3" } +! Check that the TYPE_CANONICAL is being correctly set +! for the derived types, when whole file compiling. +! (based on import.f90) +! +subroutine test(x) + type myType3 + sequence + integer :: i + end type myType3 + type(myType3) :: x + if(x%i /= 7) call abort() + x%i = 1 +end subroutine test + + +program foo + type myType3 + sequence + integer :: i + end type myType3 + + type(myType3) :: z + z%i = 7 + call test(z) + if(z%i /= 1) call abort +end program foo diff --git a/gcc/testsuite/gfortran.dg/whole_file_14.f90 b/gcc/testsuite/gfortran.dg/whole_file_14.f90 new file mode 100644 index 0000000..6505896 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_14.f90 @@ -0,0 +1,28 @@ +! { dg-do run } +! { dg-options "-fwhole-file -O3" } +! Check that the derived types are correctly substituted when +! whole file compiling. +! +! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr +! +module global + type :: mytype + type(mytype),pointer :: this + end type mytype + type(mytype),target :: base +end module global + +program test_equi + use global + call check() + print *, "base%this%this=>base?" , associated(base%this%this,base) + print *, "base%this%this=>?" , associated(base%this%this) + print *, "base%this=>?" , associated(base%this) +contains + subroutine check() + type(mytype),target :: j + base%this => j !have the variables point + j%this => base !to one another + end subroutine check !take j out of scope +end program test_equi +! { dg-final { cleanup-modules "global" } } diff --git a/gcc/testsuite/gfortran.dg/whole_file_7.f90 b/gcc/testsuite/gfortran.dg/whole_file_7.f90 new file mode 100644 index 0000000..53fed22 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_7.f90 @@ -0,0 +1,34 @@ +! { dg-do compile } +! { dg-options "-fwhole-file" } +! Test the fixes for the first two problems in PR40011 +! +! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr> +! +! This function would not compile because -fwhole-file would +! try repeatedly to resolve the function because of the self +! reference. +RECURSIVE FUNCTION eval_args(q) result (r) + INTEGER NNODE + PARAMETER (NNODE = 10) + TYPE NODE + SEQUENCE + INTEGER car + INTEGER cdr + END TYPE NODE + TYPE(NODE) heap(NNODE) + INTEGER r, q + r = eval_args(heap(q)%cdr) +END FUNCTION eval_args + +function test(n) + real, dimension(2) :: test + integer :: n + test = n + return +end function test + +program arr ! The error was not picked up causing an ICE + real, dimension(2) :: res + res = test(2) ! { dg-error "needs an explicit INTERFACE" } + print *, res +end program diff --git a/gcc/testsuite/gfortran.dg/whole_file_8.f90 b/gcc/testsuite/gfortran.dg/whole_file_8.f90 new file mode 100644 index 0000000..6ea319a --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_8.f90 @@ -0,0 +1,36 @@ +! { dg-do compile } +! { dg-options "-fwhole-file" } +! Test the fix for the third problem in PR40011, where false +! type/rank mismatches were found in the main program calls. +! +! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr> +! +subroutine test_d(fn, val, res) + double precision fn + double precision val, res + + print *, fn(val), res +end subroutine + +subroutine test_c(fn, val, res) + complex fn + complex val, res + + print *, fn(val), res +end subroutine + +program specifics + + intrinsic dcos + intrinsic dcosh + intrinsic dexp + + intrinsic conjg + + call test_d (dcos, 1d0, dcos(1d0)) + call test_d (dcosh, 1d0, dcosh(1d0)) + call test_d (dexp, 1d0, dexp(1d0)) + + call test_c (conjg, (1.0,1.0) , conjg((1.0,1.0))) + +end program diff --git a/gcc/testsuite/gfortran.dg/whole_file_9.f90 b/gcc/testsuite/gfortran.dg/whole_file_9.f90 new file mode 100644 index 0000000..64dce42 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/whole_file_9.f90 @@ -0,0 +1,46 @@ +! { dg-do compile } +! { dg-options "-fwhole-file" } +! Test the fix for the fourth problem in PR40011, where the +! entries were not resolved, resulting in a segfault. +! +! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr> +! +program test +interface + function bad_stuff(n) + integer :: bad_stuff (2) + integer :: n(2) + end function bad_stuff + recursive function rec_stuff(n) result (tmp) + integer :: n(2), tmp(2) + end function rec_stuff +end interface + integer :: res(2) + res = bad_stuff((/-19,-30/)) + +end program test + + recursive function bad_stuff(n) + integer :: bad_stuff (2) + integer :: n(2), tmp(2), ent = 0, sent = 0 + save ent, sent + ent = -1 + entry rec_stuff(n) result (tmp) + if (ent == -1) then + sent = ent + ent = 0 + end if + ent = ent + 1 + tmp = 1 + if(maxval (n) < 5) then + tmp = tmp + rec_stuff (n+1) + ent = ent - 1 + endif + if (ent == 1) then + if (sent == -1) then + bad_stuff = tmp + bad_stuff (1) + end if + ent = 0 + sent = 0 + end if + end function bad_stuff |