X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fparse.c;h=2552fcd67886520288b2eb40dfeade6c15eccfa9;hb=eeebe20ba63ca092de5e2d4575b5765dd88a7ce6;hp=f9c37058c3f47a45121842b5f51b449ceb6807ff;hpb=3be2b8d585d1d3e83ac98bb088e14170e0a10bff;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index f9c37058c3f..2552fcd6788 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1,5 +1,6 @@ /* Main parser. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -372,6 +373,7 @@ decode_statement (void) break; case 'g': + match ("generic", gfc_match_generic, ST_GENERIC); match ("go to", gfc_match_goto, ST_GOTO); break; @@ -564,6 +566,34 @@ decode_omp_directive (void) return ST_NONE; } +static gfc_statement +decode_gcc_attribute (void) +{ + locus old_locus; + +#ifdef GFC_DEBUG + gfc_symbol_state (); +#endif + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + old_locus = gfc_current_locus; + + match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL); + + /* All else has failed, so give up. See if any of the matchers has + stored an error message of some sort. */ + + if (gfc_error_check () == 0) + gfc_error_now ("Unclassifiable GCC directive at %C"); + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; +} + #undef match @@ -635,21 +665,39 @@ next_free (void) else if (c == '!') { /* Comments have already been skipped by the time we get here, - except for OpenMP directives. */ - if (gfc_option.flag_openmp) + except for GCC attributes and OpenMP directives. */ + + gfc_next_ascii_char (); /* Eat up the exclamation sign. */ + c = gfc_peek_ascii_char (); + + if (c == 'g') + { + int i; + + c = gfc_next_ascii_char (); + for (i = 0; i < 4; i++, c = gfc_next_ascii_char ()) + gcc_assert (c == "gcc$"[i]); + + gfc_gobble_whitespace (); + return decode_gcc_attribute (); + + } + else if (c == '$' && gfc_option.flag_openmp) { int i; c = gfc_next_ascii_char (); - for (i = 0; i < 5; i++, c = gfc_next_ascii_char ()) - gcc_assert (c == "!$omp"[i]); + for (i = 0; i < 4; i++, c = gfc_next_ascii_char ()) + gcc_assert (c == "$omp"[i]); gcc_assert (c == ' ' || c == '\t'); gfc_gobble_whitespace (); return decode_omp_directive (); } - } + gcc_unreachable (); + } + if (at_bol && c == ';') { gfc_error_now ("Semicolon at %C needs to be preceded by statement"); @@ -707,12 +755,22 @@ next_fixed (void) break; /* Comments have already been skipped by the time we get - here, except for OpenMP directives. */ + here, except for GCC attributes and OpenMP directives. */ + case '*': - if (gfc_option.flag_openmp) + c = gfc_next_char_literal (0); + + if (TOLOWER (c) == 'g') + { + for (i = 0; i < 4; i++, c = gfc_next_char_literal (0)) + gcc_assert (TOLOWER (c) == "gcc$"[i]); + + return decode_gcc_attribute (); + } + else if (c == '$' && gfc_option.flag_openmp) { - for (i = 0; i < 5; i++, c = gfc_next_char_literal (0)) - gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]); + for (i = 0; i < 4; i++, c = gfc_next_char_literal (0)) + gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]); if (c != ' ' && c != '0') { @@ -806,6 +864,7 @@ next_statement (void) locus old_locus; gfc_new_block = NULL; + gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; for (;;) { gfc_statement_label = NULL; @@ -1195,6 +1254,9 @@ gfc_ascii_statement (gfc_statement st) case ST_FUNCTION: p = "FUNCTION"; break; + case ST_GENERIC: + p = "GENERIC"; + break; case ST_GOTO: p = "GOTO"; break; @@ -1459,16 +1521,23 @@ accept_statement (gfc_statement st) /* If the statement is the end of a block, lay down a special code that allows a branch to the end of the block from within the - construct. */ + construct. IF and SELECT are treated differently from DO + (where EXEC_NOP is added inside the loop) for two + reasons: + 1. END DO has a meaning in the sense that after a GOTO to + it, the loop counter must be increased. + 2. IF blocks and SELECT blocks can consist of multiple + parallel blocks (IF ... ELSE IF ... ELSE ... END IF). + Putting the label before the END IF would make the jump + from, say, the ELSE IF block to the END IF illegal. */ case ST_ENDIF: case ST_END_SELECT: if (gfc_statement_label != NULL) { - new_st.op = EXEC_NOP; + new_st.op = EXEC_END_BLOCK; add_statement (); } - break; /* The end-of-program unit statements do not get the special @@ -1483,6 +1552,11 @@ accept_statement (gfc_statement st) new_st.op = EXEC_RETURN; add_statement (); } + else + { + new_st.op = EXEC_END_PROCEDURE; + add_statement (); + } break; @@ -1508,6 +1582,10 @@ accept_statement (gfc_statement st) static void reject_statement (void) { + /* Revert to the previous charlen chain. */ + gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list); + gfc_current_ns->cl_list = gfc_current_ns->old_cl_list; + gfc_new_block = NULL; gfc_undo_symbols (); gfc_clear_warning (); @@ -1563,13 +1641,20 @@ unexpected_statement (gfc_statement st) */ +enum state_order +{ + ORDER_START, + ORDER_USE, + ORDER_IMPORT, + ORDER_IMPLICIT_NONE, + ORDER_IMPLICIT, + ORDER_SPEC, + ORDER_EXEC +}; + typedef struct { - enum - { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE, - ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC - } - state; + enum state_order state; gfc_statement last_statement; locus where; } @@ -1691,13 +1776,149 @@ unexpected_eof (void) } +/* Parse the CONTAINS section of a derived type definition. */ + +gfc_access gfc_typebound_default_access; + +static bool +parse_derived_contains (void) +{ + gfc_state_data s; + bool seen_private = false; + bool seen_comps = false; + bool error_flag = false; + bool to_finish; + + gcc_assert (gfc_current_state () == COMP_DERIVED); + gcc_assert (gfc_current_block ()); + + /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS + section. */ + if (gfc_current_block ()->attr.sequence) + gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS" + " section at %C", gfc_current_block ()->name); + if (gfc_current_block ()->attr.is_bind_c) + gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS" + " section at %C", gfc_current_block ()->name); + + accept_statement (ST_CONTAINS); + push_state (&s, COMP_DERIVED_CONTAINS, NULL); + + gfc_typebound_default_access = ACCESS_PUBLIC; + + to_finish = false; + while (!to_finish) + { + gfc_statement st; + st = next_statement (); + switch (st) + { + case ST_NONE: + unexpected_eof (); + break; + + case ST_DATA_DECL: + gfc_error ("Components in TYPE at %C must precede CONTAINS"); + error_flag = true; + break; + + case ST_PROCEDURE: + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Type-bound" + " procedure at %C") == FAILURE) + error_flag = true; + + accept_statement (ST_PROCEDURE); + seen_comps = true; + break; + + case ST_GENERIC: + if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: GENERIC binding" + " at %C") == FAILURE) + error_flag = true; + + accept_statement (ST_GENERIC); + seen_comps = true; + break; + + case ST_FINAL: + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: FINAL procedure declaration" + " at %C") == FAILURE) + error_flag = true; + + accept_statement (ST_FINAL); + seen_comps = true; + break; + + case ST_END_TYPE: + to_finish = true; + + if (!seen_comps + && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type " + "definition at %C with empty CONTAINS " + "section") == FAILURE)) + error_flag = true; + + /* ST_END_TYPE is accepted by parse_derived after return. */ + break; + + case ST_PRIVATE: + if (gfc_find_state (COMP_MODULE) == FAILURE) + { + gfc_error ("PRIVATE statement in TYPE at %C must be inside " + "a MODULE"); + error_flag = true; + break; + } + + if (seen_comps) + { + gfc_error ("PRIVATE statement at %C must precede procedure" + " bindings"); + error_flag = true; + break; + } + + if (seen_private) + { + gfc_error ("Duplicate PRIVATE statement at %C"); + error_flag = true; + } + + accept_statement (ST_PRIVATE); + gfc_typebound_default_access = ACCESS_PRIVATE; + seen_private = true; + break; + + case ST_SEQUENCE: + gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); + error_flag = true; + break; + + case ST_CONTAINS: + gfc_error ("Already inside a CONTAINS block at %C"); + error_flag = true; + break; + + default: + unexpected_statement (st); + break; + } + } + + pop_state (); + gcc_assert (gfc_current_state () == COMP_DERIVED); + + return error_flag; +} + + /* Parse a derived type. */ static void parse_derived (void) { int compiling_type, seen_private, seen_sequence, seen_component, error_flag; - int seen_contains, seen_contains_comp; gfc_statement st; gfc_state_data s; gfc_symbol *derived_sym = NULL; @@ -1713,8 +1934,6 @@ parse_derived (void) seen_private = 0; seen_sequence = 0; seen_component = 0; - seen_contains = 0; - seen_contains_comp = 0; compiling_type = 1; @@ -1728,33 +1947,17 @@ parse_derived (void) case ST_DATA_DECL: case ST_PROCEDURE: - if (seen_contains) - { - gfc_error ("Components in TYPE at %C must precede CONTAINS"); - error_flag = 1; - } - accept_statement (st); seen_component = 1; break; case ST_FINAL: - if (!seen_contains) - { - gfc_error ("FINAL declaration at %C must be inside CONTAINS"); - error_flag = 1; - } - - if (gfc_notify_std (GFC_STD_F2003, - "Fortran 2003: FINAL procedure declaration" - " at %C") == FAILURE) - error_flag = 1; - - accept_statement (ST_FINAL); - seen_contains_comp = 1; + gfc_error ("FINAL declaration at %C must be inside CONTAINS"); + error_flag = 1; break; case ST_END_TYPE: +endType: compiling_type = 0; if (!seen_component @@ -1763,22 +1966,10 @@ parse_derived (void) == FAILURE)) error_flag = 1; - if (seen_contains && !seen_contains_comp - && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type " - "definition at %C with empty CONTAINS " - "section") == FAILURE)) - error_flag = 1; - accept_statement (ST_END_TYPE); break; case ST_PRIVATE: - if (seen_contains) - { - gfc_error ("PRIVATE statement at %C must precede CONTAINS"); - error_flag = 1; - } - if (gfc_find_state (COMP_MODULE) == FAILURE) { gfc_error ("PRIVATE statement in TYPE at %C must be inside " @@ -1802,17 +1993,12 @@ parse_derived (void) } s.sym->component_access = ACCESS_PRIVATE; + accept_statement (ST_PRIVATE); seen_private = 1; break; case ST_SEQUENCE: - if (seen_contains) - { - gfc_error ("SEQUENCE statement at %C must precede CONTAINS"); - error_flag = 1; - } - if (seen_component) { gfc_error ("SEQUENCE statement at %C must precede " @@ -1842,15 +2028,10 @@ parse_derived (void) " definition at %C") == FAILURE) error_flag = 1; - if (seen_contains) - { - gfc_error ("Already inside a CONTAINS block at %C"); - error_flag = 1; - } - - seen_contains = 1; accept_statement (ST_CONTAINS); - break; + if (parse_derived_contains ()) + error_flag = 1; + goto endType; default: unexpected_statement (st); @@ -1868,28 +2049,25 @@ parse_derived (void) { /* Look for allocatable components. */ if (c->attr.allocatable - || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)) - { - sym->attr.alloc_comp = 1; - break; - } + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp)) + sym->attr.alloc_comp = 1; /* Look for pointer components. */ if (c->attr.pointer - || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp)) - { - sym->attr.pointer_comp = 1; - break; - } + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp)) + sym->attr.pointer_comp = 1; + + /* Look for procedure pointer components. */ + if (c->attr.proc_pointer + || (c->ts.type == BT_DERIVED + && c->ts.u.derived->attr.proc_pointer_comp)) + sym->attr.proc_pointer_comp = 1; /* Look for private components. */ if (sym->component_access == ACCESS_PRIVATE || c->attr.access == ACCESS_PRIVATE - || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp)) - { - sym->attr.private_comp = 1; - break; - } + || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp)) + sym->attr.private_comp = 1; } if (!seen_component) @@ -1959,7 +2137,7 @@ static gfc_statement parse_spec (gfc_statement); static void parse_interface (void) { - gfc_compile_state new_state, current_state; + gfc_compile_state new_state = COMP_NONE, current_state; gfc_symbol *prog_unit, *sym; gfc_interface_info save; gfc_state_data s1, s2; @@ -2005,14 +2183,6 @@ loop: gfc_free_namespace (gfc_current_ns); goto loop; } - if (current_interface.type != INTERFACE_ABSTRACT && - !gfc_new_block->attr.dummy && - gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE) - { - reject_statement (); - gfc_free_namespace (gfc_current_ns); - goto loop; - } break; case ST_PROCEDURE: @@ -2066,7 +2236,7 @@ loop: if (current_interface.type == INTERFACE_ABSTRACT) { - gfc_new_block->attr.abstract = 1; + gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus); if (gfc_is_intrinsic_typename (gfc_new_block->name)) gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C " "cannot be the same as an intrinsic type", @@ -2105,6 +2275,10 @@ decl: goto decl; } + /* Add EXTERNAL attribute to function or subroutine. */ + if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy) + gfc_add_external (&prog_unit->attr, &gfc_current_locus); + current_interface = save; gfc_add_interface (prog_unit); pop_state (); @@ -2146,7 +2320,7 @@ match_deferred_characteristics (gfc_typespec * ts) { ts->kind = 0; - if (!ts->derived || !ts->derived->components) + if (!ts->u.derived || !ts->u.derived->components) m = MATCH_ERROR; } @@ -2156,8 +2330,9 @@ match_deferred_characteristics (gfc_typespec * ts) /* Set the function locus correctly. If we have not found the function name, there is an error. */ - gfc_match ("function% %n", name); - if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0) + if (m == MATCH_YES + && gfc_match ("function% %n", name) == MATCH_YES + && strcmp (name, gfc_current_block ()->name) == 0) { gfc_current_block ()->declared_at = gfc_current_locus; gfc_commit_symbols (); @@ -2185,8 +2360,8 @@ check_function_result_typed (void) /* Check type-parameters, at the moment only CHARACTER lengths possible. */ /* TODO: Extend when KIND type parameters are implemented. */ - if (ts->type == BT_CHARACTER && ts->cl && ts->cl->length) - gfc_expr_check_typed (ts->cl->length, gfc_current_ns, true); + if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length) + gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true); } @@ -2228,7 +2403,7 @@ loop: { bool verify_now = false; - if (st == ST_END_FUNCTION) + if (st == ST_END_FUNCTION || st == ST_CONTAINS) verify_now = true; else { @@ -2365,7 +2540,7 @@ declSt: gfc_current_block ()->ts.kind = 0; /* Keep the derived type; if it's bad, it will be discovered later. */ - if (!(ts->type == BT_DERIVED && ts->derived)) + if (!(ts->type == BT_DERIVED && ts->u.derived)) ts->type = BT_UNKNOWN; } @@ -2389,10 +2564,10 @@ parse_where_block (void) push_state (&s, COMP_WHERE, gfc_new_block); d = add_statement (); - d->expr = top->expr; + d->expr1 = top->expr1; d->op = EXEC_WHERE; - top->expr = NULL; + top->expr1 = NULL; top->block = d; seen_empty_else = 0; @@ -2422,12 +2597,12 @@ parse_where_block (void) break; } - if (new_st.expr == NULL) + if (new_st.expr1 == NULL) seen_empty_else = 1; d = new_level (gfc_state_stack->head); d->op = EXEC_WHERE; - d->expr = new_st.expr; + d->expr1 = new_st.expr1; accept_statement (st); @@ -2532,8 +2707,8 @@ parse_if_block (void) new_st.op = EXEC_IF; d = add_statement (); - d->expr = top->expr; - top->expr = NULL; + d->expr1 = top->expr1; + top->expr1 = NULL; top->block = d; do @@ -2557,7 +2732,7 @@ parse_if_block (void) d = new_level (gfc_state_stack->head); d->op = EXEC_IF; - d->expr = new_st.expr; + d->expr1 = new_st.expr1; accept_statement (st); @@ -2715,7 +2890,6 @@ check_do_closure (void) if (p->ext.end_do_label == gfc_statement_label) { - if (p == gfc_state_stack) return 1; @@ -2749,7 +2923,7 @@ parse_do_block (void) gfc_state_data s; gfc_symtree *stree; - s.ext.end_do_label = new_st.label; + s.ext.end_do_label = new_st.label1; if (new_st.ext.iterator != NULL) stree = new_st.ext.iterator->var->symtree; @@ -2793,7 +2967,7 @@ loop: name, but in that case we must have seen ST_ENDDO first). We only complain about this in pedantic mode. */ if (gfc_current_block () != NULL) - gfc_error_now ("named block DO at %L requires matching ENDDO name", + gfc_error_now ("Named block DO at %L requires matching ENDDO name", &gfc_current_block()->declared_at); break; @@ -3206,10 +3380,10 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) sym->attr.referenced = 1; for (ns = siblings; ns; ns = ns->sibling) { - gfc_find_sym_tree (sym->name, ns, 0, &st); + st = gfc_find_symtree (ns->sym_root, sym->name); if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) - continue; + goto fixup_contained; old_sym = st->n.sym; if (old_sym->ns == ns @@ -3243,6 +3417,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) gfc_free_symbol (old_sym); } +fixup_contained: /* Do the same for any contained procedures. */ gfc_fixup_sibling_symbols (sym, ns->contained); } @@ -3585,6 +3760,8 @@ loop: st = next_statement (); goto loop; } + + s->ns = gfc_current_ns; } @@ -3606,6 +3783,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; } } @@ -3628,10 +3806,81 @@ add_global_program (void) s->type = GSYM_PROGRAM; s->where = gfc_current_locus; s->defined = 1; + s->ns = gfc_current_ns; } } +/* 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 @@ -3641,6 +3890,7 @@ gfc_parse_file (void) gfc_state_data top, s; gfc_statement st; locus prog_locus; + gfc_namespace *next; gfc_start_source_files (); @@ -3659,6 +3909,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. */ @@ -3685,6 +3939,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: @@ -3692,6 +3948,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: @@ -3699,6 +3957,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: @@ -3725,9 +3985,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); @@ -3742,18 +4005,64 @@ 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 (); } + goto loop; + +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 (); - gfc_done_2 (); goto loop; -done: + done: + + if (!gfc_option.flag_whole_file) + goto termination; + + /* 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; + + for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling) + { + gfc_dump_parse_tree (gfc_current_ns, stdout); + fputs ("------------------------------------------\n\n", stdout); + } + + /* Do the translation. */ + translate_all_program_units (gfc_global_ns_list); + +termination: + gfc_end_source_files (); return SUCCESS;