X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;ds=sidebyside;f=gcc%2Ffortran%2Fparse.c;h=2552fcd67886520288b2eb40dfeade6c15eccfa9;hb=eeebe20ba63ca092de5e2d4575b5765dd88a7ce6;hp=5fb9ce12457d035d4f5be7025c00791c370bd234;hpb=4ccfeca17118c11267f85c40cc38497ab6aeb094;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 5fb9ce12457..2552fcd6788 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1,13 +1,14 @@ /* Main parser. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, - Inc. + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, + 2009 + 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 +17,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 +26,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 +43,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 +51,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 +79,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 +239,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 +258,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 +316,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 +331,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 +367,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 +381,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 +409,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 +434,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; } @@ -304,7 +465,7 @@ static gfc_statement decode_omp_directive (void) { locus old_locus; - int c; + char c; #ifdef GFC_DEBUG gfc_symbol_state (); @@ -315,7 +476,8 @@ decode_omp_directive (void) if (gfc_pure (NULL)) { - gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures"); + gfc_error_now ("OpenMP directives at %C may not appear in PURE " + "or ELEMENTAL procedures"); gfc_error_recovery (); return ST_NONE; } @@ -326,7 +488,7 @@ decode_omp_directive (void) statement, we eliminate most possibilities by peeking at the first character. */ - c = gfc_peek_char (); + c = gfc_peek_ascii_char (); switch (c) { @@ -355,6 +517,7 @@ decode_omp_directive (void) 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; @@ -381,6 +544,8 @@ decode_omp_directive (void) 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': @@ -401,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 @@ -410,35 +603,40 @@ static gfc_statement next_free (void) { match m; - int c, d, cnt; + 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); - d = gfc_peek_char (); + d = gfc_peek_ascii_char (); if (m != MATCH_YES || !gfc_is_whitespace (d)) { - gfc_match_small_literal_int (&c, &cnt); + gfc_match_small_literal_int (&i, &cnt); - if (cnt > 5) + if (cnt > 5) gfc_error_now ("Too many digits in statement label at %C"); - if (c == 0) + if (i == 0) gfc_error_now ("Zero is not a valid statement label at %C"); do - c = gfc_next_char (); + 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 { @@ -446,10 +644,18 @@ next_free (void) gfc_gobble_whitespace (); + if (at_bol && gfc_peek_ascii_char () == ';') + { + gfc_error_now ("Semicolon at %C needs to be preceded by " + "statement"); + gfc_next_ascii_char (); /* Eat up the semicolon. */ + return ST_NONE; + } + 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; @@ -459,18 +665,44 @@ 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_char (); - for (i = 0; i < 5; i++, c = gfc_next_char ()) - gcc_assert (c == "!$omp"[i]); + c = gfc_next_ascii_char (); + for (i = 0; i < 4; i++, c = gfc_next_ascii_char ()) + gcc_assert (c == "gcc$"[i]); - gcc_assert (c == ' '); + 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 < 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"); + gfc_next_ascii_char (); /* Eat up the semicolon. */ + return ST_NONE; } return decode_statement (); @@ -484,7 +716,7 @@ next_fixed (void) { int label, digit_flag, i; locus loc; - char c; + gfc_char_t c; if (!gfc_at_bol ()) return decode_statement (); @@ -517,18 +749,28 @@ 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 - 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 < 5; i++, c = gfc_next_char_literal (0)) - gcc_assert (TOLOWER (c) == "*$omp"[i]); + 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 < 4; i++, c = gfc_next_char_literal (0)) + gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]); if (c != ' ' && c != '0') { @@ -570,7 +812,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"); @@ -592,6 +834,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; @@ -613,9 +861,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; @@ -623,7 +872,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"); @@ -638,8 +888,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; @@ -647,6 +901,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); @@ -667,11 +928,11 @@ 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_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_BARRIER: case ST_OMP_TASKWAIT /* Statements that mark other executable statements. */ @@ -680,50 +941,48 @@ next_statement (void) 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_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_OMP_THREADPRIVATE + 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; @@ -739,7 +998,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; @@ -826,8 +1085,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; @@ -995,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; @@ -1010,6 +1272,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; @@ -1046,6 +1311,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; @@ -1071,6 +1339,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; @@ -1146,6 +1417,9 @@ gfc_ascii_statement (gfc_statement st) 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; @@ -1179,6 +1453,12 @@ gfc_ascii_statement (gfc_statement st) 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; @@ -1196,14 +1476,14 @@ 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) +main_program_symbol (gfc_namespace *ns, const char *name) { gfc_symbol *main_program; symbol_attribute attr; - gfc_get_symbol ("MAIN__", ns, &main_program); + gfc_get_symbol (name, ns, &main_program); gfc_clear_attr (&attr); - attr.flavor = FL_PROCEDURE; + attr.flavor = FL_PROGRAM; attr.proc = PROC_UNKNOWN; attr.subroutine = 1; attr.access = ACCESS_PUBLIC; @@ -1220,7 +1500,6 @@ main_program_symbol (gfc_namespace * ns) static void accept_statement (gfc_statement st) { - switch (st) { case ST_USE: @@ -1241,22 +1520,29 @@ 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. 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 - 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: @@ -1266,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; @@ -1291,7 +1582,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 (); @@ -1304,7 +1599,6 @@ reject_statement (void) static void unexpected_statement (gfc_statement st) { - gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st)); reject_statement (); @@ -1317,48 +1611,57 @@ 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 | + +---------------------------------------+ */ +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_IMPLICIT_NONE, ORDER_IMPLICIT, - ORDER_SPEC, ORDER_EXEC - } - state; + enum state_order state; gfc_statement last_statement; locus where; } 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) @@ -1373,14 +1676,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; @@ -1426,9 +1735,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. */ @@ -1437,9 +1745,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; } @@ -1467,6 +1776,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 @@ -1474,8 +1920,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; @@ -1498,18 +1946,25 @@ parse_derived (void) unexpected_eof (); case ST_DATA_DECL: + case ST_PROCEDURE: accept_statement (st); seen_component = 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; @@ -1517,8 +1972,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; } @@ -1538,6 +1993,7 @@ parse_derived (void) } s.sym->component_access = ACCESS_PRIVATE; + accept_statement (ST_PRIVATE); seen_private = 1; break; @@ -1566,31 +2022,61 @@ 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.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.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.u.derived->attr.private_comp)) + sym->attr.private_comp = 1; + } + + if (!seen_component) + sym->attr.zero_comp = 1; pop_state (); } - /* Parse an ENUM. */ static void @@ -1612,35 +2098,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(). */ @@ -1650,11 +2137,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); @@ -1662,7 +2150,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; @@ -1677,17 +2166,26 @@ 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; + } break; + case ST_PROCEDURE: case ST_MODULE_PROC: /* The module procedure matcher makes sure the context is correct. */ accept_statement (st); @@ -1726,27 +2224,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", @@ -1755,10 +2275,21 @@ 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 (); + + 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: @@ -1766,6 +2297,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->u.derived || !ts->u.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->u.cl && ts->u.cl->length) + gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true); +} + + /* Parse a set of specification statements. Returns the statement that doesn't fit. */ @@ -1773,17 +2372,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 */ @@ -1793,14 +2445,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 (); @@ -1838,6 +2490,13 @@ loop: break; + case ST_STATEMENT_FUNCTION: + if (gfc_current_state () == COMP_MODULE) + { + unexpected_statement (st); + break; + } + default: break; } @@ -1852,10 +2511,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->u.derived)) + ts->type = BT_UNKNOWN; + } + return st; } @@ -1876,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; @@ -1894,7 +2582,7 @@ parse_where_block (void) case ST_WHERE_BLOCK: parse_where_block (); - break; + break; case ST_ASSIGNMENT: case ST_WHERE: @@ -1904,18 +2592,17 @@ 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; } - 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); @@ -1931,7 +2618,6 @@ parse_where_block (void) reject_statement (); break; } - } while (st != ST_END_WHERE); @@ -2021,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 @@ -2037,9 +2723,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; @@ -2047,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); @@ -2117,9 +2802,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 (); } @@ -2149,8 +2833,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; @@ -2206,12 +2890,10 @@ check_do_closure (void) if (p->ext.end_do_label == gfc_statement_label) { - 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; } @@ -2241,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; @@ -2269,8 +2951,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) { @@ -2280,6 +2962,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: @@ -2327,12 +3017,12 @@ parse_omp_do (gfc_statement omp_st) && 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. */ + 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; } @@ -2430,6 +3120,9 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) 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; @@ -2533,9 +3226,9 @@ parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only) 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 ((char *) new_st.ext.omp_name); + 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] @@ -2589,9 +3282,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: @@ -2641,6 +3333,7 @@ parse_executable (gfc_statement st) case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: + case ST_OMP_TASK: parse_omp_structured_block (st, false); break; @@ -2678,7 +3371,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; @@ -2687,26 +3380,44 @@ 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); - if (!st) - continue; + st = gfc_find_symtree (ns->sym_root, sym->name); + + 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); } @@ -2715,11 +3426,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; @@ -2731,6 +3444,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) @@ -2740,6 +3456,7 @@ parse_contained (int module) case ST_FUNCTION: case ST_SUBROUTINE: + contains_statements = 1; accept_statement (st); push_state (&s2, @@ -2752,9 +3469,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, @@ -2772,18 +3488,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); @@ -2794,8 +3510,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: @@ -2807,6 +3522,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; } } @@ -2815,14 +3532,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"); } @@ -2851,6 +3573,9 @@ parse_progunit (gfc_statement st) break; } + if (gfc_current_state () == COMP_FUNCTION) + gfc_check_function_type (gfc_current_ns); + loop: for (;;) { @@ -2906,7 +3631,7 @@ done: something else. */ void -global_used (gfc_gsymbol *sym, locus *where) +gfc_global_used (gfc_gsymbol *sym, locus *where) { const char *name; @@ -2934,7 +3659,7 @@ 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; } @@ -2960,22 +3685,23 @@ 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->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) - 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; } } @@ -3002,7 +3728,7 @@ parse_module (void) s = gfc_get_gsymbol (gfc_new_block->name); if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE)) - global_used(s, NULL); + gfc_global_used(s, NULL); else { s->type = GSYM_MODULE; @@ -3034,6 +3760,8 @@ loop: st = next_statement (); goto loop; } + + s->ns = gfc_current_ns; } @@ -3047,13 +3775,15 @@ add_global_procedure (int sub) s = gfc_get_gsymbol(gfc_new_block->name); if (s->defined - || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) - global_used(s, NULL); + || (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; + s->ns = gfc_current_ns; } } @@ -3070,25 +3800,99 @@ add_global_program (void) s = gfc_get_gsymbol (gfc_new_block->name); if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM)) - global_used(s, NULL); + gfc_global_used(s, NULL); else { 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. */ -try +gfc_try gfc_parse_file (void) { int seen_program, errors_before, errors; gfc_state_data top, s; gfc_statement st; locus prog_locus; + gfc_namespace *next; + + gfc_start_source_files (); top.state = COMP_NONE; top.sym = NULL; @@ -3105,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. */ @@ -3127,10 +3935,12 @@ loop: prog_locus = gfc_current_locus; push_state (&s, COMP_PROGRAM, gfc_new_block); - main_program_symbol(gfc_current_ns); + main_program_symbol(gfc_current_ns, gfc_new_block->name); accept_statement (st); add_global_program (); parse_progunit (ST_NONE); + if (gfc_option.flag_whole_file) + goto prog_units; break; case ST_SUBROUTINE: @@ -3138,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: @@ -3145,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: @@ -3169,42 +3983,92 @@ loop: prog_locus = gfc_current_locus; push_state (&s, COMP_PROGRAM, gfc_new_block); - main_program_symbol(gfc_current_ns); + 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); /* 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); + 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_option.flag_no_backend) + 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; 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 ();