X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Ffortran%2Fparse.c;h=3e86a43d0b13f4383c002c1be2ce2ef5ed528ed4;hb=88087e898a921f4adeb8e5612f521e8b47e4587d;hp=14acb862144072a9dacd6677ca9ec5fd83dad4eb;hpb=f2bb610fe8816fb0d5ab5476e322dc2a21e72578;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/fortran/parse.c b/gcc/fortran/parse.c index 14acb862144..3e86a43d0b1 100644 --- a/gcc/fortran/parse.c +++ b/gcc/fortran/parse.c @@ -1,5 +1,5 @@ /* Main parser. - Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 + Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 Free Software Foundation, Inc. Contributed by Andy Vaught @@ -85,13 +85,151 @@ match_word (const char *str, match (*subr) (void), locus *old_locus) 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 (); @@ -100,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 @@ -113,6 +257,7 @@ 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; @@ -122,6 +267,8 @@ decode_statement (void) 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. */ @@ -168,7 +315,7 @@ 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) { @@ -219,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; @@ -293,6 +442,7 @@ decode_statement (void) break; case 'w': + match ("wait", gfc_match_wait, ST_WAIT); match ("write", gfc_match_write, ST_WRITE); break; } @@ -314,7 +464,7 @@ static gfc_statement decode_omp_directive (void) { locus old_locus; - int c; + char c; #ifdef GFC_DEBUG gfc_symbol_state (); @@ -337,7 +487,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) { @@ -366,6 +516,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; @@ -392,6 +543,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': @@ -421,31 +574,34 @@ static gfc_statement next_free (void) { match m; - int c, d, cnt, at_bol; + 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) 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)) @@ -459,11 +615,11 @@ next_free (void) gfc_gobble_whitespace (); - if (at_bol && gfc_peek_char () == ';') + if (at_bol && gfc_peek_ascii_char () == ';') { gfc_error_now ("Semicolon at %C needs to be preceded by " "statement"); - gfc_next_char (); /* Eat up the semicolon. */ + gfc_next_ascii_char (); /* Eat up the semicolon. */ return ST_NONE; } @@ -485,11 +641,11 @@ next_free (void) { int i; - c = gfc_next_char (); - for (i = 0; i < 5; i++, c = gfc_next_char ()) + c = gfc_next_ascii_char (); + for (i = 0; i < 5; i++, c = gfc_next_ascii_char ()) gcc_assert (c == "!$omp"[i]); - gcc_assert (c == ' '); + gcc_assert (c == ' ' || c == '\t'); gfc_gobble_whitespace (); return decode_omp_directive (); } @@ -498,7 +654,7 @@ next_free (void) if (at_bol && c == ';') { gfc_error_now ("Semicolon at %C needs to be preceded by statement"); - gfc_next_char (); /* Eat up the semicolon. */ + gfc_next_ascii_char (); /* Eat up the semicolon. */ return ST_NONE; } @@ -513,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 (); @@ -546,7 +702,7 @@ 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; @@ -557,7 +713,7 @@ next_fixed (void) if (gfc_option.flag_openmp) { for (i = 0; i < 5; i++, c = gfc_next_char_literal (0)) - gcc_assert (TOLOWER (c) == "*$omp"[i]); + gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]); if (c != ' ' && c != '0') { @@ -648,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; @@ -677,6 +834,8 @@ next_statement (void) 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) @@ -685,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); @@ -705,11 +871,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. */ @@ -718,7 +884,8 @@ 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 */ @@ -758,7 +925,7 @@ pop_state (void) /* Try to find the given state in the state stack. */ -try +gfc_try gfc_find_state (gfc_compile_state state) { gfc_state_data *p; @@ -1030,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; @@ -1112,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; @@ -1187,6 +1360,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; @@ -1220,6 +1396,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; @@ -1237,14 +1419,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; @@ -1331,6 +1513,10 @@ accept_statement (gfc_statement st) static void reject_statement (void) { + /* Revert to the previous charlen chain. */ + gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list); + gfc_current_ns->cl_list = gfc_current_ns->old_cl_list; + gfc_new_block = NULL; gfc_undo_symbols (); gfc_clear_warning (); @@ -1356,7 +1542,7 @@ 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: +---------------------------------------+ @@ -1398,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) @@ -1483,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; } @@ -1513,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 @@ -1546,17 +1870,27 @@ parse_derived (void) unexpected_eof (); case ST_DATA_DECL: - case ST_PROCEDURE: accept_statement (st); 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_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type " - "definition at %C without components") + "definition at %C without components") == FAILURE)) error_flag = 1; @@ -1587,6 +1921,7 @@ parse_derived (void) } s.sym->component_access = ACCESS_PRIVATE; + accept_statement (ST_PRIVATE); seen_private = 1; break; @@ -1615,6 +1950,17 @@ 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; @@ -1630,7 +1976,7 @@ parse_derived (void) for (c = sym->components; c; c = c->next) { /* Look for allocatable components. */ - if (c->allocatable + if (c->attr.allocatable || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp)) { sym->attr.alloc_comp = 1; @@ -1638,7 +1984,7 @@ parse_derived (void) } /* Look for pointer components. */ - if (c->pointer + if (c->attr.pointer || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp)) { sym->attr.pointer_comp = 1; @@ -1647,7 +1993,7 @@ parse_derived (void) /* Look for private components. */ if (sym->component_access == ACCESS_PRIVATE - || c->access == ACCESS_PRIVATE + || c->attr.access == ACCESS_PRIVATE || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp)) { sym->attr.private_comp = 1; @@ -1722,7 +2068,7 @@ static gfc_statement parse_spec (gfc_statement); static void parse_interface (void) { - gfc_compile_state new_state, current_state; + gfc_compile_state new_state = COMP_NONE, current_state; gfc_symbol *prog_unit, *sym; gfc_interface_info save; gfc_state_data s1, s2; @@ -1751,15 +2097,31 @@ 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: @@ -1813,7 +2175,7 @@ loop: if (current_interface.type == INTERFACE_ABSTRACT) { - gfc_new_block->attr.abstract = 1; + gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus); if (gfc_is_intrinsic_typename (gfc_new_block->name)) gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C " "cannot be the same as an intrinsic type", @@ -1870,35 +2232,74 @@ done: } -/* Recover use associated or imported function characteristics. */ +/* Associate function characteristics by going back to the function + declaration and rematching the prefix. */ -static try +static match match_deferred_characteristics (gfc_typespec * ts) { locus loc; - match m; + match m = MATCH_ERROR; + char name[GFC_MAX_SYMBOL_LEN + 1]; loc = gfc_current_locus; - if (gfc_current_block ()->ts.type != BT_UNKNOWN) + 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) { - /* Kind expression for an intrinsic type. */ - gfc_current_locus = gfc_function_kind_locus; - m = gfc_match_kind_spec (ts, true); + ts->kind = 0; + + if (!ts->derived || !ts->derived->components) + m = MATCH_ERROR; } - else + + /* 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) { - /* A derived type. */ - gfc_current_locus = gfc_function_type_locus; - m = gfc_match_type_spec (ts, 0); + gfc_current_block ()->declared_at = gfc_current_locus; + gfc_commit_symbols (); } + else + gfc_error_check (); - gfc_current_ns->proc_name->result->ts = *ts; 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. */ @@ -1906,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 */ @@ -1927,14 +2381,13 @@ loop: case ST_USE: case ST_IMPORT: - case ST_IMPLICIT_NONE: - case ST_IMPLICIT: 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 (); @@ -1984,15 +2437,6 @@ loop: } accept_statement (st); - - /* Look out for function kind/type information that used - use associated or imported parameter. This is signalled - by kind = -1. */ - if (gfc_current_state () == COMP_FUNCTION - && (st == ST_USE || st == ST_IMPORT || st == ST_DERIVED_DECL) - && gfc_current_block ()->ts.kind == -1) - match_deferred_characteristics (&gfc_current_block ()->ts); - st = next_statement (); goto loop; @@ -2002,21 +2446,37 @@ 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 we still have kind = -1 at the end of the specification block, - then there is an error. */ - if (gfc_current_state () == COMP_FUNCTION - && gfc_current_block ()->ts.kind == -1) + /* If match_deferred_characteristics failed, then there is an error. */ + if (bad_characteristic) { - if (gfc_current_block ()->ts.type != BT_UNKNOWN) + 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_function_kind_locus); + 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_function_type_locus); + 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; @@ -2596,6 +3056,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; @@ -2806,6 +3269,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; @@ -2855,14 +3319,29 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) gfc_find_sym_tree (sym->name, ns, 0, &st); if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns)) - continue; + 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 - && old_sym->attr.flavor != FL_NAMELIST) + 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; @@ -2874,6 +3353,7 @@ gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings) gfc_free_symbol (old_sym); } +fixup_contained: /* Do the same for any contained procedures. */ gfc_fixup_sibling_symbols (sym, ns->contained); } @@ -2999,8 +3479,7 @@ parse_contained (int module) pop_state (); if (!contains_statements) - /* This is valid in Fortran 2008. */ - gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without " + gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without " "FUNCTION or SUBROUTINE statement at %C"); } @@ -3088,7 +3567,7 @@ done: something else. */ void -global_used (gfc_gsymbol *sym, locus *where) +gfc_global_used (gfc_gsymbol *sym, locus *where) { const char *name; @@ -3116,7 +3595,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; } @@ -3154,7 +3633,7 @@ parse_block_data (void) s = gfc_get_gsymbol (gfc_new_block->name); if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA)) - global_used(s, NULL); + gfc_global_used(s, NULL); else { s->type = GSYM_BLOCK_DATA; @@ -3185,7 +3664,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; @@ -3232,7 +3711,7 @@ add_global_procedure (int sub) if (s->defined || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION))) - global_used(s, NULL); + gfc_global_used(s, NULL); else { s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION; @@ -3254,7 +3733,7 @@ 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; @@ -3266,7 +3745,7 @@ add_global_program (void) /* Top level parser. */ -try +gfc_try gfc_parse_file (void) { int seen_program, errors_before, errors; @@ -3274,10 +3753,7 @@ gfc_parse_file (void) gfc_statement st; locus prog_locus; - /* If the debugger wants the name of the main source file, - we give it. */ - if (debug_hooks->start_end_main_source_file) - (*debug_hooks->start_source_file) (0, gfc_source_file); + gfc_start_source_files (); top.state = COMP_NONE; top.sym = NULL; @@ -3316,7 +3792,7 @@ 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); @@ -3358,7 +3834,7 @@ 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); break; } @@ -3368,8 +3844,8 @@ 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) @@ -3389,14 +3865,12 @@ loop: goto loop; done: - if (debug_hooks->start_end_main_source_file) - (*debug_hooks->end_source_file) (0); - + 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 ();