X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fparse.c;h=3e86a43d0b13f4383c002c1be2ce2ef5ed528ed4;hb=88087e898a921f4adeb8e5612f521e8b47e4587d;hp=430d8f3761c83ccac87d1961d05ec61ccae56c68;hpb=3b6a4b4184528ed5c6c5f8e51c1c57cd92ed2cf5;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 430d8f3761c..3e86a43d0b1 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1,13 +1,13 @@ /* Main parser. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005 Free Software Foundation, - Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 + Free Software Foundation, Inc. Contributed by Andy Vaught This file is part of GCC. GCC is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free -Software Foundation; either version 2, or (at your option) any later +Software Foundation; either version 3, or (at your option) any later version. GCC is distributed in the hope that it will be useful, but WITHOUT ANY @@ -16,10 +16,8 @@ FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License -along with GCC; see the file COPYING. If not, write to the Free -Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA -02110-1301, USA. */ - +along with GCC; see the file COPYING3. If not see +. */ #include "config.h" #include "system.h" @@ -27,10 +25,10 @@ Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA #include "gfortran.h" #include "match.h" #include "parse.h" +#include "debug.h" -/* Current statement label. Zero means no statement label. Because - new_st can get wiped during statement matching, we have to keep it - separate. */ +/* Current statement label. Zero means no statement label. Because new_st + can get wiped during statement matching, we have to keep it separate. */ gfc_st_label *gfc_statement_label; @@ -44,6 +42,7 @@ static void check_statement_label (gfc_statement); static void undo_new_statement (void); static void reject_statement (void); + /* A sort of half-matching function. We try to match the word on the input with the passed string. If this succeeds, we call the keyword-dependent matching function that will match the rest of the @@ -51,7 +50,7 @@ static void reject_statement (void); gfc_match_eos(). */ static match -match_word (const char *str, match (*subr) (void), locus * old_locus) +match_word (const char *str, match (*subr) (void), locus *old_locus) { match m; @@ -79,20 +78,158 @@ match_word (const char *str, match (*subr) (void), locus * old_locus) ambiguity. */ #define match(keyword, subr, st) \ - do { \ + do { \ if (match_word(keyword, subr, &old_locus) == MATCH_YES) \ - return st; \ + return st; \ else \ - undo_new_statement (); \ + undo_new_statement (); \ } while (0); + +/* This is a specialist version of decode_statement that is used + for the specification statements in a function, whose + characteristics are deferred into the specification statements. + eg.: INTEGER (king = mykind) foo () + USE mymodule, ONLY mykind..... + The KIND parameter needs a return after USE or IMPORT, whereas + derived type declarations can occur anywhere, up the executable + block. ST_GET_FCN_CHARACTERISTICS is returned when we have run + out of the correct kind of specification statements. */ +static gfc_statement +decode_specification_statement (void) +{ + gfc_statement st; + locus old_locus; + char c; + + if (gfc_match_eos () == MATCH_YES) + return ST_NONE; + + old_locus = gfc_current_locus; + + match ("import", gfc_match_import, ST_IMPORT); + match ("use", gfc_match_use, ST_USE); + + if (gfc_current_block ()->ts.type != BT_DERIVED) + goto end_of_block; + + match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION); + match (NULL, gfc_match_data_decl, ST_DATA_DECL); + match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR); + + /* General statement matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_ascii_char (); + + switch (c) + { + case 'a': + match ("abstract% interface", gfc_match_abstract_interface, + ST_INTERFACE); + break; + + case 'b': + match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); + break; + + case 'c': + break; + + case 'd': + match ("data", gfc_match_data, ST_DATA); + match ("dimension", gfc_match_dimension, ST_ATTR_DECL); + break; + + case 'e': + match ("enum , bind ( c )", gfc_match_enum, ST_ENUM); + match ("entry% ", gfc_match_entry, ST_ENTRY); + match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE); + match ("external", gfc_match_external, ST_ATTR_DECL); + break; + + case 'f': + match ("format", gfc_match_format, ST_FORMAT); + break; + + case 'g': + break; + + case 'i': + match ("implicit", gfc_match_implicit, ST_IMPLICIT); + match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); + match ("interface", gfc_match_interface, ST_INTERFACE); + match ("intent", gfc_match_intent, ST_ATTR_DECL); + match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); + break; + + case 'm': + break; + + case 'n': + match ("namelist", gfc_match_namelist, ST_NAMELIST); + break; + + case 'o': + match ("optional", gfc_match_optional, ST_ATTR_DECL); + break; + + case 'p': + match ("parameter", gfc_match_parameter, ST_PARAMETER); + match ("pointer", gfc_match_pointer, ST_ATTR_DECL); + if (gfc_match_private (&st) == MATCH_YES) + return st; + match ("procedure", gfc_match_procedure, ST_PROCEDURE); + if (gfc_match_public (&st) == MATCH_YES) + return st; + match ("protected", gfc_match_protected, ST_ATTR_DECL); + break; + + case 'r': + break; + + case 's': + match ("save", gfc_match_save, ST_ATTR_DECL); + break; + + case 't': + match ("target", gfc_match_target, ST_ATTR_DECL); + match ("type", gfc_match_derived_decl, ST_DERIVED_DECL); + break; + + case 'u': + break; + + case 'v': + match ("value", gfc_match_value, ST_ATTR_DECL); + match ("volatile", gfc_match_volatile, ST_ATTR_DECL); + break; + + case 'w': + break; + } + + /* This is not a specification statement. See if any of the matchers + has stored an error message of some sort. */ + +end_of_block: + gfc_clear_error (); + gfc_buffer_error (0); + gfc_current_locus = old_locus; + + return ST_GET_FCN_CHARACTERISTICS; +} + + +/* This is the primary 'decode_statement'. */ static gfc_statement decode_statement (void) { gfc_statement st; locus old_locus; match m; - int c; + char c; #ifdef GFC_DEBUG gfc_symbol_state (); @@ -101,9 +238,15 @@ decode_statement (void) gfc_clear_error (); /* Clear any pending errors. */ gfc_clear_warning (); /* Clear any pending warnings. */ + gfc_matching_function = false; + if (gfc_match_eos () == MATCH_YES) return ST_NONE; + if (gfc_current_state () == COMP_FUNCTION + && gfc_current_block ()->result->ts.kind == -1) + return decode_specification_statement (); + old_locus = gfc_current_locus; /* Try matching a data declaration or function declaration. The @@ -114,15 +257,18 @@ decode_statement (void) || gfc_current_state () == COMP_INTERFACE || gfc_current_state () == COMP_CONTAINS) { + gfc_matching_function = true; m = gfc_match_function_decl (); if (m == MATCH_YES) return ST_FUNCTION; else if (m == MATCH_ERROR) reject_statement (); - - gfc_undo_symbols (); + else + gfc_undo_symbols (); gfc_current_locus = old_locus; } + gfc_matching_function = false; + /* Match statements whose error messages are meant to be overwritten by something better. */ @@ -169,11 +315,13 @@ decode_statement (void) statement, we eliminate most possibilities by peeking at the first character. */ - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); switch (c) { case 'a': + match ("abstract% interface", gfc_match_abstract_interface, + ST_INTERFACE); match ("allocate", gfc_match_allocate, ST_ALLOCATE); match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL); match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT); @@ -182,6 +330,7 @@ decode_statement (void) case 'b': match ("backspace", gfc_match_backspace, ST_BACKSPACE); match ("block data", gfc_match_block_data, ST_BLOCK_DATA); + match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL); break; case 'c': @@ -217,11 +366,13 @@ decode_statement (void) break; case 'f': + match ("final", gfc_match_final_decl, ST_FINAL); match ("flush", gfc_match_flush, ST_FLUSH); match ("format", gfc_match_format, ST_FORMAT); break; case 'g': + match ("generic", gfc_match_generic, ST_GENERIC); match ("go to", gfc_match_goto, ST_GOTO); break; @@ -229,6 +380,7 @@ decode_statement (void) match ("inquire", gfc_match_inquire, ST_INQUIRE); match ("implicit", gfc_match_implicit, ST_IMPLICIT); match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE); + match ("import", gfc_match_import, ST_IMPORT); match ("interface", gfc_match_interface, ST_INTERFACE); match ("intent", gfc_match_intent, ST_ATTR_DECL); match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL); @@ -256,9 +408,11 @@ decode_statement (void) match ("pointer", gfc_match_pointer, ST_ATTR_DECL); if (gfc_match_private (&st) == MATCH_YES) return st; + match ("procedure", gfc_match_procedure, ST_PROCEDURE); match ("program", gfc_match_program, ST_PROGRAM); if (gfc_match_public (&st) == MATCH_YES) return st; + match ("protected", gfc_match_protected, ST_ATTR_DECL); break; case 'r': @@ -279,10 +433,16 @@ decode_statement (void) break; case 'u': - match ("use% ", gfc_match_use, ST_USE); + match ("use", gfc_match_use, ST_USE); + break; + + case 'v': + match ("value", gfc_match_value, ST_ATTR_DECL); + match ("volatile", gfc_match_volatile, ST_ATTR_DECL); break; case 'w': + match ("wait", gfc_match_wait, ST_WAIT); match ("write", gfc_match_write, ST_WRITE); break; } @@ -300,6 +460,111 @@ decode_statement (void) return ST_NONE; } +static gfc_statement +decode_omp_directive (void) +{ + locus old_locus; + char c; + +#ifdef GFC_DEBUG + gfc_symbol_state (); +#endif + + gfc_clear_error (); /* Clear any pending errors. */ + gfc_clear_warning (); /* Clear any pending warnings. */ + + if (gfc_pure (NULL)) + { + gfc_error_now ("OpenMP directives at %C may not appear in PURE " + "or ELEMENTAL procedures"); + gfc_error_recovery (); + return ST_NONE; + } + + old_locus = gfc_current_locus; + + /* General OpenMP directive matching: Instead of testing every possible + statement, we eliminate most possibilities by peeking at the + first character. */ + + c = gfc_peek_ascii_char (); + + switch (c) + { + case 'a': + match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC); + break; + case 'b': + match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER); + break; + case 'c': + match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL); + break; + case 'd': + match ("do", gfc_match_omp_do, ST_OMP_DO); + break; + case 'e': + match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL); + match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO); + match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER); + match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED); + match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO); + match ("end parallel sections", gfc_match_omp_eos, + ST_OMP_END_PARALLEL_SECTIONS); + match ("end parallel workshare", gfc_match_omp_eos, + ST_OMP_END_PARALLEL_WORKSHARE); + match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL); + match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS); + match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE); + match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK); + match ("end workshare", gfc_match_omp_end_nowait, + ST_OMP_END_WORKSHARE); + break; + case 'f': + match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH); + break; + case 'm': + match ("master", gfc_match_omp_master, ST_OMP_MASTER); + break; + case 'o': + match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED); + break; + case 'p': + match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO); + match ("parallel sections", gfc_match_omp_parallel_sections, + ST_OMP_PARALLEL_SECTIONS); + match ("parallel workshare", gfc_match_omp_parallel_workshare, + ST_OMP_PARALLEL_WORKSHARE); + match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL); + break; + case 's': + match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS); + match ("section", gfc_match_omp_eos, ST_OMP_SECTION); + match ("single", gfc_match_omp_single, ST_OMP_SINGLE); + break; + case 't': + match ("task", gfc_match_omp_task, ST_OMP_TASK); + match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT); + match ("threadprivate", gfc_match_omp_threadprivate, + ST_OMP_THREADPRIVATE); + case 'w': + match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE); + break; + } + + /* 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 OpenMP directive at %C"); + + reject_statement (); + + gfc_error_recovery (); + + return ST_NONE; +} + #undef match @@ -309,51 +574,89 @@ static gfc_statement next_free (void) { match m; - int c, d; + int i, cnt, at_bol; + char c; + at_bol = gfc_at_bol (); gfc_gobble_whitespace (); - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); if (ISDIGIT (c)) { + char d; + /* Found a statement label? */ - m = gfc_match_st_label (&gfc_statement_label, 0); + m = gfc_match_st_label (&gfc_statement_label); - d = gfc_peek_char (); + d = gfc_peek_ascii_char (); if (m != MATCH_YES || !gfc_is_whitespace (d)) { + gfc_match_small_literal_int (&i, &cnt); + + if (cnt > 5) + gfc_error_now ("Too many digits in statement label at %C"); + + if (i == 0) + gfc_error_now ("Zero is not a valid statement label at %C"); + do - { - /* Skip the bad statement label. */ - gfc_warning_now ("Ignoring bad statement label at %C"); - c = gfc_next_char (); - } - while (ISDIGIT (c)); + c = gfc_next_ascii_char (); + while (ISDIGIT(c)); + + if (!gfc_is_whitespace (c)) + gfc_error_now ("Non-numeric character in statement label at %C"); + + return ST_NONE; } else { label_locus = gfc_current_locus; - if (gfc_statement_label->value == 0) + gfc_gobble_whitespace (); + + if (at_bol && gfc_peek_ascii_char () == ';') { - gfc_warning_now ("Ignoring statement label of zero at %C"); - gfc_free_st_label (gfc_statement_label); - gfc_statement_label = NULL; + gfc_error_now ("Semicolon at %C needs to be preceded by " + "statement"); + gfc_next_ascii_char (); /* Eat up the semicolon. */ + return ST_NONE; } - gfc_gobble_whitespace (); - if (gfc_match_eos () == MATCH_YES) { - gfc_warning_now - ("Ignoring statement label in empty statement at %C"); + gfc_warning_now ("Ignoring statement label in empty statement " + "at %C"); gfc_free_st_label (gfc_statement_label); gfc_statement_label = NULL; return ST_NONE; } } } + else if (c == '!') + { + /* Comments have already been skipped by the time we get here, + except for OpenMP directives. */ + if (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]); + + gcc_assert (c == ' ' || c == '\t'); + gfc_gobble_whitespace (); + return decode_omp_directive (); + } + } + + if (at_bol && c == ';') + { + gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + gfc_next_ascii_char (); /* Eat up the semicolon. */ + return ST_NONE; + } return decode_statement (); } @@ -366,7 +669,7 @@ next_fixed (void) { int label, digit_flag, i; locus loc; - char c; + gfc_char_t c; if (!gfc_at_bol ()) return decode_statement (); @@ -399,12 +702,31 @@ next_fixed (void) case '7': case '8': case '9': - label = label * 10 + c - '0'; + label = label * 10 + ((unsigned char) c - '0'); label_locus = gfc_current_locus; digit_flag = 1; break; - /* Comments have already been skipped by the time we get + /* Comments have already been skipped by the time we get + here, except for OpenMP directives. */ + case '*': + if (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]); + + if (c != ' ' && c != '0') + { + gfc_buffer_error (0); + gfc_error ("Bad continuation line at %C"); + return ST_NONE; + } + + return decode_omp_directive (); + } + /* FALLTHROUGH */ + + /* Comments have already been skipped by the time we get here so don't bother checking for them. */ default: @@ -433,7 +755,7 @@ next_fixed (void) if (c == '\n') goto blank_line; - if (c != ' ' && c!= '0') + if (c != ' ' && c != '0') { gfc_buffer_error (0); gfc_error ("Bad continuation line at %C"); @@ -455,6 +777,12 @@ next_fixed (void) goto blank_line; gfc_current_locus = loc; + if (c == ';') + { + gfc_error_now ("Semicolon at %C needs to be preceded by statement"); + return ST_NONE; + } + if (gfc_match_eos () == MATCH_YES) goto blank_line; @@ -463,7 +791,7 @@ next_fixed (void) blank_line: if (digit_flag) - gfc_warning ("Statement label in blank line will be " "ignored at %C"); + gfc_warning ("Ignoring statement label in empty statement at %C"); gfc_advance_line (); return ST_NONE; } @@ -476,9 +804,10 @@ static gfc_statement next_statement (void) { gfc_statement st; - + locus old_locus; gfc_new_block = NULL; + gfc_current_ns->old_cl_list = gfc_current_ns->cl_list; for (;;) { gfc_statement_label = NULL; @@ -486,7 +815,8 @@ next_statement (void) if (gfc_at_eol ()) { - if (gfc_option.warn_line_truncation + if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE) + && gfc_current_locus.lb && gfc_current_locus.lb->truncated) gfc_warning_now ("Line truncated at %C"); @@ -501,8 +831,12 @@ next_statement (void) break; } - st = - (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free (); + if (gfc_define_undef_line ()) + continue; + + old_locus = gfc_current_locus; + + st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free (); if (st != ST_NONE) break; @@ -510,6 +844,13 @@ next_statement (void) gfc_buffer_error (0); + if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL) + { + gfc_free_st_label (gfc_statement_label); + gfc_statement_label = NULL; + gfc_current_locus = old_locus; + } + if (st != ST_NONE) check_statement_label (st); @@ -530,58 +871,61 @@ next_statement (void) case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \ case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \ case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \ - case ST_PAUSE: case ST_STOP: case ST_WRITE: case ST_ASSIGNMENT: \ + case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \ case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \ - case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ - case ST_LABEL_ASSIGNMENT: case ST_FLUSH + case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \ + case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \ + case ST_OMP_BARRIER: case ST_OMP_TASKWAIT /* Statements that mark other executable statements. */ #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \ - case ST_WHERE_BLOCK: case ST_SELECT_CASE + case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \ + case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \ + case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \ + case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \ + case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \ + case ST_OMP_TASK /* Declaration statements */ #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \ case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \ - case ST_TYPE: case ST_INTERFACE + case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \ + case ST_PROCEDURE /* Block end statements. Errors associated with interchanging these are detected in gfc_match_end(). */ #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \ - case ST_END_PROGRAM: case ST_END_SUBROUTINE + case ST_END_PROGRAM: case ST_END_SUBROUTINE /* Push a new state onto the stack. */ static void -push_state (gfc_state_data * p, gfc_compile_state new_state, gfc_symbol * sym) +push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym) { - p->state = new_state; p->previous = gfc_state_stack; p->sym = sym; p->head = p->tail = NULL; p->do_variable = NULL; - gfc_state_stack = p; } /* Pop the current state. */ - static void pop_state (void) { - gfc_state_stack = gfc_state_stack->previous; } /* Try to find the given state in the state stack. */ -try +gfc_try gfc_find_state (gfc_compile_state state) { gfc_state_data *p; @@ -597,7 +941,7 @@ gfc_find_state (gfc_compile_state state) /* Starts a new level in the statement list. */ static gfc_code * -new_level (gfc_code * q) +new_level (gfc_code *q) { gfc_code *p; @@ -684,8 +1028,8 @@ check_statement_label (gfc_statement st) break; /* Statement labels are not restricted from appearing on a - particular line. However, there are plenty of situations - where the resulting label can't be referenced. */ + particular line. However, there are plenty of situations + where the resulting label can't be referenced. */ default: type = ST_LABEL_BAD_TARGET; @@ -853,6 +1197,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; @@ -868,6 +1215,9 @@ gfc_ascii_statement (gfc_statement st) case ST_IMPLIED_ENDDO: p = _("implied END DO"); break; + case ST_IMPORT: + p = "IMPORT"; + break; case ST_INQUIRE: p = "INQUIRE"; break; @@ -904,6 +1254,9 @@ gfc_ascii_statement (gfc_statement st) case ST_PROGRAM: p = "PROGRAM"; break; + case ST_PROCEDURE: + p = "PROCEDURE"; + break; case ST_READ: p = "READ"; break; @@ -929,6 +1282,9 @@ gfc_ascii_statement (gfc_statement st) case ST_WHERE: p = "WHERE"; break; + case ST_WAIT: + p = "WAIT"; + break; case ST_WRITE: p = "WRITE"; break; @@ -962,6 +1318,96 @@ gfc_ascii_statement (gfc_statement st) case ST_END_ENUM: p = "END ENUM"; break; + case ST_OMP_ATOMIC: + p = "!$OMP ATOMIC"; + break; + case ST_OMP_BARRIER: + p = "!$OMP BARRIER"; + break; + case ST_OMP_CRITICAL: + p = "!$OMP CRITICAL"; + break; + case ST_OMP_DO: + p = "!$OMP DO"; + break; + case ST_OMP_END_CRITICAL: + p = "!$OMP END CRITICAL"; + break; + case ST_OMP_END_DO: + p = "!$OMP END DO"; + break; + case ST_OMP_END_MASTER: + p = "!$OMP END MASTER"; + break; + case ST_OMP_END_ORDERED: + p = "!$OMP END ORDERED"; + break; + case ST_OMP_END_PARALLEL: + p = "!$OMP END PARALLEL"; + break; + case ST_OMP_END_PARALLEL_DO: + p = "!$OMP END PARALLEL DO"; + break; + case ST_OMP_END_PARALLEL_SECTIONS: + p = "!$OMP END PARALLEL SECTIONS"; + break; + case ST_OMP_END_PARALLEL_WORKSHARE: + p = "!$OMP END PARALLEL WORKSHARE"; + break; + case ST_OMP_END_SECTIONS: + p = "!$OMP END SECTIONS"; + break; + case ST_OMP_END_SINGLE: + p = "!$OMP END SINGLE"; + break; + case ST_OMP_END_TASK: + p = "!$OMP END TASK"; + break; + case ST_OMP_END_WORKSHARE: + p = "!$OMP END WORKSHARE"; + break; + case ST_OMP_FLUSH: + p = "!$OMP FLUSH"; + break; + case ST_OMP_MASTER: + p = "!$OMP MASTER"; + break; + case ST_OMP_ORDERED: + p = "!$OMP ORDERED"; + break; + case ST_OMP_PARALLEL: + p = "!$OMP PARALLEL"; + break; + case ST_OMP_PARALLEL_DO: + p = "!$OMP PARALLEL DO"; + break; + case ST_OMP_PARALLEL_SECTIONS: + p = "!$OMP PARALLEL SECTIONS"; + break; + case ST_OMP_PARALLEL_WORKSHARE: + p = "!$OMP PARALLEL WORKSHARE"; + break; + case ST_OMP_SECTIONS: + p = "!$OMP SECTIONS"; + break; + case ST_OMP_SECTION: + p = "!$OMP SECTION"; + break; + case ST_OMP_SINGLE: + p = "!$OMP SINGLE"; + break; + case ST_OMP_TASK: + p = "!$OMP TASK"; + break; + case ST_OMP_TASKWAIT: + p = "!$OMP TASKWAIT"; + break; + case ST_OMP_THREADPRIVATE: + p = "!$OMP THREADPRIVATE"; + break; + case ST_OMP_WORKSHARE: + p = "!$OMP WORKSHARE"; + break; default: gfc_internal_error ("gfc_ascii_statement(): Bad statement code"); } @@ -970,12 +1416,33 @@ gfc_ascii_statement (gfc_statement st) } +/* Create a symbol for the main program and assign it to ns->proc_name. */ + +static void +main_program_symbol (gfc_namespace *ns, const char *name) +{ + gfc_symbol *main_program; + symbol_attribute attr; + + gfc_get_symbol (name, ns, &main_program); + gfc_clear_attr (&attr); + attr.flavor = FL_PROGRAM; + attr.proc = PROC_UNKNOWN; + attr.subroutine = 1; + attr.access = ACCESS_PUBLIC; + attr.is_main_program = 1; + main_program->attr = attr; + main_program->declared_at = gfc_current_locus; + ns->proc_name = main_program; + gfc_commit_symbols (); +} + + /* Do whatever is necessary to accept the last statement. */ static void accept_statement (gfc_statement st) { - switch (st) { case ST_USE: @@ -996,8 +1463,8 @@ accept_statement (gfc_statement st) break; /* 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. */ + that allows a branch to the end of the block from within the + construct. */ case ST_ENDIF: case ST_END_SELECT: @@ -1010,8 +1477,8 @@ accept_statement (gfc_statement st) break; /* The end-of-program unit statements do not get the special - marker and require a statement of some sort if they are a - branch target. */ + marker and require a statement of some sort if they are a + branch target. */ case ST_END_PROGRAM: case ST_END_FUNCTION: @@ -1046,7 +1513,11 @@ 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 (); undo_new_statement (); @@ -1059,7 +1530,6 @@ reject_statement (void) static void unexpected_statement (gfc_statement st) { - gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); reject_statement (); @@ -1072,39 +1542,41 @@ unexpected_statement (gfc_statement st) issue an error and return FAILURE. Otherwise we return SUCCESS. Individual parsers need to verify that the statements seen are - valid before calling here, ie ENTRY statements are not allowed in + valid before calling here, i.e., ENTRY statements are not allowed in INTERFACE blocks. The following diagram is taken from the standard: - +---------------------------------------+ - | program subroutine function module | - +---------------------------------------+ - | use | - |---------------------------------------+ - | | implicit none | - | +-----------+------------------+ - | | parameter | implicit | - | +-----------+------------------+ - | format | | derived type | - | entry | parameter | interface | - | | data | specification | - | | | statement func | - | +-----------+------------------+ - | | data | executable | - +--------+-----------+------------------+ - | contains | - +---------------------------------------+ - | internal module/subprogram | - +---------------------------------------+ - | end | - +---------------------------------------+ + +---------------------------------------+ + | program subroutine function module | + +---------------------------------------+ + | use | + +---------------------------------------+ + | import | + +---------------------------------------+ + | | implicit none | + | +-----------+------------------+ + | | parameter | implicit | + | +-----------+------------------+ + | format | | derived type | + | entry | parameter | interface | + | | data | specification | + | | | statement func | + | +-----------+------------------+ + | | data | executable | + +--------+-----------+------------------+ + | contains | + +---------------------------------------+ + | internal module/subprogram | + +---------------------------------------+ + | end | + +---------------------------------------+ */ typedef struct { enum - { ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT, - ORDER_SPEC, ORDER_EXEC + { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE, + ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC } state; gfc_statement last_statement; @@ -1112,8 +1584,8 @@ typedef struct } st_state; -static try -verify_st_order (st_state * p, gfc_statement st) +static gfc_try +verify_st_order (st_state *p, gfc_statement st, bool silent) { switch (st) @@ -1128,14 +1600,20 @@ verify_st_order (st_state * p, gfc_statement st) p->state = ORDER_USE; break; + case ST_IMPORT: + if (p->state > ORDER_IMPORT) + goto order; + p->state = ORDER_IMPORT; + break; + case ST_IMPLICIT_NONE: if (p->state > ORDER_IMPLICIT_NONE) goto order; - /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY - statement disqualifies a USE but not an IMPLICIT NONE. - Duplicate IMPLICIT NONEs are caught when the implicit types - are set. */ + /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY + statement disqualifies a USE but not an IMPLICIT NONE. + Duplicate IMPLICIT NONEs are caught when the implicit types + are set. */ p->state = ORDER_IMPLICIT_NONE; break; @@ -1181,9 +1659,8 @@ verify_st_order (st_state * p, gfc_statement st) break; default: - gfc_internal_error - ("Unexpected %s statement in verify_st_order() at %C", - gfc_ascii_statement (st)); + gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C", + gfc_ascii_statement (st)); } /* All is well, record the statement in case we need it next time. */ @@ -1192,9 +1669,10 @@ verify_st_order (st_state * p, gfc_statement st) return SUCCESS; order: - gfc_error ("%s statement at %C cannot follow %s statement at %L", - gfc_ascii_statement (st), - gfc_ascii_statement (p->last_statement), &p->where); + if (!silent) + gfc_error ("%s statement at %C cannot follow %s statement at %L", + gfc_ascii_statement (st), + gfc_ascii_statement (p->last_statement), &p->where); return FAILURE; } @@ -1222,6 +1700,143 @@ 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 @@ -1229,8 +1844,10 @@ parse_derived (void) { int compiling_type, seen_private, seen_sequence, seen_component, error_flag; gfc_statement st; - gfc_component *c; gfc_state_data s; + gfc_symbol *derived_sym = NULL; + gfc_symbol *sym; + gfc_component *c; error_flag = 0; @@ -1257,14 +1874,25 @@ parse_derived (void) seen_component = 1; break; + case ST_PROCEDURE: + gfc_error ("PROCEDURE binding at %C must be inside CONTAINS"); + error_flag = 1; + break; + + case ST_FINAL: + 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) - { - gfc_error ("Derived type definition at %C has no components"); - error_flag = 1; - } + if (!seen_component + && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type " + "definition at %C without components") + == FAILURE)) + error_flag = 1; accept_statement (ST_END_TYPE); break; @@ -1272,8 +1900,8 @@ parse_derived (void) case ST_PRIVATE: if (gfc_find_state (COMP_MODULE) == FAILURE) { - gfc_error - ("PRIVATE statement in TYPE at %C must be inside a MODULE"); + gfc_error ("PRIVATE statement in TYPE at %C must be inside " + "a MODULE"); error_flag = 1; break; } @@ -1293,6 +1921,7 @@ parse_derived (void) } s.sym->component_access = ACCESS_PRIVATE; + accept_statement (ST_PRIVATE); seen_private = 1; break; @@ -1321,31 +1950,64 @@ parse_derived (void) gfc_current_block ()->name, NULL); break; + case ST_CONTAINS: + if (gfc_notify_std (GFC_STD_F2003, + "Fortran 2003: CONTAINS block in derived type" + " definition at %C") == FAILURE) + error_flag = 1; + + accept_statement (ST_CONTAINS); + if (parse_derived_contains ()) + error_flag = 1; + goto endType; + default: unexpected_statement (st); break; } } - /* Sanity checks on the structure. If the structure has the - SEQUENCE attribute, then all component structures must also have - SEQUENCE. */ - if (error_flag == 0 && gfc_current_block ()->attr.sequence) - for (c = gfc_current_block ()->components; c; c = c->next) - { - if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0) - { - gfc_error - ("Component %s of SEQUENCE type declared at %C does not " - "have the SEQUENCE attribute", c->ts.derived->name); - } - } + /* need to verify that all fields of the derived type are + * interoperable with C if the type is declared to be bind(c) + */ + derived_sym = gfc_current_block(); + + sym = gfc_current_block (); + for (c = sym->components; c; c = c->next) + { + /* 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; + } + + /* 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; + } + + /* 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; + } + } + + if (!seen_component) + sym->attr.zero_comp = 1; pop_state (); } - /* Parse an ENUM. */ static void @@ -1367,35 +2029,36 @@ parse_enum (void) { st = next_statement (); switch (st) - { - case ST_NONE: - unexpected_eof (); - break; + { + case ST_NONE: + unexpected_eof (); + break; - case ST_ENUMERATOR: + case ST_ENUMERATOR: seen_enumerator = 1; - accept_statement (st); - break; + accept_statement (st); + break; - case ST_END_ENUM: - compiling_enum = 0; + case ST_END_ENUM: + compiling_enum = 0; if (!seen_enumerator) - { - gfc_error ("ENUM declaration at %C has no ENUMERATORS"); + { + gfc_error ("ENUM declaration at %C has no ENUMERATORS"); error_flag = 1; - } - accept_statement (st); - break; + } + accept_statement (st); + break; - default: - gfc_free_enum_history (); - unexpected_statement (st); - break; - } + default: + gfc_free_enum_history (); + unexpected_statement (st); + break; + } } pop_state (); } + /* Parse an interface. We must be able to deal with the possibility of recursive interfaces. The parse_spec() subroutine is mutually recursive with parse_interface(). */ @@ -1405,11 +2068,12 @@ 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; gfc_statement st; + locus proc_locus; accept_statement (ST_INTERFACE); @@ -1417,7 +2081,8 @@ parse_interface (void) save = current_interface; sym = (current_interface.type == INTERFACE_GENERIC - || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL; + || current_interface.type == INTERFACE_USER_OP) + ? gfc_new_block : NULL; push_state (&s1, COMP_INTERFACE, sym); current_state = COMP_NONE; @@ -1432,17 +2097,34 @@ loop: unexpected_eof (); case ST_SUBROUTINE: - new_state = COMP_SUBROUTINE; - gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, - gfc_new_block->formal, NULL); - break; - case ST_FUNCTION: - new_state = COMP_FUNCTION; - gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, - gfc_new_block->formal, NULL); + if (st == ST_SUBROUTINE) + new_state = COMP_SUBROUTINE; + else if (st == ST_FUNCTION) + new_state = COMP_FUNCTION; + if (gfc_new_block->attr.pointer) + { + gfc_new_block->attr.pointer = 0; + gfc_new_block->attr.proc_pointer = 1; + } + if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY, + gfc_new_block->formal, NULL) == FAILURE) + { + reject_statement (); + 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: case ST_MODULE_PROC: /* The module procedure matcher makes sure the context is correct. */ accept_statement (st); @@ -1481,27 +2163,49 @@ loop: if (new_state != current_state) { if (new_state == COMP_SUBROUTINE) - gfc_error - ("SUBROUTINE at %C does not belong in a generic function " - "interface"); + gfc_error ("SUBROUTINE at %C does not belong in a " + "generic function interface"); if (new_state == COMP_FUNCTION) - gfc_error - ("FUNCTION at %C does not belong in a generic subroutine " - "interface"); + gfc_error ("FUNCTION at %C does not belong in a " + "generic subroutine interface"); } } } + if (current_interface.type == INTERFACE_ABSTRACT) + { + 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", + gfc_new_block->name); + } + push_state (&s2, new_state, gfc_new_block); accept_statement (st); prog_unit = gfc_new_block; prog_unit->formal_ns = gfc_current_ns; + proc_locus = gfc_current_locus; decl: /* Read data declaration statements. */ st = parse_spec (ST_NONE); + /* Since the interface block does not permit an IMPLICIT statement, + the default type for the function or the result must be taken + from the formal namespace. */ + if (new_state == COMP_FUNCTION) + { + if (prog_unit->result == prog_unit + && prog_unit->ts.type == BT_UNKNOWN) + gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns); + else if (prog_unit->result != prog_unit + && prog_unit->result->ts.type == BT_UNKNOWN) + gfc_set_default_type (prog_unit->result, 1, + prog_unit->formal_ns); + } + if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION) { gfc_error ("Unexpected %s statement at %C in INTERFACE body", @@ -1512,8 +2216,15 @@ decl: current_interface = save; gfc_add_interface (prog_unit); - pop_state (); + + if (current_interface.ns + && current_interface.ns->proc_name + && strcmp (current_interface.ns->proc_name->name, + prog_unit->name) == 0) + gfc_error ("INTERFACE procedure '%s' at %L has the same name as the " + "enclosing procedure", prog_unit->name, &proc_locus); + goto loop; done: @@ -1521,6 +2232,74 @@ done: } +/* Associate function characteristics by going back to the function + declaration and rematching the prefix. */ + +static match +match_deferred_characteristics (gfc_typespec * ts) +{ + locus loc; + match m = MATCH_ERROR; + char name[GFC_MAX_SYMBOL_LEN + 1]; + + loc = gfc_current_locus; + + gfc_current_locus = gfc_current_block ()->declared_at; + + gfc_clear_error (); + gfc_buffer_error (1); + m = gfc_match_prefix (ts); + gfc_buffer_error (0); + + if (ts->type == BT_DERIVED) + { + ts->kind = 0; + + if (!ts->derived || !ts->derived->components) + m = MATCH_ERROR; + } + + /* Only permit one go at the characteristic association. */ + if (ts->kind == -1) + ts->kind = 0; + + /* Set the function locus correctly. If we have not found the + function name, there is an error. */ + 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 (); + } + else + gfc_error_check (); + + gfc_current_locus =loc; + return m; +} + + +/* Check specification-expressions in the function result of the currently + parsed block and ensure they are typed (give an IMPLICIT type if necessary). + For return types specified in a FUNCTION prefix, the IMPLICIT rules of the + scope are not yet parsed so this has to be delayed up to parse_spec. */ + +static void +check_function_result_typed (void) +{ + gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts; + + gcc_assert (gfc_current_state () == COMP_FUNCTION); + gcc_assert (ts->type != BT_UNKNOWN); + + /* 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); +} + + /* Parse a set of specification statements. Returns the statement that doesn't fit. */ @@ -1528,17 +2307,70 @@ static gfc_statement parse_spec (gfc_statement st) { st_state ss; + bool function_result_typed = false; + bool bad_characteristic = false; + gfc_typespec *ts; - verify_st_order (&ss, ST_NONE); + verify_st_order (&ss, ST_NONE, false); if (st == ST_NONE) st = next_statement (); + /* If we are not inside a function or don't have a result specified so far, + do nothing special about it. */ + if (gfc_current_state () != COMP_FUNCTION) + function_result_typed = true; + else + { + gfc_symbol* proc = gfc_current_ns->proc_name; + gcc_assert (proc); + + if (proc->result->ts.type == BT_UNKNOWN) + function_result_typed = true; + } + loop: + + /* If we find a statement that can not be followed by an IMPLICIT statement + (and thus we can expect to see none any further), type the function result + if it has not yet been typed. Be careful not to give the END statement + to verify_st_order! */ + if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS) + { + bool verify_now = false; + + if (st == ST_END_FUNCTION || st == ST_CONTAINS) + verify_now = true; + else + { + st_state dummyss; + verify_st_order (&dummyss, ST_NONE, false); + verify_st_order (&dummyss, st, false); + + if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE) + verify_now = true; + } + + if (verify_now) + { + check_function_result_typed (); + function_result_typed = true; + } + } + switch (st) { case ST_NONE: unexpected_eof (); + case ST_IMPLICIT_NONE: + case ST_IMPLICIT: + if (!function_result_typed) + { + check_function_result_typed (); + function_result_typed = true; + } + goto declSt; + case ST_FORMAT: case ST_ENTRY: case ST_DATA: /* Not allowed in interfaces */ @@ -1548,14 +2380,14 @@ loop: /* Fall through */ case ST_USE: - case ST_IMPLICIT_NONE: - case ST_IMPLICIT: + case ST_IMPORT: case ST_PARAMETER: case ST_PUBLIC: case ST_PRIVATE: case ST_DERIVED_DECL: case_decl: - if (verify_st_order (&ss, st) == FAILURE) +declSt: + if (verify_st_order (&ss, st, false) == FAILURE) { reject_statement (); st = next_statement (); @@ -1593,6 +2425,13 @@ loop: break; + case ST_STATEMENT_FUNCTION: + if (gfc_current_state () == COMP_MODULE) + { + unexpected_statement (st); + break; + } + default: break; } @@ -1607,10 +2446,39 @@ loop: st = next_statement (); goto loop; + case ST_GET_FCN_CHARACTERISTICS: + /* This statement triggers the association of a function's result + characteristics. */ + ts = &gfc_current_block ()->result->ts; + if (match_deferred_characteristics (ts) != MATCH_YES) + bad_characteristic = true; + + st = next_statement (); + goto loop; + default: break; } + /* If match_deferred_characteristics failed, then there is an error. */ + if (bad_characteristic) + { + ts = &gfc_current_block ()->result->ts; + if (ts->type != BT_DERIVED) + gfc_error ("Bad kind expression for function '%s' at %L", + gfc_current_block ()->name, + &gfc_current_block ()->declared_at); + else + gfc_error ("The type for function '%s' at %L is not accessible", + gfc_current_block ()->name, + &gfc_current_block ()->declared_at); + + 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)) + ts->type = BT_UNKNOWN; + } + return st; } @@ -1649,7 +2517,7 @@ parse_where_block (void) case ST_WHERE_BLOCK: parse_where_block (); - /* Fall through */ + break; case ST_ASSIGNMENT: case ST_WHERE: @@ -1659,9 +2527,8 @@ parse_where_block (void) case ST_ELSEWHERE: if (seen_empty_else) { - gfc_error - ("ELSEWHERE statement at %C follows previous unmasked " - "ELSEWHERE"); + gfc_error ("ELSEWHERE statement at %C follows previous " + "unmasked ELSEWHERE"); break; } @@ -1686,7 +2553,6 @@ parse_where_block (void) reject_statement (); break; } - } while (st != ST_END_WHERE); @@ -1792,9 +2658,8 @@ parse_if_block (void) case ST_ELSEIF: if (seen_else) { - gfc_error - ("ELSE IF statement at %C cannot follow ELSE statement at %L", - &else_locus); + gfc_error ("ELSE IF statement at %C cannot follow ELSE " + "statement at %L", &else_locus); reject_statement (); break; @@ -1872,9 +2737,8 @@ parse_select_block (void) if (st == ST_CASE) break; - gfc_error - ("Expected a CASE or END SELECT statement following SELECT CASE " - "at %C"); + gfc_error ("Expected a CASE or END SELECT statement following SELECT " + "CASE at %C"); reject_statement (); } @@ -1904,8 +2768,8 @@ parse_select_block (void) case ST_END_SELECT: break; - /* Can't have an executable statement because of - parse_executable(). */ + /* Can't have an executable statement because of + parse_executable(). */ default: unexpected_statement (st); break; @@ -1965,8 +2829,7 @@ check_do_closure (void) if (p == gfc_state_stack) return 1; - gfc_error - ("End of nonblock DO statement at %C is within another block"); + gfc_error ("End of nonblock DO statement at %C is within another block"); return 2; } @@ -2024,8 +2887,8 @@ loop: case ST_ENDDO: if (s.ext.end_do_label != NULL && s.ext.end_do_label != gfc_statement_label) - gfc_error_now - ("Statement label in ENDDO at %C doesn't match DO label"); + gfc_error_now ("Statement label in ENDDO at %C doesn't match " + "DO label"); if (gfc_statement_label != NULL) { @@ -2035,6 +2898,14 @@ loop: break; case ST_IMPLIED_ENDDO: + /* If the do-stmt of this DO construct has a do-construct-name, + the corresponding end-do must be an end-do-stmt (with a matching + 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_current_block()->declared_at); + break; default: @@ -2047,6 +2918,273 @@ loop: } +/* Parse the statements of OpenMP do/parallel do. */ + +static gfc_statement +parse_omp_do (gfc_statement omp_st) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (omp_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_DO) + break; + else + unexpected_statement (st); + } + + parse_do_block (); + if (gfc_statement_label != NULL + && gfc_state_stack->previous != NULL + && gfc_state_stack->previous->state == COMP_DO + && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label) + { + /* In + DO 100 I=1,10 + !$OMP DO + DO J=1,10 + ... + 100 CONTINUE + there should be no !$OMP END DO. */ + pop_state (); + return ST_IMPLIED_ENDDO; + } + + check_do_closure (); + pop_state (); + + st = next_statement (); + if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO)) + { + if (new_st.op == EXEC_OMP_END_NOWAIT) + cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; + else + gcc_assert (new_st.op == EXEC_NOP); + gfc_clear_new_st (); + gfc_commit_symbols (); + gfc_warning_check (); + st = next_statement (); + } + return st; +} + + +/* Parse the statements of OpenMP atomic directive. */ + +static void +parse_omp_atomic (void) +{ + gfc_statement st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (ST_OMP_ATOMIC); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + for (;;) + { + st = next_statement (); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_ASSIGNMENT) + break; + else + unexpected_statement (st); + } + + accept_statement (st); + + pop_state (); +} + + +/* Parse the statements of an OpenMP structured block. */ + +static void +parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) +{ + gfc_statement st, omp_end_st; + gfc_code *cp, *np; + gfc_state_data s; + + accept_statement (omp_st); + + cp = gfc_state_stack->tail; + push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL); + np = new_level (cp); + np->op = cp->op; + np->block = NULL; + + switch (omp_st) + { + case ST_OMP_PARALLEL: + omp_end_st = ST_OMP_END_PARALLEL; + break; + case ST_OMP_PARALLEL_SECTIONS: + omp_end_st = ST_OMP_END_PARALLEL_SECTIONS; + break; + case ST_OMP_SECTIONS: + omp_end_st = ST_OMP_END_SECTIONS; + break; + case ST_OMP_ORDERED: + omp_end_st = ST_OMP_END_ORDERED; + break; + case ST_OMP_CRITICAL: + omp_end_st = ST_OMP_END_CRITICAL; + break; + case ST_OMP_MASTER: + omp_end_st = ST_OMP_END_MASTER; + break; + case ST_OMP_SINGLE: + omp_end_st = ST_OMP_END_SINGLE; + break; + case ST_OMP_TASK: + omp_end_st = ST_OMP_END_TASK; + break; + case ST_OMP_WORKSHARE: + omp_end_st = ST_OMP_END_WORKSHARE; + break; + case ST_OMP_PARALLEL_WORKSHARE: + omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE; + break; + default: + gcc_unreachable (); + } + + do + { + if (workshare_stmts_only) + { + /* Inside of !$omp workshare, only + scalar assignments + array assignments + where statements and constructs + forall statements and constructs + !$omp atomic + !$omp critical + !$omp parallel + are allowed. For !$omp critical these + restrictions apply recursively. */ + bool cycle = true; + + st = next_statement (); + for (;;) + { + switch (st) + { + case ST_NONE: + unexpected_eof (); + + case ST_ASSIGNMENT: + case ST_WHERE: + case ST_FORALL: + accept_statement (st); + break; + + case ST_WHERE_BLOCK: + parse_where_block (); + break; + + case ST_FORALL_BLOCK: + parse_forall_block (); + break; + + case ST_OMP_PARALLEL: + case ST_OMP_PARALLEL_SECTIONS: + parse_omp_structured_block (st, false); + break; + + case ST_OMP_PARALLEL_WORKSHARE: + case ST_OMP_CRITICAL: + parse_omp_structured_block (st, true); + break; + + case ST_OMP_PARALLEL_DO: + st = parse_omp_do (st); + continue; + + case ST_OMP_ATOMIC: + parse_omp_atomic (); + break; + + default: + cycle = false; + break; + } + + if (!cycle) + break; + + st = next_statement (); + } + } + else + st = parse_executable (ST_NONE); + if (st == ST_NONE) + unexpected_eof (); + else if (st == ST_OMP_SECTION + && (omp_st == ST_OMP_SECTIONS + || omp_st == ST_OMP_PARALLEL_SECTIONS)) + { + np = new_level (np); + np->op = cp->op; + np->block = NULL; + } + else if (st != omp_end_st) + unexpected_statement (st); + } + while (st != omp_end_st); + + switch (new_st.op) + { + case EXEC_OMP_END_NOWAIT: + cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool; + break; + case EXEC_OMP_CRITICAL: + if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL)) + || (new_st.ext.omp_name != NULL + && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0)) + gfc_error ("Name after !$omp critical and !$omp end critical does " + "not match at %C"); + gfc_free (CONST_CAST (char *, new_st.ext.omp_name)); + break; + case EXEC_OMP_END_SINGLE: + cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] + = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]; + new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL; + gfc_free_omp_clauses (new_st.ext.omp_clauses); + break; + case EXEC_NOP: + break; + default: + gcc_unreachable (); + } + + gfc_clear_new_st (); + gfc_commit_symbols (); + gfc_warning_check (); + pop_state (); +} + + /* Accept a series of executable statements. We return the first statement that doesn't fit to the caller. Any block statements are passed on to the correct handler, which usually passes the buck @@ -2060,9 +3198,8 @@ parse_executable (gfc_statement st) if (st == ST_NONE) st = next_statement (); - for (;; st = next_statement ()) + for (;;) { - close_flag = check_do_closure (); if (close_flag) switch (st) @@ -2081,9 +3218,8 @@ parse_executable (gfc_statement st) case ST_FORALL: case ST_WHERE: case ST_SELECT_CASE: - gfc_error - ("%s statement at %C cannot terminate a non-block DO loop", - gfc_ascii_statement (st)); + gfc_error ("%s statement at %C cannot terminate a non-block " + "DO loop", gfc_ascii_statement (st)); break; default: @@ -2102,38 +3238,63 @@ parse_executable (gfc_statement st) accept_statement (st); if (close_flag == 1) return ST_IMPLIED_ENDDO; - continue; + break; case ST_IF_BLOCK: parse_if_block (); - continue; + break; case ST_SELECT_CASE: parse_select_block (); - continue; + break; case ST_DO: parse_do_block (); if (check_do_closure () == 1) return ST_IMPLIED_ENDDO; - continue; + break; case ST_WHERE_BLOCK: parse_where_block (); - continue; + break; case ST_FORALL_BLOCK: parse_forall_block (); + break; + + case ST_OMP_PARALLEL: + case ST_OMP_PARALLEL_SECTIONS: + case ST_OMP_SECTIONS: + case ST_OMP_ORDERED: + case ST_OMP_CRITICAL: + case ST_OMP_MASTER: + case ST_OMP_SINGLE: + case ST_OMP_TASK: + parse_omp_structured_block (st, false); + break; + + case ST_OMP_WORKSHARE: + case ST_OMP_PARALLEL_WORKSHARE: + parse_omp_structured_block (st, true); + break; + + case ST_OMP_DO: + case ST_OMP_PARALLEL_DO: + st = parse_omp_do (st); + if (st == ST_IMPLIED_ENDDO) + return st; continue; - default: + case ST_OMP_ATOMIC: + parse_omp_atomic (); break; + + default: + return st; } - break; + st = next_statement (); } - - return st; } @@ -2146,7 +3307,7 @@ static void parse_progunit (gfc_statement); the child namespace as the parser didn't know about this procedure. */ static void -gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings) +gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) { gfc_namespace *ns; gfc_symtree *st; @@ -2156,25 +3317,43 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings) for (ns = siblings; ns; ns = ns->sibling) { gfc_find_sym_tree (sym->name, ns, 0, &st); - if (!st) - continue; + + if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) + goto fixup_contained; old_sym = st->n.sym; - if ((old_sym->attr.flavor == FL_PROCEDURE - || old_sym->ts.type == BT_UNKNOWN) - && old_sym->ns == ns - && ! old_sym->attr.contained) - { - /* Replace it with the symbol from the parent namespace. */ - st->n.sym = sym; - sym->refs++; - - /* Free the old (local) symbol. */ - old_sym->refs--; - if (old_sym->refs == 0) - gfc_free_symbol (old_sym); - } + if (old_sym->ns == ns + && !old_sym->attr.contained + + /* By 14.6.1.3, host association should be excluded + for the following. */ + && !(old_sym->attr.external + || (old_sym->ts.type != BT_UNKNOWN + && !old_sym->attr.implicit_type) + || old_sym->attr.flavor == FL_PARAMETER + || old_sym->attr.in_common + || old_sym->attr.in_equivalence + || old_sym->attr.data + || old_sym->attr.dummy + || old_sym->attr.result + || old_sym->attr.dimension + || old_sym->attr.allocatable + || old_sym->attr.intrinsic + || old_sym->attr.generic + || old_sym->attr.flavor == FL_NAMELIST + || old_sym->attr.proc == PROC_ST_FUNCTION)) + { + /* Replace it with the symbol from the parent namespace. */ + st->n.sym = sym; + sym->refs++; + + /* Free the old (local) symbol. */ + old_sym->refs--; + if (old_sym->refs == 0) + gfc_free_symbol (old_sym); + } +fixup_contained: /* Do the same for any contained procedures. */ gfc_fixup_sibling_symbols (sym, ns->contained); } @@ -2183,11 +3362,13 @@ gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings) static void parse_contained (int module) { - gfc_namespace *ns, *parent_ns; + gfc_namespace *ns, *parent_ns, *tmp; gfc_state_data s1, s2; gfc_statement st; gfc_symbol *sym; gfc_entry_list *el; + int contains_statements = 0; + int seen_error = 0; push_state (&s1, COMP_CONTAINS, NULL); parent_ns = gfc_current_ns; @@ -2199,6 +3380,9 @@ parse_contained (int module) gfc_current_ns->sibling = parent_ns->contained; parent_ns->contained = gfc_current_ns; + next: + /* Process the next available statement. We come here if we got an error + and rejected the last statement. */ st = next_statement (); switch (st) @@ -2208,6 +3392,7 @@ parse_contained (int module) case ST_FUNCTION: case ST_SUBROUTINE: + contains_statements = 1; accept_statement (st); push_state (&s2, @@ -2220,9 +3405,8 @@ parse_contained (int module) if (!module) { if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym)) - gfc_error - ("Contained procedure '%s' at %C is already ambiguous", - gfc_new_block->name); + gfc_error ("Contained procedure '%s' at %C is already " + "ambiguous", gfc_new_block->name); else { if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name, @@ -2240,18 +3424,18 @@ parse_contained (int module) gfc_commit_symbols (); } - else - sym = gfc_new_block; + else + sym = gfc_new_block; - /* Mark this as a contained function, so it isn't replaced - by other module functions. */ - sym->attr.contained = 1; + /* Mark this as a contained function, so it isn't replaced + by other module functions. */ + sym->attr.contained = 1; sym->attr.referenced = 1; parse_progunit (ST_NONE); - /* Fix up any sibling functions that refer to this one. */ - gfc_fixup_sibling_symbols (sym, gfc_current_ns); + /* Fix up any sibling functions that refer to this one. */ + gfc_fixup_sibling_symbols (sym, gfc_current_ns); /* Or refer to any of its alternate entry points. */ for (el = gfc_current_ns->entries; el; el = el->next) gfc_fixup_sibling_symbols (el->sym, gfc_current_ns); @@ -2262,8 +3446,7 @@ parse_contained (int module) pop_state (); break; - /* These statements are associated with the end of the host - unit. */ + /* These statements are associated with the end of the host unit. */ case ST_END_FUNCTION: case ST_END_MODULE: case ST_END_PROGRAM: @@ -2275,6 +3458,8 @@ parse_contained (int module) gfc_error ("Unexpected %s statement in CONTAINS section at %C", gfc_ascii_statement (st)); reject_statement (); + seen_error = 1; + goto next; break; } } @@ -2283,14 +3468,19 @@ parse_contained (int module) /* The first namespace in the list is guaranteed to not have anything (worthwhile) in it. */ - + tmp = gfc_current_ns; gfc_current_ns = parent_ns; + if (seen_error && tmp->refs > 1) + gfc_free_namespace (tmp); ns = gfc_current_ns->contained; gfc_current_ns->contained = ns->sibling; gfc_free_namespace (ns); pop_state (); + if (!contains_statements) + gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without " + "FUNCTION or SUBROUTINE statement at %C"); } @@ -2319,6 +3509,9 @@ parse_progunit (gfc_statement st) break; } + if (gfc_current_state () == COMP_FUNCTION) + gfc_check_function_type (gfc_current_ns); + loop: for (;;) { @@ -2373,8 +3566,8 @@ done: /* Come here to complain about a global symbol already in use as something else. */ -static void -global_used (gfc_gsymbol *sym, locus *where) +void +gfc_global_used (gfc_gsymbol *sym, locus *where) { const char *name; @@ -2402,12 +3595,12 @@ global_used (gfc_gsymbol *sym, locus *where) name = "MODULE"; break; default: - gfc_internal_error ("gfc_gsymbol_type(): Bad type"); + gfc_internal_error ("gfc_global_used(): Bad type"); name = NULL; } gfc_error("Global name '%s' at %L is already being used as a %s at %L", - gfc_new_block->name, where, name, &sym->where); + sym->name, where, name, &sym->where); } @@ -2428,22 +3621,24 @@ parse_block_data (void) { if (blank_block) gfc_error ("Blank BLOCK DATA at %C conflicts with " - "prior BLOCK DATA at %L", &blank_locus); + "prior BLOCK DATA at %L", &blank_locus); else { - blank_block = 1; - blank_locus = gfc_current_locus; + blank_block = 1; + blank_locus = gfc_current_locus; } } else { s = gfc_get_gsymbol (gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) - global_used(s, NULL); + if (s->defined + || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) + gfc_global_used(s, NULL); else { - s->type = GSYM_BLOCK_DATA; - s->where = gfc_current_locus; + s->type = GSYM_BLOCK_DATA; + s->where = gfc_current_locus; + s->defined = 1; } } @@ -2468,12 +3663,13 @@ parse_module (void) gfc_gsymbol *s; s = gfc_get_gsymbol (gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) - global_used(s, NULL); + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE)) + gfc_global_used(s, NULL); else { s->type = GSYM_MODULE; s->where = gfc_current_locus; + s->defined = 1; } st = parse_spec (ST_NONE); @@ -2512,12 +3708,15 @@ add_global_procedure (int sub) s = gfc_get_gsymbol(gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) - global_used(s, NULL); + if (s->defined + || (s->type != GSYM_UNKNOWN + && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) + gfc_global_used(s, NULL); else { s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; s->where = gfc_current_locus; + s->defined = 1; } } @@ -2533,19 +3732,20 @@ add_global_program (void) return; s = gfc_get_gsymbol (gfc_new_block->name); - if (s->type != GSYM_UNKNOWN) - global_used(s, NULL); + if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM)) + gfc_global_used(s, NULL); else { s->type = GSYM_PROGRAM; s->where = gfc_current_locus; + s->defined = 1; } } /* Top level parser. */ -try +gfc_try gfc_parse_file (void) { int seen_program, errors_before, errors; @@ -2553,6 +3753,8 @@ gfc_parse_file (void) gfc_statement st; locus prog_locus; + gfc_start_source_files (); + top.state = COMP_NONE; top.sym = NULL; top.previous = NULL; @@ -2590,6 +3792,7 @@ loop: prog_locus = gfc_current_locus; push_state (&s, COMP_PROGRAM, gfc_new_block); + main_program_symbol(gfc_current_ns, gfc_new_block->name); accept_statement (st); add_global_program (); parse_progunit (ST_NONE); @@ -2631,6 +3834,7 @@ loop: prog_locus = gfc_current_locus; push_state (&s, COMP_PROGRAM, gfc_new_block); + main_program_symbol (gfc_current_ns, "MAIN__"); parse_progunit (st); break; } @@ -2640,19 +3844,19 @@ loop: gfc_resolve (gfc_current_ns); /* Dump the parse tree if requested. */ - if (gfc_option.verbose) - gfc_show_namespace (gfc_current_ns); + if (gfc_option.dump_parse_tree) + gfc_dump_parse_tree (gfc_current_ns, stdout); gfc_get_errors (NULL, &errors); if (s.state == COMP_MODULE) { gfc_dump_module (s.sym->name, errors_before == errors); - if (errors == 0 && ! gfc_option.flag_no_backend) + if (errors == 0) gfc_generate_module_code (gfc_current_ns); } else { - if (errors == 0 && ! gfc_option.flag_no_backend) + if (errors == 0) gfc_generate_code (gfc_current_ns); } @@ -2661,11 +3865,12 @@ loop: goto loop; done: + gfc_end_source_files (); return SUCCESS; duplicate_main: /* If we see a duplicate main program, shut down. If the second - instance is an implied main program, ie data decls or executable + instance is an implied main program, i.e. data decls or executable statements, we're in for lots of errors. */ gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus); reject_statement ();