gcc/fortran/parse.c

   1 /* Main parser.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include <setjmp.h>
  25 #include "gfortran.h"
  26 #include "match.h"
  27 #include "parse.h"
  28 #include "debug.h"
  29
  30 /* Current statement label.  Zero means no statement label.  Because new_st
  31    can get wiped during statement matching, we have to keep it separate.  */
  32
  33 gfc_st_label *gfc_statement_label;
  34
  35 static locus label_locus;
  36 static jmp_buf eof_buf;
  37
  38 gfc_state_data *gfc_state_stack;
  39
  40 /* TODO: Re-order functions to kill these forward decls.  */
  41 static void check_statement_label (gfc_statement);
  42 static void undo_new_statement (void);
  43 static void reject_statement (void);
  44
  45
  46 /* A sort of half-matching function.  We try to match the word on the
  47    input with the passed string.  If this succeeds, we call the
  48    keyword-dependent matching function that will match the rest of the
  49    statement.  For single keywords, the matching subroutine is
  50    gfc_match_eos().  */
  51
  52 static match
  53 match_word (const char *str, match (*subr) (void), locus *old_locus)
  54 {
  55   match m;
  56
  57   if (str != NULL)
  58     {
  59       m = gfc_match (str);
  60       if (m != MATCH_YES)
  61         return m;
  62     }
  63
  64   m = (*subr) ();
  65
  66   if (m != MATCH_YES)
  67     {
  68       gfc_current_locus = *old_locus;
  69       reject_statement ();
  70     }
  71
  72   return m;
  73 }
  74
  75
  76 /* Figure out what the next statement is, (mostly) regardless of
  77    proper ordering.  The do...while(0) is there to prevent if/else
  78    ambiguity.  */
  79
  80 #define match(keyword, subr, st)                                \
  81     do {                                                        \
  82       if (match_word(keyword, subr, &old_locus) == MATCH_YES)   \
  83         return st;                                              \
  84       else                                                      \
  85         undo_new_statement ();                            \
  86     } while (0);
  87
  88
  89 /* This is a specialist version of decode_statement that is used
  90    for the specification statements in a function, whose
  91    characteristics are deferred into the specification statements.
  92    eg.:  INTEGER (king = mykind) foo ()
  93          USE mymodule, ONLY mykind.....
  94    The KIND parameter needs a return after USE or IMPORT, whereas
  95    derived type declarations can occur anywhere, up the executable
  96    block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
  97    out of the correct kind of specification statements.  */
  98 static gfc_statement
  99 decode_specification_statement (void)
 100 {
 101   gfc_statement st;
 102   locus old_locus;
 103   char c;
 104
 105   if (gfc_match_eos () == MATCH_YES)
 106     return ST_NONE;
 107
 108   old_locus = gfc_current_locus;
 109
 110   match ("import", gfc_match_import, ST_IMPORT);
 111   match ("use", gfc_match_use, ST_USE);
 112
 113   if (gfc_current_block ()->ts.type != BT_DERIVED)
 114     goto end_of_block;
 115
 116   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 117   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 118   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 119
 120   /* General statement matching: Instead of testing every possible
 121      statement, we eliminate most possibilities by peeking at the
 122      first character.  */
 123
 124   c = gfc_peek_ascii_char ();
 125
 126   switch (c)
 127     {
 128     case 'a':
 129       match ("abstract% interface", gfc_match_abstract_interface,
 130              ST_INTERFACE);
 131       break;
 132
 133     case 'b':
 134       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 135       break;
 136
 137     case 'c':
 138       break;
 139
 140     case 'd':
 141       match ("data", gfc_match_data, ST_DATA);
 142       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 143       break;
 144
 145     case 'e':
 146       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 147       match ("entry% ", gfc_match_entry, ST_ENTRY);
 148       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 149       match ("external", gfc_match_external, ST_ATTR_DECL);
 150       break;
 151
 152     case 'f':
 153       match ("format", gfc_match_format, ST_FORMAT);
 154       break;
 155
 156     case 'g':
 157       break;
 158
 159     case 'i':
 160       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 161       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 162       match ("interface", gfc_match_interface, ST_INTERFACE);
 163       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 164       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 165       break;
 166
 167     case 'm':
 168       break;
 169
 170     case 'n':
 171       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 172       break;
 173
 174     case 'o':
 175       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 176       break;
 177
 178     case 'p':
 179       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 180       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 181       if (gfc_match_private (&st) == MATCH_YES)
 182         return st;
 183       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 184       if (gfc_match_public (&st) == MATCH_YES)
 185         return st;
 186       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 187       break;
 188
 189     case 'r':
 190       break;
 191
 192     case 's':
 193       match ("save", gfc_match_save, ST_ATTR_DECL);
 194       break;
 195
 196     case 't':
 197       match ("target", gfc_match_target, ST_ATTR_DECL);
 198       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 199       break;
 200
 201     case 'u':
 202       break;
 203
 204     case 'v':
 205       match ("value", gfc_match_value, ST_ATTR_DECL);
 206       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 207       break;
 208
 209     case 'w':
 210       break;
 211     }
 212
 213   /* This is not a specification statement.  See if any of the matchers
 214      has stored an error message of some sort.  */
 215
 216 end_of_block:
 217   gfc_clear_error ();
 218   gfc_buffer_error (0);
 219   gfc_current_locus = old_locus;
 220
 221   return ST_GET_FCN_CHARACTERISTICS;
 222 }
 223
 224
 225 /* This is the primary 'decode_statement'.  */
 226 static gfc_statement
 227 decode_statement (void)
 228 {
 229   gfc_statement st;
 230   locus old_locus;
 231   match m;
 232   char c;
 233
 234 #ifdef GFC_DEBUG
 235   gfc_symbol_state ();
 236 #endif
 237
 238   gfc_clear_error ();   /* Clear any pending errors.  */
 239   gfc_clear_warning (); /* Clear any pending warnings.  */
 240
 241   gfc_matching_function = false;
 242
 243   if (gfc_match_eos () == MATCH_YES)
 244     return ST_NONE;
 245
 246   if (gfc_current_state () == COMP_FUNCTION
 247         && gfc_current_block ()->result->ts.kind == -1)
 248     return decode_specification_statement ();
 249
 250   old_locus = gfc_current_locus;
 251
 252   /* Try matching a data declaration or function declaration. The
 253       input "REALFUNCTIONA(N)" can mean several things in different
 254       contexts, so it (and its relatives) get special treatment.  */
 255
 256   if (gfc_current_state () == COMP_NONE
 257       || gfc_current_state () == COMP_INTERFACE
 258       || gfc_current_state () == COMP_CONTAINS)
 259     {
 260       gfc_matching_function = true;
 261       m = gfc_match_function_decl ();
 262       if (m == MATCH_YES)
 263         return ST_FUNCTION;
 264       else if (m == MATCH_ERROR)
 265         reject_statement ();
 266       else
 267         gfc_undo_symbols ();
 268       gfc_current_locus = old_locus;
 269     }
 270   gfc_matching_function = false;
 271
 272
 273   /* Match statements whose error messages are meant to be overwritten
 274      by something better.  */
 275
 276   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
 277   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
 278   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 279
 280   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 281   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 282
 283   /* Try to match a subroutine statement, which has the same optional
 284      prefixes that functions can have.  */
 285
 286   if (gfc_match_subroutine () == MATCH_YES)
 287     return ST_SUBROUTINE;
 288   gfc_undo_symbols ();
 289   gfc_current_locus = old_locus;
 290
 291   /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
 292      might begin with a block label.  The match functions for these
 293      statements are unusual in that their keyword is not seen before
 294      the matcher is called.  */
 295
 296   if (gfc_match_if (&st) == MATCH_YES)
 297     return st;
 298   gfc_undo_symbols ();
 299   gfc_current_locus = old_locus;
 300
 301   if (gfc_match_where (&st) == MATCH_YES)
 302     return st;
 303   gfc_undo_symbols ();
 304   gfc_current_locus = old_locus;
 305
 306   if (gfc_match_forall (&st) == MATCH_YES)
 307     return st;
 308   gfc_undo_symbols ();
 309   gfc_current_locus = old_locus;
 310
 311   match (NULL, gfc_match_do, ST_DO);
 312   match (NULL, gfc_match_select, ST_SELECT_CASE);
 313
 314   /* General statement matching: Instead of testing every possible
 315      statement, we eliminate most possibilities by peeking at the
 316      first character.  */
 317
 318   c = gfc_peek_ascii_char ();
 319
 320   switch (c)
 321     {
 322     case 'a':
 323       match ("abstract% interface", gfc_match_abstract_interface,
 324              ST_INTERFACE);
 325       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
 326       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
 327       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
 328       break;
 329
 330     case 'b':
 331       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
 332       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
 333       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 334       break;
 335
 336     case 'c':
 337       match ("call", gfc_match_call, ST_CALL);
 338       match ("close", gfc_match_close, ST_CLOSE);
 339       match ("continue", gfc_match_continue, ST_CONTINUE);
 340       match ("cycle", gfc_match_cycle, ST_CYCLE);
 341       match ("case", gfc_match_case, ST_CASE);
 342       match ("common", gfc_match_common, ST_COMMON);
 343       match ("contains", gfc_match_eos, ST_CONTAINS);
 344       break;
 345
 346     case 'd':
 347       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
 348       match ("data", gfc_match_data, ST_DATA);
 349       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 350       break;
 351
 352     case 'e':
 353       match ("end file", gfc_match_endfile, ST_END_FILE);
 354       match ("exit", gfc_match_exit, ST_EXIT);
 355       match ("else", gfc_match_else, ST_ELSE);
 356       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
 357       match ("else if", gfc_match_elseif, ST_ELSEIF);
 358       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 359
 360       if (gfc_match_end (&st) == MATCH_YES)
 361         return st;
 362
 363       match ("entry% ", gfc_match_entry, ST_ENTRY);
 364       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 365       match ("external", gfc_match_external, ST_ATTR_DECL);
 366       break;
 367
 368     case 'f':
 369       match ("final", gfc_match_final_decl, ST_FINAL);
 370       match ("flush", gfc_match_flush, ST_FLUSH);
 371       match ("format", gfc_match_format, ST_FORMAT);
 372       break;
 373
 374     case 'g':
 375       match ("go to", gfc_match_goto, ST_GOTO);
 376       break;
 377
 378     case 'i':
 379       match ("inquire", gfc_match_inquire, ST_INQUIRE);
 380       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 381       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 382       match ("import", gfc_match_import, ST_IMPORT);
 383       match ("interface", gfc_match_interface, ST_INTERFACE);
 384       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 385       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 386       break;
 387
 388     case 'm':
 389       match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
 390       match ("module", gfc_match_module, ST_MODULE);
 391       break;
 392
 393     case 'n':
 394       match ("nullify", gfc_match_nullify, ST_NULLIFY);
 395       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 396       break;
 397
 398     case 'o':
 399       match ("open", gfc_match_open, ST_OPEN);
 400       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 401       break;
 402
 403     case 'p':
 404       match ("print", gfc_match_print, ST_WRITE);
 405       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 406       match ("pause", gfc_match_pause, ST_PAUSE);
 407       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 408       if (gfc_match_private (&st) == MATCH_YES)
 409         return st;
 410       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 411       match ("program", gfc_match_program, ST_PROGRAM);
 412       if (gfc_match_public (&st) == MATCH_YES)
 413         return st;
 414       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 415       break;
 416
 417     case 'r':
 418       match ("read", gfc_match_read, ST_READ);
 419       match ("return", gfc_match_return, ST_RETURN);
 420       match ("rewind", gfc_match_rewind, ST_REWIND);
 421       break;
 422
 423     case 's':
 424       match ("sequence", gfc_match_eos, ST_SEQUENCE);
 425       match ("stop", gfc_match_stop, ST_STOP);
 426       match ("save", gfc_match_save, ST_ATTR_DECL);
 427       break;
 428
 429     case 't':
 430       match ("target", gfc_match_target, ST_ATTR_DECL);
 431       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 432       break;
 433
 434     case 'u':
 435       match ("use", gfc_match_use, ST_USE);
 436       break;
 437
 438     case 'v':
 439       match ("value", gfc_match_value, ST_ATTR_DECL);
 440       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 441       break;
 442
 443     case 'w':
 444       match ("wait", gfc_match_wait, ST_WAIT);
 445       match ("write", gfc_match_write, ST_WRITE);
 446       break;
 447     }
 448
 449   /* All else has failed, so give up.  See if any of the matchers has
 450      stored an error message of some sort.  */
 451
 452   if (gfc_error_check () == 0)
 453     gfc_error_now ("Unclassifiable statement at %C");
 454
 455   reject_statement ();
 456
 457   gfc_error_recovery ();
 458
 459   return ST_NONE;
 460 }
 461
 462 static gfc_statement
 463 decode_omp_directive (void)
 464 {
 465   locus old_locus;
 466   char c;
 467
 468 #ifdef GFC_DEBUG
 469   gfc_symbol_state ();
 470 #endif
 471
 472   gfc_clear_error ();   /* Clear any pending errors.  */
 473   gfc_clear_warning (); /* Clear any pending warnings.  */
 474
 475   if (gfc_pure (NULL))
 476     {
 477       gfc_error_now ("OpenMP directives at %C may not appear in PURE "
 478                      "or ELEMENTAL procedures");
 479       gfc_error_recovery ();
 480       return ST_NONE;
 481     }
 482
 483   old_locus = gfc_current_locus;
 484
 485   /* General OpenMP directive matching: Instead of testing every possible
 486      statement, we eliminate most possibilities by peeking at the
 487      first character.  */
 488
 489   c = gfc_peek_ascii_char ();
 490
 491   switch (c)
 492     {
 493     case 'a':
 494       match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
 495       break;
 496     case 'b':
 497       match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
 498       break;
 499     case 'c':
 500       match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
 501       break;
 502     case 'd':
 503       match ("do", gfc_match_omp_do, ST_OMP_DO);
 504       break;
 505     case 'e':
 506       match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
 507       match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
 508       match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
 509       match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
 510       match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
 511       match ("end parallel sections", gfc_match_omp_eos,
 512              ST_OMP_END_PARALLEL_SECTIONS);
 513       match ("end parallel workshare", gfc_match_omp_eos,
 514              ST_OMP_END_PARALLEL_WORKSHARE);
 515       match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
 516       match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
 517       match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
 518       match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
 519       match ("end workshare", gfc_match_omp_end_nowait,
 520              ST_OMP_END_WORKSHARE);
 521       break;
 522     case 'f':
 523       match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
 524       break;
 525     case 'm':
 526       match ("master", gfc_match_omp_master, ST_OMP_MASTER);
 527       break;
 528     case 'o':
 529       match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
 530       break;
 531     case 'p':
 532       match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
 533       match ("parallel sections", gfc_match_omp_parallel_sections,
 534              ST_OMP_PARALLEL_SECTIONS);
 535       match ("parallel workshare", gfc_match_omp_parallel_workshare,
 536              ST_OMP_PARALLEL_WORKSHARE);
 537       match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
 538       break;
 539     case 's':
 540       match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
 541       match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
 542       match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
 543       break;
 544     case 't':
 545       match ("task", gfc_match_omp_task, ST_OMP_TASK);
 546       match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
 547       match ("threadprivate", gfc_match_omp_threadprivate,
 548              ST_OMP_THREADPRIVATE);
 549     case 'w':
 550       match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
 551       break;
 552     }
 553
 554   /* All else has failed, so give up.  See if any of the matchers has
 555      stored an error message of some sort.  */
 556
 557   if (gfc_error_check () == 0)
 558     gfc_error_now ("Unclassifiable OpenMP directive at %C");
 559
 560   reject_statement ();
 561
 562   gfc_error_recovery ();
 563
 564   return ST_NONE;
 565 }
 566
 567 #undef match
 568
 569
 570 /* Get the next statement in free form source.  */
 571
 572 static gfc_statement
 573 next_free (void)
 574 {
 575   match m;
 576   int i, cnt, at_bol;
 577   char c;
 578
 579   at_bol = gfc_at_bol ();
 580   gfc_gobble_whitespace ();
 581
 582   c = gfc_peek_ascii_char ();
 583
 584   if (ISDIGIT (c))
 585     {
 586       char d;
 587
 588       /* Found a statement label?  */
 589       m = gfc_match_st_label (&gfc_statement_label);
 590
 591       d = gfc_peek_ascii_char ();
 592       if (m != MATCH_YES || !gfc_is_whitespace (d))
 593         {
 594           gfc_match_small_literal_int (&i, &cnt);
 595
 596           if (cnt > 5)
 597             gfc_error_now ("Too many digits in statement label at %C");
 598
 599           if (i == 0)
 600             gfc_error_now ("Zero is not a valid statement label at %C");
 601
 602           do
 603             c = gfc_next_ascii_char ();
 604           while (ISDIGIT(c));
 605
 606           if (!gfc_is_whitespace (c))
 607             gfc_error_now ("Non-numeric character in statement label at %C");
 608
 609           return ST_NONE;
 610         }
 611       else
 612         {
 613           label_locus = gfc_current_locus;
 614
 615           gfc_gobble_whitespace ();
 616
 617           if (at_bol && gfc_peek_ascii_char () == ';')
 618             {
 619               gfc_error_now ("Semicolon at %C needs to be preceded by "
 620                              "statement");
 621               gfc_next_ascii_char (); /* Eat up the semicolon.  */
 622               return ST_NONE;
 623             }
 624
 625           if (gfc_match_eos () == MATCH_YES)
 626             {
 627               gfc_warning_now ("Ignoring statement label in empty statement "
 628                                "at %C");
 629               gfc_free_st_label (gfc_statement_label);
 630               gfc_statement_label = NULL;
 631               return ST_NONE;
 632             }
 633         }
 634     }
 635   else if (c == '!')
 636     {
 637       /* Comments have already been skipped by the time we get here,
 638          except for OpenMP directives.  */
 639       if (gfc_option.flag_openmp)
 640         {
 641           int i;
 642
 643           c = gfc_next_ascii_char ();
 644           for (i = 0; i < 5; i++, c = gfc_next_ascii_char ())
 645             gcc_assert (c == "!$omp"[i]);
 646
 647           gcc_assert (c == ' ' || c == '\t');
 648           gfc_gobble_whitespace ();
 649           return decode_omp_directive ();
 650         }
 651     }
 652
 653   if (at_bol && c == ';')
 654     {
 655       gfc_error_now ("Semicolon at %C needs to be preceded by statement");
 656       gfc_next_ascii_char (); /* Eat up the semicolon.  */
 657       return ST_NONE;
 658     }
 659
 660   return decode_statement ();
 661 }
 662
 663
 664 /* Get the next statement in fixed-form source.  */
 665
 666 static gfc_statement
 667 next_fixed (void)
 668 {
 669   int label, digit_flag, i;
 670   locus loc;
 671   gfc_char_t c;
 672
 673   if (!gfc_at_bol ())
 674     return decode_statement ();
 675
 676   /* Skip past the current label field, parsing a statement label if
 677      one is there.  This is a weird number parser, since the number is
 678      contained within five columns and can have any kind of embedded
 679      spaces.  We also check for characters that make the rest of the
 680      line a comment.  */
 681
 682   label = 0;
 683   digit_flag = 0;
 684
 685   for (i = 0; i < 5; i++)
 686     {
 687       c = gfc_next_char_literal (0);
 688
 689       switch (c)
 690         {
 691         case ' ':
 692           break;
 693
 694         case '0':
 695         case '1':
 696         case '2':
 697         case '3':
 698         case '4':
 699         case '5':
 700         case '6':
 701         case '7':
 702         case '8':
 703         case '9':
 704           label = label * 10 + ((unsigned char) c - '0');
 705           label_locus = gfc_current_locus;
 706           digit_flag = 1;
 707           break;
 708
 709           /* Comments have already been skipped by the time we get
 710              here, except for OpenMP directives.  */
 711         case '*':
 712           if (gfc_option.flag_openmp)
 713             {
 714               for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
 715                 gcc_assert ((char) gfc_wide_tolower (c) == "*$omp"[i]);
 716
 717               if (c != ' ' && c != '0')
 718                 {
 719                   gfc_buffer_error (0);
 720                   gfc_error ("Bad continuation line at %C");
 721                   return ST_NONE;
 722                 }
 723
 724               return decode_omp_directive ();
 725             }
 726           /* FALLTHROUGH */
 727
 728           /* Comments have already been skipped by the time we get
 729              here so don't bother checking for them.  */
 730
 731         default:
 732           gfc_buffer_error (0);
 733           gfc_error ("Non-numeric character in statement label at %C");
 734           return ST_NONE;
 735         }
 736     }
 737
 738   if (digit_flag)
 739     {
 740       if (label == 0)
 741         gfc_warning_now ("Zero is not a valid statement label at %C");
 742       else
 743         {
 744           /* We've found a valid statement label.  */
 745           gfc_statement_label = gfc_get_st_label (label);
 746         }
 747     }
 748
 749   /* Since this line starts a statement, it cannot be a continuation
 750      of a previous statement.  If we see something here besides a
 751      space or zero, it must be a bad continuation line.  */
 752
 753   c = gfc_next_char_literal (0);
 754   if (c == '\n')
 755     goto blank_line;
 756
 757   if (c != ' ' && c != '0')
 758     {
 759       gfc_buffer_error (0);
 760       gfc_error ("Bad continuation line at %C");
 761       return ST_NONE;
 762     }
 763
 764   /* Now that we've taken care of the statement label columns, we have
 765      to make sure that the first nonblank character is not a '!'.  If
 766      it is, the rest of the line is a comment.  */
 767
 768   do
 769     {
 770       loc = gfc_current_locus;
 771       c = gfc_next_char_literal (0);
 772     }
 773   while (gfc_is_whitespace (c));
 774
 775   if (c == '!')
 776     goto blank_line;
 777   gfc_current_locus = loc;
 778
 779   if (c == ';')
 780     {
 781       gfc_error_now ("Semicolon at %C needs to be preceded by statement");
 782       return ST_NONE;
 783     }
 784
 785   if (gfc_match_eos () == MATCH_YES)
 786     goto blank_line;
 787
 788   /* At this point, we've got a nonblank statement to parse.  */
 789   return decode_statement ();
 790
 791 blank_line:
 792   if (digit_flag)
 793     gfc_warning ("Ignoring statement label in empty statement at %C");
 794   gfc_advance_line ();
 795   return ST_NONE;
 796 }
 797
 798
 799 /* Return the next non-ST_NONE statement to the caller.  We also worry
 800    about including files and the ends of include files at this stage.  */
 801
 802 static gfc_statement
 803 next_statement (void)
 804 {
 805   gfc_statement st;
 806   locus old_locus;
 807   gfc_new_block = NULL;
 808
 809   for (;;)
 810     {
 811       gfc_statement_label = NULL;
 812       gfc_buffer_error (1);
 813
 814       if (gfc_at_eol ())
 815         {
 816           if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE)
 817               && gfc_current_locus.lb
 818               && gfc_current_locus.lb->truncated)
 819             gfc_warning_now ("Line truncated at %C");
 820
 821           gfc_advance_line ();
 822         }
 823
 824       gfc_skip_comments ();
 825
 826       if (gfc_at_end ())
 827         {
 828           st = ST_NONE;
 829           break;
 830         }
 831
 832       if (gfc_define_undef_line ())
 833         continue;
 834
 835       old_locus = gfc_current_locus;
 836
 837       st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
 838
 839       if (st != ST_NONE)
 840         break;
 841     }
 842
 843   gfc_buffer_error (0);
 844
 845   if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
 846     {
 847       gfc_free_st_label (gfc_statement_label);
 848       gfc_statement_label = NULL;
 849       gfc_current_locus = old_locus;
 850     }
 851
 852   if (st != ST_NONE)
 853     check_statement_label (st);
 854
 855   return st;
 856 }
 857
 858
 859 /****************************** Parser ***********************************/
 860
 861 /* The parser subroutines are of type 'try' that fail if the file ends
 862    unexpectedly.  */
 863
 864 /* Macros that expand to case-labels for various classes of
 865    statements.  Start with executable statements that directly do
 866    things.  */
 867
 868 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
 869   case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
 870   case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
 871   case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
 872   case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
 873   case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
 874   case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
 875   case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
 876   case ST_OMP_BARRIER: case ST_OMP_TASKWAIT
 877
 878 /* Statements that mark other executable statements.  */
 879
 880 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
 881   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
 882   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
 883   case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
 884   case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
 885   case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
 886   case ST_OMP_TASK
 887
 888 /* Declaration statements */
 889
 890 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
 891   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
 892   case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
 893   case ST_PROCEDURE
 894
 895 /* Block end statements.  Errors associated with interchanging these
 896    are detected in gfc_match_end().  */
 897
 898 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
 899                  case ST_END_PROGRAM: case ST_END_SUBROUTINE
 900
 901
 902 /* Push a new state onto the stack.  */
 903
 904 static void
 905 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
 906 {
 907   p->state = new_state;
 908   p->previous = gfc_state_stack;
 909   p->sym = sym;
 910   p->head = p->tail = NULL;
 911   p->do_variable = NULL;
 912   gfc_state_stack = p;
 913 }
 914
 915
 916 /* Pop the current state.  */
 917 static void
 918 pop_state (void)
 919 {
 920   gfc_state_stack = gfc_state_stack->previous;
 921 }
 922
 923
 924 /* Try to find the given state in the state stack.  */
 925
 926 gfc_try
 927 gfc_find_state (gfc_compile_state state)
 928 {
 929   gfc_state_data *p;
 930
 931   for (p = gfc_state_stack; p; p = p->previous)
 932     if (p->state == state)
 933       break;
 934
 935   return (p == NULL) ? FAILURE : SUCCESS;
 936 }
 937
 938
 939 /* Starts a new level in the statement list.  */
 940
 941 static gfc_code *
 942 new_level (gfc_code *q)
 943 {
 944   gfc_code *p;
 945
 946   p = q->block = gfc_get_code ();
 947
 948   gfc_state_stack->head = gfc_state_stack->tail = p;
 949
 950   return p;
 951 }
 952
 953
 954 /* Add the current new_st code structure and adds it to the current
 955    program unit.  As a side-effect, it zeroes the new_st.  */
 956
 957 static gfc_code *
 958 add_statement (void)
 959 {
 960   gfc_code *p;
 961
 962   p = gfc_get_code ();
 963   *p = new_st;
 964
 965   p->loc = gfc_current_locus;
 966
 967   if (gfc_state_stack->head == NULL)
 968     gfc_state_stack->head = p;
 969   else
 970     gfc_state_stack->tail->next = p;
 971
 972   while (p->next != NULL)
 973     p = p->next;
 974
 975   gfc_state_stack->tail = p;
 976
 977   gfc_clear_new_st ();
 978
 979   return p;
 980 }
 981
 982
 983 /* Frees everything associated with the current statement.  */
 984
 985 static void
 986 undo_new_statement (void)
 987 {
 988   gfc_free_statements (new_st.block);
 989   gfc_free_statements (new_st.next);
 990   gfc_free_statement (&new_st);
 991   gfc_clear_new_st ();
 992 }
 993
 994
 995 /* If the current statement has a statement label, make sure that it
 996    is allowed to, or should have one.  */
 997
 998 static void
 999 check_statement_label (gfc_statement st)
1000 {
1001   gfc_sl_type type;
1002
1003   if (gfc_statement_label == NULL)
1004     {
1005       if (st == ST_FORMAT)
1006         gfc_error ("FORMAT statement at %L does not have a statement label",
1007                    &new_st.loc);
1008       return;
1009     }
1010
1011   switch (st)
1012     {
1013     case ST_END_PROGRAM:
1014     case ST_END_FUNCTION:
1015     case ST_END_SUBROUTINE:
1016     case ST_ENDDO:
1017     case ST_ENDIF:
1018     case ST_END_SELECT:
1019     case_executable:
1020     case_exec_markers:
1021       type = ST_LABEL_TARGET;
1022       break;
1023
1024     case ST_FORMAT:
1025       type = ST_LABEL_FORMAT;
1026       break;
1027
1028       /* Statement labels are not restricted from appearing on a
1029          particular line.  However, there are plenty of situations
1030          where the resulting label can't be referenced.  */
1031
1032     default:
1033       type = ST_LABEL_BAD_TARGET;
1034       break;
1035     }
1036
1037   gfc_define_st_label (gfc_statement_label, type, &label_locus);
1038
1039   new_st.here = gfc_statement_label;
1040 }
1041
1042
1043 /* Figures out what the enclosing program unit is.  This will be a
1044    function, subroutine, program, block data or module.  */
1045
1046 gfc_state_data *
1047 gfc_enclosing_unit (gfc_compile_state * result)
1048 {
1049   gfc_state_data *p;
1050
1051   for (p = gfc_state_stack; p; p = p->previous)
1052     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1053         || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
1054         || p->state == COMP_PROGRAM)
1055       {
1056
1057         if (result != NULL)
1058           *result = p->state;
1059         return p;
1060       }
1061
1062   if (result != NULL)
1063     *result = COMP_PROGRAM;
1064   return NULL;
1065 }
1066
1067
1068 /* Translate a statement enum to a string.  */
1069
1070 const char *
1071 gfc_ascii_statement (gfc_statement st)
1072 {
1073   const char *p;
1074
1075   switch (st)
1076     {
1077     case ST_ARITHMETIC_IF:
1078       p = _("arithmetic IF");
1079       break;
1080     case ST_ALLOCATE:
1081       p = "ALLOCATE";
1082       break;
1083     case ST_ATTR_DECL:
1084       p = _("attribute declaration");
1085       break;
1086     case ST_BACKSPACE:
1087       p = "BACKSPACE";
1088       break;
1089     case ST_BLOCK_DATA:
1090       p = "BLOCK DATA";
1091       break;
1092     case ST_CALL:
1093       p = "CALL";
1094       break;
1095     case ST_CASE:
1096       p = "CASE";
1097       break;
1098     case ST_CLOSE:
1099       p = "CLOSE";
1100       break;
1101     case ST_COMMON:
1102       p = "COMMON";
1103       break;
1104     case ST_CONTINUE:
1105       p = "CONTINUE";
1106       break;
1107     case ST_CONTAINS:
1108       p = "CONTAINS";
1109       break;
1110     case ST_CYCLE:
1111       p = "CYCLE";
1112       break;
1113     case ST_DATA_DECL:
1114       p = _("data declaration");
1115       break;
1116     case ST_DATA:
1117       p = "DATA";
1118       break;
1119     case ST_DEALLOCATE:
1120       p = "DEALLOCATE";
1121       break;
1122     case ST_DERIVED_DECL:
1123       p = _("derived type declaration");
1124       break;
1125     case ST_DO:
1126       p = "DO";
1127       break;
1128     case ST_ELSE:
1129       p = "ELSE";
1130       break;
1131     case ST_ELSEIF:
1132       p = "ELSE IF";
1133       break;
1134     case ST_ELSEWHERE:
1135       p = "ELSEWHERE";
1136       break;
1137     case ST_END_BLOCK_DATA:
1138       p = "END BLOCK DATA";
1139       break;
1140     case ST_ENDDO:
1141       p = "END DO";
1142       break;
1143     case ST_END_FILE:
1144       p = "END FILE";
1145       break;
1146     case ST_END_FORALL:
1147       p = "END FORALL";
1148       break;
1149     case ST_END_FUNCTION:
1150       p = "END FUNCTION";
1151       break;
1152     case ST_ENDIF:
1153       p = "END IF";
1154       break;
1155     case ST_END_INTERFACE:
1156       p = "END INTERFACE";
1157       break;
1158     case ST_END_MODULE:
1159       p = "END MODULE";
1160       break;
1161     case ST_END_PROGRAM:
1162       p = "END PROGRAM";
1163       break;
1164     case ST_END_SELECT:
1165       p = "END SELECT";
1166       break;
1167     case ST_END_SUBROUTINE:
1168       p = "END SUBROUTINE";
1169       break;
1170     case ST_END_WHERE:
1171       p = "END WHERE";
1172       break;
1173     case ST_END_TYPE:
1174       p = "END TYPE";
1175       break;
1176     case ST_ENTRY:
1177       p = "ENTRY";
1178       break;
1179     case ST_EQUIVALENCE:
1180       p = "EQUIVALENCE";
1181       break;
1182     case ST_EXIT:
1183       p = "EXIT";
1184       break;
1185     case ST_FLUSH:
1186       p = "FLUSH";
1187       break;
1188     case ST_FORALL_BLOCK:       /* Fall through */
1189     case ST_FORALL:
1190       p = "FORALL";
1191       break;
1192     case ST_FORMAT:
1193       p = "FORMAT";
1194       break;
1195     case ST_FUNCTION:
1196       p = "FUNCTION";
1197       break;
1198     case ST_GOTO:
1199       p = "GOTO";
1200       break;
1201     case ST_IF_BLOCK:
1202       p = _("block IF");
1203       break;
1204     case ST_IMPLICIT:
1205       p = "IMPLICIT";
1206       break;
1207     case ST_IMPLICIT_NONE:
1208       p = "IMPLICIT NONE";
1209       break;
1210     case ST_IMPLIED_ENDDO:
1211       p = _("implied END DO");
1212       break;
1213     case ST_IMPORT:
1214       p = "IMPORT";
1215       break;
1216     case ST_INQUIRE:
1217       p = "INQUIRE";
1218       break;
1219     case ST_INTERFACE:
1220       p = "INTERFACE";
1221       break;
1222     case ST_PARAMETER:
1223       p = "PARAMETER";
1224       break;
1225     case ST_PRIVATE:
1226       p = "PRIVATE";
1227       break;
1228     case ST_PUBLIC:
1229       p = "PUBLIC";
1230       break;
1231     case ST_MODULE:
1232       p = "MODULE";
1233       break;
1234     case ST_PAUSE:
1235       p = "PAUSE";
1236       break;
1237     case ST_MODULE_PROC:
1238       p = "MODULE PROCEDURE";
1239       break;
1240     case ST_NAMELIST:
1241       p = "NAMELIST";
1242       break;
1243     case ST_NULLIFY:
1244       p = "NULLIFY";
1245       break;
1246     case ST_OPEN:
1247       p = "OPEN";
1248       break;
1249     case ST_PROGRAM:
1250       p = "PROGRAM";
1251       break;
1252     case ST_PROCEDURE:
1253       p = "PROCEDURE";
1254       break;
1255     case ST_READ:
1256       p = "READ";
1257       break;
1258     case ST_RETURN:
1259       p = "RETURN";
1260       break;
1261     case ST_REWIND:
1262       p = "REWIND";
1263       break;
1264     case ST_STOP:
1265       p = "STOP";
1266       break;
1267     case ST_SUBROUTINE:
1268       p = "SUBROUTINE";
1269       break;
1270     case ST_TYPE:
1271       p = "TYPE";
1272       break;
1273     case ST_USE:
1274       p = "USE";
1275       break;
1276     case ST_WHERE_BLOCK:        /* Fall through */
1277     case ST_WHERE:
1278       p = "WHERE";
1279       break;
1280     case ST_WAIT:
1281       p = "WAIT";
1282       break;
1283     case ST_WRITE:
1284       p = "WRITE";
1285       break;
1286     case ST_ASSIGNMENT:
1287       p = _("assignment");
1288       break;
1289     case ST_POINTER_ASSIGNMENT:
1290       p = _("pointer assignment");
1291       break;
1292     case ST_SELECT_CASE:
1293       p = "SELECT CASE";
1294       break;
1295     case ST_SEQUENCE:
1296       p = "SEQUENCE";
1297       break;
1298     case ST_SIMPLE_IF:
1299       p = _("simple IF");
1300       break;
1301     case ST_STATEMENT_FUNCTION:
1302       p = "STATEMENT FUNCTION";
1303       break;
1304     case ST_LABEL_ASSIGNMENT:
1305       p = "LABEL ASSIGNMENT";
1306       break;
1307     case ST_ENUM:
1308       p = "ENUM DEFINITION";
1309       break;
1310     case ST_ENUMERATOR:
1311       p = "ENUMERATOR DEFINITION";
1312       break;
1313     case ST_END_ENUM:
1314       p = "END ENUM";
1315       break;
1316     case ST_OMP_ATOMIC:
1317       p = "!$OMP ATOMIC";
1318       break;
1319     case ST_OMP_BARRIER:
1320       p = "!$OMP BARRIER";
1321       break;
1322     case ST_OMP_CRITICAL:
1323       p = "!$OMP CRITICAL";
1324       break;
1325     case ST_OMP_DO:
1326       p = "!$OMP DO";
1327       break;
1328     case ST_OMP_END_CRITICAL:
1329       p = "!$OMP END CRITICAL";
1330       break;
1331     case ST_OMP_END_DO:
1332       p = "!$OMP END DO";
1333       break;
1334     case ST_OMP_END_MASTER:
1335       p = "!$OMP END MASTER";
1336       break;
1337     case ST_OMP_END_ORDERED:
1338       p = "!$OMP END ORDERED";
1339       break;
1340     case ST_OMP_END_PARALLEL:
1341       p = "!$OMP END PARALLEL";
1342       break;
1343     case ST_OMP_END_PARALLEL_DO:
1344       p = "!$OMP END PARALLEL DO";
1345       break;
1346     case ST_OMP_END_PARALLEL_SECTIONS:
1347       p = "!$OMP END PARALLEL SECTIONS";
1348       break;
1349     case ST_OMP_END_PARALLEL_WORKSHARE:
1350       p = "!$OMP END PARALLEL WORKSHARE";
1351       break;
1352     case ST_OMP_END_SECTIONS:
1353       p = "!$OMP END SECTIONS";
1354       break;
1355     case ST_OMP_END_SINGLE:
1356       p = "!$OMP END SINGLE";
1357       break;
1358     case ST_OMP_END_TASK:
1359       p = "!$OMP END TASK";
1360       break;
1361     case ST_OMP_END_WORKSHARE:
1362       p = "!$OMP END WORKSHARE";
1363       break;
1364     case ST_OMP_FLUSH:
1365       p = "!$OMP FLUSH";
1366       break;
1367     case ST_OMP_MASTER:
1368       p = "!$OMP MASTER";
1369       break;
1370     case ST_OMP_ORDERED:
1371       p = "!$OMP ORDERED";
1372       break;
1373     case ST_OMP_PARALLEL:
1374       p = "!$OMP PARALLEL";
1375       break;
1376     case ST_OMP_PARALLEL_DO:
1377       p = "!$OMP PARALLEL DO";
1378       break;
1379     case ST_OMP_PARALLEL_SECTIONS:
1380       p = "!$OMP PARALLEL SECTIONS";
1381       break;
1382     case ST_OMP_PARALLEL_WORKSHARE:
1383       p = "!$OMP PARALLEL WORKSHARE";
1384       break;
1385     case ST_OMP_SECTIONS:
1386       p = "!$OMP SECTIONS";
1387       break;
1388     case ST_OMP_SECTION:
1389       p = "!$OMP SECTION";
1390       break;
1391     case ST_OMP_SINGLE:
1392       p = "!$OMP SINGLE";
1393       break;
1394     case ST_OMP_TASK:
1395       p = "!$OMP TASK";
1396       break;
1397     case ST_OMP_TASKWAIT:
1398       p = "!$OMP TASKWAIT";
1399       break;
1400     case ST_OMP_THREADPRIVATE:
1401       p = "!$OMP THREADPRIVATE";
1402       break;
1403     case ST_OMP_WORKSHARE:
1404       p = "!$OMP WORKSHARE";
1405       break;
1406     default:
1407       gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1408     }
1409
1410   return p;
1411 }
1412
1413
1414 /* Create a symbol for the main program and assign it to ns->proc_name.  */
1415
1416 static void
1417 main_program_symbol (gfc_namespace *ns, const char *name)
1418 {
1419   gfc_symbol *main_program;
1420   symbol_attribute attr;
1421
1422   gfc_get_symbol (name, ns, &main_program);
1423   gfc_clear_attr (&attr);
1424   attr.flavor = FL_PROGRAM;
1425   attr.proc = PROC_UNKNOWN;
1426   attr.subroutine = 1;
1427   attr.access = ACCESS_PUBLIC;
1428   attr.is_main_program = 1;
1429   main_program->attr = attr;
1430   main_program->declared_at = gfc_current_locus;
1431   ns->proc_name = main_program;
1432   gfc_commit_symbols ();
1433 }
1434
1435
1436 /* Do whatever is necessary to accept the last statement.  */
1437
1438 static void
1439 accept_statement (gfc_statement st)
1440 {
1441   switch (st)
1442     {
1443     case ST_USE:
1444       gfc_use_module ();
1445       break;
1446
1447     case ST_IMPLICIT_NONE:
1448       gfc_set_implicit_none ();
1449       break;
1450
1451     case ST_IMPLICIT:
1452       break;
1453
1454     case ST_FUNCTION:
1455     case ST_SUBROUTINE:
1456     case ST_MODULE:
1457       gfc_current_ns->proc_name = gfc_new_block;
1458       break;
1459
1460       /* If the statement is the end of a block, lay down a special code
1461          that allows a branch to the end of the block from within the
1462          construct.  */
1463
1464     case ST_ENDIF:
1465     case ST_END_SELECT:
1466       if (gfc_statement_label != NULL)
1467         {
1468           new_st.op = EXEC_NOP;
1469           add_statement ();
1470         }
1471
1472       break;
1473
1474       /* The end-of-program unit statements do not get the special
1475          marker and require a statement of some sort if they are a
1476          branch target.  */
1477
1478     case ST_END_PROGRAM:
1479     case ST_END_FUNCTION:
1480     case ST_END_SUBROUTINE:
1481       if (gfc_statement_label != NULL)
1482         {
1483           new_st.op = EXEC_RETURN;
1484           add_statement ();
1485         }
1486
1487       break;
1488
1489     case ST_ENTRY:
1490     case_executable:
1491     case_exec_markers:
1492       add_statement ();
1493       break;
1494
1495     default:
1496       break;
1497     }
1498
1499   gfc_commit_symbols ();
1500   gfc_warning_check ();
1501   gfc_clear_new_st ();
1502 }
1503
1504
1505 /* Undo anything tentative that has been built for the current
1506    statement.  */
1507
1508 static void
1509 reject_statement (void)
1510 {
1511   gfc_new_block = NULL;
1512   gfc_undo_symbols ();
1513   gfc_clear_warning ();
1514   undo_new_statement ();
1515 }
1516
1517
1518 /* Generic complaint about an out of order statement.  We also do
1519    whatever is necessary to clean up.  */
1520
1521 static void
1522 unexpected_statement (gfc_statement st)
1523 {
1524   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1525
1526   reject_statement ();
1527 }
1528
1529
1530 /* Given the next statement seen by the matcher, make sure that it is
1531    in proper order with the last.  This subroutine is initialized by
1532    calling it with an argument of ST_NONE.  If there is a problem, we
1533    issue an error and return FAILURE.  Otherwise we return SUCCESS.
1534
1535    Individual parsers need to verify that the statements seen are
1536    valid before calling here, i.e., ENTRY statements are not allowed in
1537    INTERFACE blocks.  The following diagram is taken from the standard:
1538
1539             +---------------------------------------+
1540             | program  subroutine  function  module |
1541             +---------------------------------------+
1542             |            use               |
1543             +---------------------------------------+
1544             |            import         |
1545             +---------------------------------------+
1546             |   |       implicit none    |
1547             |   +-----------+------------------+
1548             |   | parameter |  implicit |
1549             |   +-----------+------------------+
1550             | format |     |  derived type    |
1551             | entry  | parameter |  interface       |
1552             |   |   data    |  specification   |
1553             |   |          |  statement func  |
1554             |   +-----------+------------------+
1555             |   |   data    |    executable    |
1556             +--------+-----------+------------------+
1557             |           contains               |
1558             +---------------------------------------+
1559             |      internal module/subprogram       |
1560             +---------------------------------------+
1561             |              end           |
1562             +---------------------------------------+
1563
1564 */
1565
1566 typedef struct
1567 {
1568   enum
1569   { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
1570     ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
1571   }
1572   state;
1573   gfc_statement last_statement;
1574   locus where;
1575 }
1576 st_state;
1577
1578 static gfc_try
1579 verify_st_order (st_state *p, gfc_statement st, bool silent)
1580 {
1581
1582   switch (st)
1583     {
1584     case ST_NONE:
1585       p->state = ORDER_START;
1586       break;
1587
1588     case ST_USE:
1589       if (p->state > ORDER_USE)
1590         goto order;
1591       p->state = ORDER_USE;
1592       break;
1593
1594     case ST_IMPORT:
1595       if (p->state > ORDER_IMPORT)
1596         goto order;
1597       p->state = ORDER_IMPORT;
1598       break;
1599
1600     case ST_IMPLICIT_NONE:
1601       if (p->state > ORDER_IMPLICIT_NONE)
1602         goto order;
1603
1604       /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1605          statement disqualifies a USE but not an IMPLICIT NONE.
1606          Duplicate IMPLICIT NONEs are caught when the implicit types
1607          are set.  */
1608
1609       p->state = ORDER_IMPLICIT_NONE;
1610       break;
1611
1612     case ST_IMPLICIT:
1613       if (p->state > ORDER_IMPLICIT)
1614         goto order;
1615       p->state = ORDER_IMPLICIT;
1616       break;
1617
1618     case ST_FORMAT:
1619     case ST_ENTRY:
1620       if (p->state < ORDER_IMPLICIT_NONE)
1621         p->state = ORDER_IMPLICIT_NONE;
1622       break;
1623
1624     case ST_PARAMETER:
1625       if (p->state >= ORDER_EXEC)
1626         goto order;
1627       if (p->state < ORDER_IMPLICIT)
1628         p->state = ORDER_IMPLICIT;
1629       break;
1630
1631     case ST_DATA:
1632       if (p->state < ORDER_SPEC)
1633         p->state = ORDER_SPEC;
1634       break;
1635
1636     case ST_PUBLIC:
1637     case ST_PRIVATE:
1638     case ST_DERIVED_DECL:
1639     case_decl:
1640       if (p->state >= ORDER_EXEC)
1641         goto order;
1642       if (p->state < ORDER_SPEC)
1643         p->state = ORDER_SPEC;
1644       break;
1645
1646     case_executable:
1647     case_exec_markers:
1648       if (p->state < ORDER_EXEC)
1649         p->state = ORDER_EXEC;
1650       break;
1651
1652     default:
1653       gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1654                           gfc_ascii_statement (st));
1655     }
1656
1657   /* All is well, record the statement in case we need it next time.  */
1658   p->where = gfc_current_locus;
1659   p->last_statement = st;
1660   return SUCCESS;
1661
1662 order:
1663   if (!silent)
1664     gfc_error ("%s statement at %C cannot follow %s statement at %L",
1665                gfc_ascii_statement (st),
1666                gfc_ascii_statement (p->last_statement), &p->where);
1667
1668   return FAILURE;
1669 }
1670
1671
1672 /* Handle an unexpected end of file.  This is a show-stopper...  */
1673
1674 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1675
1676 static void
1677 unexpected_eof (void)
1678 {
1679   gfc_state_data *p;
1680
1681   gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1682
1683   /* Memory cleanup.  Move to "second to last".  */
1684   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1685        p = p->previous);
1686
1687   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1688   gfc_done_2 ();
1689
1690   longjmp (eof_buf, 1);
1691 }
1692
1693
1694 /* Set the default access attribute for a typebound procedure; this is used
1695    as callback for gfc_traverse_symtree.  */
1696
1697 static gfc_access typebound_default_access;
1698
1699 static void
1700 set_typebound_default_access (gfc_symtree* stree)
1701 {
1702   if (stree->typebound && stree->typebound->access == ACCESS_UNKNOWN)
1703     stree->typebound->access = typebound_default_access;
1704 }
1705
1706
1707 /* Parse the CONTAINS section of a derived type definition.  */
1708
1709 static bool
1710 parse_derived_contains (void)
1711 {
1712   gfc_state_data s;
1713   bool seen_private = false;
1714   bool seen_comps = false;
1715   bool error_flag = false;
1716   bool to_finish;
1717
1718   gcc_assert (gfc_current_state () == COMP_DERIVED);
1719   gcc_assert (gfc_current_block ());
1720
1721   /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
1722      section.  */
1723   if (gfc_current_block ()->attr.sequence)
1724     gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
1725                " section at %C", gfc_current_block ()->name);
1726   if (gfc_current_block ()->attr.is_bind_c)
1727     gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
1728                " section at %C", gfc_current_block ()->name);
1729
1730   accept_statement (ST_CONTAINS);
1731   push_state (&s, COMP_DERIVED_CONTAINS, NULL);
1732
1733   to_finish = false;
1734   while (!to_finish)
1735     {
1736       gfc_statement st;
1737       st = next_statement ();
1738       switch (st)
1739         {
1740         case ST_NONE:
1741           unexpected_eof ();
1742           break;
1743
1744         case ST_DATA_DECL:
1745           gfc_error ("Components in TYPE at %C must precede CONTAINS");
1746           error_flag = true;
1747           break;
1748
1749         case ST_PROCEDURE:
1750           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  Type-bound"
1751                                              " procedure at %C") == FAILURE)
1752             error_flag = true;
1753
1754           accept_statement (ST_PROCEDURE);
1755           seen_comps = true;
1756           break;
1757
1758         case ST_FINAL:
1759           if (gfc_notify_std (GFC_STD_F2003,
1760                               "Fortran 2003:  FINAL procedure declaration"
1761                               " at %C") == FAILURE)
1762             error_flag = true;
1763
1764           accept_statement (ST_FINAL);
1765           seen_comps = true;
1766           break;
1767
1768         case ST_END_TYPE:
1769           to_finish = true;
1770
1771           if (!seen_comps
1772               && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
1773                                   "definition at %C with empty CONTAINS "
1774                                   "section") == FAILURE))
1775             error_flag = true;
1776
1777           /* ST_END_TYPE is accepted by parse_derived after return.  */
1778           break;
1779
1780         case ST_PRIVATE:
1781           if (gfc_find_state (COMP_MODULE) == FAILURE)
1782             {
1783               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1784                          "a MODULE");
1785               error_flag = true;
1786               break;
1787             }
1788
1789           if (seen_comps)
1790             {
1791               gfc_error ("PRIVATE statement at %C must precede procedure"
1792                          " bindings");
1793               error_flag = true;
1794               break;
1795             }
1796
1797           if (seen_private)
1798             {
1799               gfc_error ("Duplicate PRIVATE statement at %C");
1800               error_flag = true;
1801             }
1802
1803           accept_statement (ST_PRIVATE);
1804           seen_private = true;
1805           break;
1806
1807         case ST_SEQUENCE:
1808           gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
1809           error_flag = true;
1810           break;
1811
1812         case ST_CONTAINS:
1813           gfc_error ("Already inside a CONTAINS block at %C");
1814           error_flag = true;
1815           break;
1816
1817         default:
1818           unexpected_statement (st);
1819           break;
1820         }
1821     }
1822
1823   pop_state ();
1824   gcc_assert (gfc_current_state () == COMP_DERIVED);
1825
1826   /* Walk the parsed type-bound procedures and set ACCESS_UNKNOWN attributes
1827      to PUBLIC or PRIVATE depending on seen_private.  */
1828   typebound_default_access = (seen_private ? ACCESS_PRIVATE : ACCESS_PUBLIC);
1829   gfc_traverse_symtree (gfc_current_block ()->f2k_derived->sym_root,
1830                         &set_typebound_default_access);
1831
1832   return error_flag;
1833 }
1834
1835
1836 /* Parse a derived type.  */
1837
1838 static void
1839 parse_derived (void)
1840 {
1841   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1842   gfc_statement st;
1843   gfc_state_data s;
1844   gfc_symbol *derived_sym = NULL;
1845   gfc_symbol *sym;
1846   gfc_component *c;
1847
1848   error_flag = 0;
1849
1850   accept_statement (ST_DERIVED_DECL);
1851   push_state (&s, COMP_DERIVED, gfc_new_block);
1852
1853   gfc_new_block->component_access = ACCESS_PUBLIC;
1854   seen_private = 0;
1855   seen_sequence = 0;
1856   seen_component = 0;
1857
1858   compiling_type = 1;
1859
1860   while (compiling_type)
1861     {
1862       st = next_statement ();
1863       switch (st)
1864         {
1865         case ST_NONE:
1866           unexpected_eof ();
1867
1868         case ST_DATA_DECL:
1869           accept_statement (st);
1870           seen_component = 1;
1871           break;
1872
1873         case ST_PROCEDURE:
1874           gfc_error ("PROCEDURE binding at %C must be inside CONTAINS");
1875           error_flag = 1;
1876           break;
1877
1878         case ST_FINAL:
1879           gfc_error ("FINAL declaration at %C must be inside CONTAINS");
1880           error_flag = 1;
1881           break;
1882
1883         case ST_END_TYPE:
1884 endType:
1885           compiling_type = 0;
1886
1887           if (!seen_component
1888               && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
1889                                  "definition at %C without components")
1890                   == FAILURE))
1891             error_flag = 1;
1892
1893           accept_statement (ST_END_TYPE);
1894           break;
1895
1896         case ST_PRIVATE:
1897           if (gfc_find_state (COMP_MODULE) == FAILURE)
1898             {
1899               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1900                          "a MODULE");
1901               error_flag = 1;
1902               break;
1903             }
1904
1905           if (seen_component)
1906             {
1907               gfc_error ("PRIVATE statement at %C must precede "
1908                          "structure components");
1909               error_flag = 1;
1910               break;
1911             }
1912
1913           if (seen_private)
1914             {
1915               gfc_error ("Duplicate PRIVATE statement at %C");
1916               error_flag = 1;
1917             }
1918
1919           s.sym->component_access = ACCESS_PRIVATE;
1920
1921           accept_statement (ST_PRIVATE);
1922           seen_private = 1;
1923           break;
1924
1925         case ST_SEQUENCE:
1926           if (seen_component)
1927             {
1928               gfc_error ("SEQUENCE statement at %C must precede "
1929                          "structure components");
1930               error_flag = 1;
1931               break;
1932             }
1933
1934           if (gfc_current_block ()->attr.sequence)
1935             gfc_warning ("SEQUENCE attribute at %C already specified in "
1936                          "TYPE statement");
1937
1938           if (seen_sequence)
1939             {
1940               gfc_error ("Duplicate SEQUENCE statement at %C");
1941               error_flag = 1;
1942             }
1943
1944           seen_sequence = 1;
1945           gfc_add_sequence (&gfc_current_block ()->attr,
1946                             gfc_current_block ()->name, NULL);
1947           break;
1948
1949         case ST_CONTAINS:
1950           if (gfc_notify_std (GFC_STD_F2003,
1951                               "Fortran 2003:  CONTAINS block in derived type"
1952                               " definition at %C") == FAILURE)
1953             error_flag = 1;
1954
1955           accept_statement (ST_CONTAINS);
1956           if (parse_derived_contains ())
1957             error_flag = 1;
1958           goto endType;
1959
1960         default:
1961           unexpected_statement (st);
1962           break;
1963         }
1964     }
1965
1966   /* need to verify that all fields of the derived type are
1967    * interoperable with C if the type is declared to be bind(c)
1968    */
1969   derived_sym = gfc_current_block();
1970
1971   sym = gfc_current_block ();
1972   for (c = sym->components; c; c = c->next)
1973     {
1974       /* Look for allocatable components.  */
1975       if (c->attr.allocatable
1976           || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
1977         {
1978           sym->attr.alloc_comp = 1;
1979           break;
1980         }
1981
1982       /* Look for pointer components.  */
1983       if (c->attr.pointer
1984           || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
1985         {
1986           sym->attr.pointer_comp = 1;
1987           break;
1988         }
1989
1990       /* Look for private components.  */
1991       if (sym->component_access == ACCESS_PRIVATE
1992           || c->attr.access == ACCESS_PRIVATE
1993           || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
1994         {
1995           sym->attr.private_comp = 1;
1996           break;
1997         }
1998     }
1999
2000   if (!seen_component)
2001     sym->attr.zero_comp = 1;
2002
2003   pop_state ();
2004 }
2005
2006
2007 /* Parse an ENUM.  */
2008
2009 static void
2010 parse_enum (void)
2011 {
2012   int error_flag;
2013   gfc_statement st;
2014   int compiling_enum;
2015   gfc_state_data s;
2016   int seen_enumerator = 0;
2017
2018   error_flag = 0;
2019
2020   push_state (&s, COMP_ENUM, gfc_new_block);
2021
2022   compiling_enum = 1;
2023
2024   while (compiling_enum)
2025     {
2026       st = next_statement ();
2027       switch (st)
2028         {
2029         case ST_NONE:
2030           unexpected_eof ();
2031           break;
2032
2033         case ST_ENUMERATOR:
2034           seen_enumerator = 1;
2035           accept_statement (st);
2036           break;
2037
2038         case ST_END_ENUM:
2039           compiling_enum = 0;
2040           if (!seen_enumerator)
2041             {
2042               gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2043               error_flag = 1;
2044             }
2045           accept_statement (st);
2046           break;
2047
2048         default:
2049           gfc_free_enum_history ();
2050           unexpected_statement (st);
2051           break;
2052         }
2053     }
2054   pop_state ();
2055 }
2056
2057
2058 /* Parse an interface.  We must be able to deal with the possibility
2059    of recursive interfaces.  The parse_spec() subroutine is mutually
2060    recursive with parse_interface().  */
2061
2062 static gfc_statement parse_spec (gfc_statement);
2063
2064 static void
2065 parse_interface (void)
2066 {
2067   gfc_compile_state new_state = COMP_NONE, current_state;
2068   gfc_symbol *prog_unit, *sym;
2069   gfc_interface_info save;
2070   gfc_state_data s1, s2;
2071   gfc_statement st;
2072   locus proc_locus;
2073
2074   accept_statement (ST_INTERFACE);
2075
2076   current_interface.ns = gfc_current_ns;
2077   save = current_interface;
2078
2079   sym = (current_interface.type == INTERFACE_GENERIC
2080          || current_interface.type == INTERFACE_USER_OP)
2081         ? gfc_new_block : NULL;
2082
2083   push_state (&s1, COMP_INTERFACE, sym);
2084   current_state = COMP_NONE;
2085
2086 loop:
2087   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2088
2089   st = next_statement ();
2090   switch (st)
2091     {
2092     case ST_NONE:
2093       unexpected_eof ();
2094
2095     case ST_SUBROUTINE:
2096     case ST_FUNCTION:
2097       if (st == ST_SUBROUTINE)
2098         new_state = COMP_SUBROUTINE;
2099       else if (st == ST_FUNCTION)
2100         new_state = COMP_FUNCTION;
2101       if (gfc_new_block->attr.pointer)
2102         {
2103           gfc_new_block->attr.pointer = 0;
2104           gfc_new_block->attr.proc_pointer = 1;
2105         }
2106       if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2107                                   gfc_new_block->formal, NULL) == FAILURE)
2108         {
2109           reject_statement ();
2110           gfc_free_namespace (gfc_current_ns);
2111           goto loop;
2112         }
2113       if (current_interface.type != INTERFACE_ABSTRACT &&
2114          !gfc_new_block->attr.dummy &&
2115          gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
2116         {
2117           reject_statement ();
2118           gfc_free_namespace (gfc_current_ns);
2119           goto loop;
2120         }
2121       break;
2122
2123     case ST_PROCEDURE:
2124     case ST_MODULE_PROC:        /* The module procedure matcher makes
2125                                    sure the context is correct.  */
2126       accept_statement (st);
2127       gfc_free_namespace (gfc_current_ns);
2128       goto loop;
2129
2130     case ST_END_INTERFACE:
2131       gfc_free_namespace (gfc_current_ns);
2132       gfc_current_ns = current_interface.ns;
2133       goto done;
2134
2135     default:
2136       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2137                  gfc_ascii_statement (st));
2138       reject_statement ();
2139       gfc_free_namespace (gfc_current_ns);
2140       goto loop;
2141     }
2142
2143
2144   /* Make sure that a generic interface has only subroutines or
2145      functions and that the generic name has the right attribute.  */
2146   if (current_interface.type == INTERFACE_GENERIC)
2147     {
2148       if (current_state == COMP_NONE)
2149         {
2150           if (new_state == COMP_FUNCTION)
2151             gfc_add_function (&sym->attr, sym->name, NULL);
2152           else if (new_state == COMP_SUBROUTINE)
2153             gfc_add_subroutine (&sym->attr, sym->name, NULL);
2154
2155           current_state = new_state;
2156         }
2157       else
2158         {
2159           if (new_state != current_state)
2160             {
2161               if (new_state == COMP_SUBROUTINE)
2162                 gfc_error ("SUBROUTINE at %C does not belong in a "
2163                            "generic function interface");
2164
2165               if (new_state == COMP_FUNCTION)
2166                 gfc_error ("FUNCTION at %C does not belong in a "
2167                            "generic subroutine interface");
2168             }
2169         }
2170     }
2171
2172   if (current_interface.type == INTERFACE_ABSTRACT)
2173     {
2174       gfc_new_block->attr.abstract = 1;
2175       if (gfc_is_intrinsic_typename (gfc_new_block->name))
2176         gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2177                    "cannot be the same as an intrinsic type",
2178                    gfc_new_block->name);
2179     }
2180
2181   push_state (&s2, new_state, gfc_new_block);
2182   accept_statement (st);
2183   prog_unit = gfc_new_block;
2184   prog_unit->formal_ns = gfc_current_ns;
2185   proc_locus = gfc_current_locus;
2186
2187 decl:
2188   /* Read data declaration statements.  */
2189   st = parse_spec (ST_NONE);
2190
2191   /* Since the interface block does not permit an IMPLICIT statement,
2192      the default type for the function or the result must be taken
2193      from the formal namespace.  */
2194   if (new_state == COMP_FUNCTION)
2195     {
2196         if (prog_unit->result == prog_unit
2197               && prog_unit->ts.type == BT_UNKNOWN)
2198           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2199         else if (prog_unit->result != prog_unit
2200                    && prog_unit->result->ts.type == BT_UNKNOWN)
2201           gfc_set_default_type (prog_unit->result, 1,
2202                                 prog_unit->formal_ns);
2203     }
2204
2205   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2206     {
2207       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2208                  gfc_ascii_statement (st));
2209       reject_statement ();
2210       goto decl;
2211     }
2212
2213   current_interface = save;
2214   gfc_add_interface (prog_unit);
2215   pop_state ();
2216
2217   if (current_interface.ns
2218         && current_interface.ns->proc_name
2219         && strcmp (current_interface.ns->proc_name->name,
2220                    prog_unit->name) == 0)
2221     gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2222                "enclosing procedure", prog_unit->name, &proc_locus);
2223
2224   goto loop;
2225
2226 done:
2227   pop_state ();
2228 }
2229
2230
2231 /* Associate function characteristics by going back to the function
2232    declaration and rematching the prefix.  */
2233
2234 static match
2235 match_deferred_characteristics (gfc_typespec * ts)
2236 {
2237   locus loc;
2238   match m = MATCH_ERROR;
2239   char name[GFC_MAX_SYMBOL_LEN + 1];
2240
2241   loc = gfc_current_locus;
2242
2243   gfc_current_locus = gfc_current_block ()->declared_at;
2244
2245   gfc_clear_error ();
2246   gfc_buffer_error (1);
2247   m = gfc_match_prefix (ts);
2248   gfc_buffer_error (0);
2249
2250   if (ts->type == BT_DERIVED)
2251     {
2252       ts->kind = 0;
2253
2254       if (!ts->derived || !ts->derived->components)
2255         m = MATCH_ERROR;
2256     }
2257
2258   /* Only permit one go at the characteristic association.  */
2259   if (ts->kind == -1)
2260     ts->kind = 0;
2261
2262   /* Set the function locus correctly.  If we have not found the
2263      function name, there is an error.  */
2264   gfc_match ("function% %n", name);
2265   if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
2266     {
2267       gfc_current_block ()->declared_at = gfc_current_locus;
2268       gfc_commit_symbols ();
2269     }
2270   else
2271     gfc_error_check ();
2272
2273   gfc_current_locus =loc;
2274   return m;
2275 }
2276
2277
2278 /* Check specification-expressions in the function result of the currently
2279    parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2280    For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2281    scope are not yet parsed so this has to be delayed up to parse_spec.  */
2282
2283 static void
2284 check_function_result_typed (void)
2285 {
2286   gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2287
2288   gcc_assert (gfc_current_state () == COMP_FUNCTION);
2289   gcc_assert (ts->type != BT_UNKNOWN);
2290
2291   /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
2292   /* TODO:  Extend when KIND type parameters are implemented.  */
2293   if (ts->type == BT_CHARACTER && ts->cl && ts->cl->length)
2294     gfc_expr_check_typed (ts->cl->length, gfc_current_ns, true);
2295 }
2296
2297
2298 /* Parse a set of specification statements.  Returns the statement
2299    that doesn't fit.  */
2300
2301 static gfc_statement
2302 parse_spec (gfc_statement st)
2303 {
2304   st_state ss;
2305   bool function_result_typed = false;
2306   bool bad_characteristic = false;
2307   gfc_typespec *ts;
2308
2309   verify_st_order (&ss, ST_NONE, false);
2310   if (st == ST_NONE)
2311     st = next_statement ();
2312
2313   /* If we are not inside a function or don't have a result specified so far,
2314      do nothing special about it.  */
2315   if (gfc_current_state () != COMP_FUNCTION)
2316     function_result_typed = true;
2317   else
2318     {
2319       gfc_symbol* proc = gfc_current_ns->proc_name;
2320       gcc_assert (proc);
2321
2322       if (proc->result->ts.type == BT_UNKNOWN)
2323         function_result_typed = true;
2324     }
2325
2326 loop:
2327
2328   /* If we find a statement that can not be followed by an IMPLICIT statement
2329      (and thus we can expect to see none any further), type the function result
2330      if it has not yet been typed.  Be careful not to give the END statement
2331      to verify_st_order!  */
2332   if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2333     {
2334       bool verify_now = false;
2335
2336       if (st == ST_END_FUNCTION)
2337         verify_now = true;
2338       else
2339         {
2340           st_state dummyss;
2341           verify_st_order (&dummyss, ST_NONE, false);
2342           verify_st_order (&dummyss, st, false);
2343
2344           if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2345             verify_now = true;
2346         }
2347
2348       if (verify_now)
2349         {
2350           check_function_result_typed ();
2351           function_result_typed = true;
2352         }
2353     }
2354
2355   switch (st)
2356     {
2357     case ST_NONE:
2358       unexpected_eof ();
2359
2360     case ST_IMPLICIT_NONE:
2361     case ST_IMPLICIT:
2362       if (!function_result_typed)
2363         {
2364           check_function_result_typed ();
2365           function_result_typed = true;
2366         }
2367       goto declSt;
2368
2369     case ST_FORMAT:
2370     case ST_ENTRY:
2371     case ST_DATA:       /* Not allowed in interfaces */
2372       if (gfc_current_state () == COMP_INTERFACE)
2373         break;
2374
2375       /* Fall through */
2376
2377     case ST_USE:
2378     case ST_IMPORT:
2379     case ST_PARAMETER:
2380     case ST_PUBLIC:
2381     case ST_PRIVATE:
2382     case ST_DERIVED_DECL:
2383     case_decl:
2384 declSt:
2385       if (verify_st_order (&ss, st, false) == FAILURE)
2386         {
2387           reject_statement ();
2388           st = next_statement ();
2389           goto loop;
2390         }
2391
2392       switch (st)
2393         {
2394         case ST_INTERFACE:
2395           parse_interface ();
2396           break;
2397
2398         case ST_DERIVED_DECL:
2399           parse_derived ();
2400           break;
2401
2402         case ST_PUBLIC:
2403         case ST_PRIVATE:
2404           if (gfc_current_state () != COMP_MODULE)
2405             {
2406               gfc_error ("%s statement must appear in a MODULE",
2407                          gfc_ascii_statement (st));
2408               break;
2409             }
2410
2411           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2412             {
2413               gfc_error ("%s statement at %C follows another accessibility "
2414                          "specification", gfc_ascii_statement (st));
2415               break;
2416             }
2417
2418           gfc_current_ns->default_access = (st == ST_PUBLIC)
2419             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2420
2421           break;
2422
2423         case ST_STATEMENT_FUNCTION:
2424           if (gfc_current_state () == COMP_MODULE)
2425             {
2426               unexpected_statement (st);
2427               break;
2428             }
2429
2430         default:
2431           break;
2432         }
2433
2434       accept_statement (st);
2435       st = next_statement ();
2436       goto loop;
2437
2438     case ST_ENUM:
2439       accept_statement (st);
2440       parse_enum();
2441       st = next_statement ();
2442       goto loop;
2443
2444     case ST_GET_FCN_CHARACTERISTICS:
2445       /* This statement triggers the association of a function's result
2446          characteristics.  */
2447       ts = &gfc_current_block ()->result->ts;
2448       if (match_deferred_characteristics (ts) != MATCH_YES)
2449         bad_characteristic = true;
2450
2451       st = next_statement ();
2452       goto loop;
2453
2454     default:
2455       break;
2456     }
2457
2458   /* If match_deferred_characteristics failed, then there is an error. */
2459   if (bad_characteristic)
2460     {
2461       ts = &gfc_current_block ()->result->ts;
2462       if (ts->type != BT_DERIVED)
2463         gfc_error ("Bad kind expression for function '%s' at %L",
2464                    gfc_current_block ()->name,
2465                    &gfc_current_block ()->declared_at);
2466       else
2467         gfc_error ("The type for function '%s' at %L is not accessible",
2468                    gfc_current_block ()->name,
2469                    &gfc_current_block ()->declared_at);
2470
2471       gfc_current_block ()->ts.kind = 0;
2472       /* Keep the derived type; if it's bad, it will be discovered later.  */
2473       if (!(ts->type == BT_DERIVED && ts->derived))
2474         ts->type = BT_UNKNOWN;
2475     }
2476
2477   return st;
2478 }
2479
2480
2481 /* Parse a WHERE block, (not a simple WHERE statement).  */
2482
2483 static void
2484 parse_where_block (void)
2485 {
2486   int seen_empty_else;
2487   gfc_code *top, *d;
2488   gfc_state_data s;
2489   gfc_statement st;
2490
2491   accept_statement (ST_WHERE_BLOCK);
2492   top = gfc_state_stack->tail;
2493
2494   push_state (&s, COMP_WHERE, gfc_new_block);
2495
2496   d = add_statement ();
2497   d->expr = top->expr;
2498   d->op = EXEC_WHERE;
2499
2500   top->expr = NULL;
2501   top->block = d;
2502
2503   seen_empty_else = 0;
2504
2505   do
2506     {
2507       st = next_statement ();
2508       switch (st)
2509         {
2510         case ST_NONE:
2511           unexpected_eof ();
2512
2513         case ST_WHERE_BLOCK:
2514           parse_where_block ();
2515           break;
2516
2517         case ST_ASSIGNMENT:
2518         case ST_WHERE:
2519           accept_statement (st);
2520           break;
2521
2522         case ST_ELSEWHERE:
2523           if (seen_empty_else)
2524             {
2525               gfc_error ("ELSEWHERE statement at %C follows previous "
2526                          "unmasked ELSEWHERE");
2527               break;
2528             }
2529
2530           if (new_st.expr == NULL)
2531             seen_empty_else = 1;
2532
2533           d = new_level (gfc_state_stack->head);
2534           d->op = EXEC_WHERE;
2535           d->expr = new_st.expr;
2536
2537           accept_statement (st);
2538
2539           break;
2540
2541         case ST_END_WHERE:
2542           accept_statement (st);
2543           break;
2544
2545         default:
2546           gfc_error ("Unexpected %s statement in WHERE block at %C",
2547                      gfc_ascii_statement (st));
2548           reject_statement ();
2549           break;
2550         }
2551     }
2552   while (st != ST_END_WHERE);
2553
2554   pop_state ();
2555 }
2556
2557
2558 /* Parse a FORALL block (not a simple FORALL statement).  */
2559
2560 static void
2561 parse_forall_block (void)
2562 {
2563   gfc_code *top, *d;
2564   gfc_state_data s;
2565   gfc_statement st;
2566
2567   accept_statement (ST_FORALL_BLOCK);
2568   top = gfc_state_stack->tail;
2569
2570   push_state (&s, COMP_FORALL, gfc_new_block);
2571
2572   d = add_statement ();
2573   d->op = EXEC_FORALL;
2574   top->block = d;
2575
2576   do
2577     {
2578       st = next_statement ();
2579       switch (st)
2580         {
2581
2582         case ST_ASSIGNMENT:
2583         case ST_POINTER_ASSIGNMENT:
2584         case ST_WHERE:
2585         case ST_FORALL:
2586           accept_statement (st);
2587           break;
2588
2589         case ST_WHERE_BLOCK:
2590           parse_where_block ();
2591           break;
2592
2593         case ST_FORALL_BLOCK:
2594           parse_forall_block ();
2595           break;
2596
2597         case ST_END_FORALL:
2598           accept_statement (st);
2599           break;
2600
2601         case ST_NONE:
2602           unexpected_eof ();
2603
2604         default:
2605           gfc_error ("Unexpected %s statement in FORALL block at %C",
2606                      gfc_ascii_statement (st));
2607
2608           reject_statement ();
2609           break;
2610         }
2611     }
2612   while (st != ST_END_FORALL);
2613
2614   pop_state ();
2615 }
2616
2617
2618 static gfc_statement parse_executable (gfc_statement);
2619
2620 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2621
2622 static void
2623 parse_if_block (void)
2624 {
2625   gfc_code *top, *d;
2626   gfc_statement st;
2627   locus else_locus;
2628   gfc_state_data s;
2629   int seen_else;
2630
2631   seen_else = 0;
2632   accept_statement (ST_IF_BLOCK);
2633
2634   top = gfc_state_stack->tail;
2635   push_state (&s, COMP_IF, gfc_new_block);
2636
2637   new_st.op = EXEC_IF;
2638   d = add_statement ();
2639
2640   d->expr = top->expr;
2641   top->expr = NULL;
2642   top->block = d;
2643
2644   do
2645     {
2646       st = parse_executable (ST_NONE);
2647
2648       switch (st)
2649         {
2650         case ST_NONE:
2651           unexpected_eof ();
2652
2653         case ST_ELSEIF:
2654           if (seen_else)
2655             {
2656               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2657                          "statement at %L", &else_locus);
2658
2659               reject_statement ();
2660               break;
2661             }
2662
2663           d = new_level (gfc_state_stack->head);
2664           d->op = EXEC_IF;
2665           d->expr = new_st.expr;
2666
2667           accept_statement (st);
2668
2669           break;
2670
2671         case ST_ELSE:
2672           if (seen_else)
2673             {
2674               gfc_error ("Duplicate ELSE statements at %L and %C",
2675                          &else_locus);
2676               reject_statement ();
2677               break;
2678             }
2679
2680           seen_else = 1;
2681           else_locus = gfc_current_locus;
2682
2683           d = new_level (gfc_state_stack->head);
2684           d->op = EXEC_IF;
2685
2686           accept_statement (st);
2687
2688           break;
2689
2690         case ST_ENDIF:
2691           break;
2692
2693         default:
2694           unexpected_statement (st);
2695           break;
2696         }
2697     }
2698   while (st != ST_ENDIF);
2699
2700   pop_state ();
2701   accept_statement (st);
2702 }
2703
2704
2705 /* Parse a SELECT block.  */
2706
2707 static void
2708 parse_select_block (void)
2709 {
2710   gfc_statement st;
2711   gfc_code *cp;
2712   gfc_state_data s;
2713
2714   accept_statement (ST_SELECT_CASE);
2715
2716   cp = gfc_state_stack->tail;
2717   push_state (&s, COMP_SELECT, gfc_new_block);
2718
2719   /* Make sure that the next statement is a CASE or END SELECT.  */
2720   for (;;)
2721     {
2722       st = next_statement ();
2723       if (st == ST_NONE)
2724         unexpected_eof ();
2725       if (st == ST_END_SELECT)
2726         {
2727           /* Empty SELECT CASE is OK.  */
2728           accept_statement (st);
2729           pop_state ();
2730           return;
2731         }
2732       if (st == ST_CASE)
2733         break;
2734
2735       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2736                  "CASE at %C");
2737
2738       reject_statement ();
2739     }
2740
2741   /* At this point, we're got a nonempty select block.  */
2742   cp = new_level (cp);
2743   *cp = new_st;
2744
2745   accept_statement (st);
2746
2747   do
2748     {
2749       st = parse_executable (ST_NONE);
2750       switch (st)
2751         {
2752         case ST_NONE:
2753           unexpected_eof ();
2754
2755         case ST_CASE:
2756           cp = new_level (gfc_state_stack->head);
2757           *cp = new_st;
2758           gfc_clear_new_st ();
2759
2760           accept_statement (st);
2761           /* Fall through */
2762
2763         case ST_END_SELECT:
2764           break;
2765
2766         /* Can't have an executable statement because of
2767            parse_executable().  */
2768         default:
2769           unexpected_statement (st);
2770           break;
2771         }
2772     }
2773   while (st != ST_END_SELECT);
2774
2775   pop_state ();
2776   accept_statement (st);
2777 }
2778
2779
2780 /* Given a symbol, make sure it is not an iteration variable for a DO
2781    statement.  This subroutine is called when the symbol is seen in a
2782    context that causes it to become redefined.  If the symbol is an
2783    iterator, we generate an error message and return nonzero.  */
2784
2785 int
2786 gfc_check_do_variable (gfc_symtree *st)
2787 {
2788   gfc_state_data *s;
2789
2790   for (s=gfc_state_stack; s; s = s->previous)
2791     if (s->do_variable == st)
2792       {
2793         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2794                       "loop beginning at %L", st->name, &s->head->loc);
2795         return 1;
2796       }
2797
2798   return 0;
2799 }
2800
2801
2802 /* Checks to see if the current statement label closes an enddo.
2803    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2804    an error) if it incorrectly closes an ENDDO.  */
2805
2806 static int
2807 check_do_closure (void)
2808 {
2809   gfc_state_data *p;
2810
2811   if (gfc_statement_label == NULL)
2812     return 0;
2813
2814   for (p = gfc_state_stack; p; p = p->previous)
2815     if (p->state == COMP_DO)
2816       break;
2817
2818   if (p == NULL)
2819     return 0;           /* No loops to close */
2820
2821   if (p->ext.end_do_label == gfc_statement_label)
2822     {
2823
2824       if (p == gfc_state_stack)
2825         return 1;
2826
2827       gfc_error ("End of nonblock DO statement at %C is within another block");
2828       return 2;
2829     }
2830
2831   /* At this point, the label doesn't terminate the innermost loop.
2832      Make sure it doesn't terminate another one.  */
2833   for (; p; p = p->previous)
2834     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2835       {
2836         gfc_error ("End of nonblock DO statement at %C is interwoven "
2837                    "with another DO loop");
2838         return 2;
2839       }
2840
2841   return 0;
2842 }
2843
2844
2845 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
2846    handled inside of parse_executable(), because they aren't really
2847    loop statements.  */
2848
2849 static void
2850 parse_do_block (void)
2851 {
2852   gfc_statement st;
2853   gfc_code *top;
2854   gfc_state_data s;
2855   gfc_symtree *stree;
2856
2857   s.ext.end_do_label = new_st.label;
2858
2859   if (new_st.ext.iterator != NULL)
2860     stree = new_st.ext.iterator->var->symtree;
2861   else
2862     stree = NULL;
2863
2864   accept_statement (ST_DO);
2865
2866   top = gfc_state_stack->tail;
2867   push_state (&s, COMP_DO, gfc_new_block);
2868
2869   s.do_variable = stree;
2870
2871   top->block = new_level (top);
2872   top->block->op = EXEC_DO;
2873
2874 loop:
2875   st = parse_executable (ST_NONE);
2876
2877   switch (st)
2878     {
2879     case ST_NONE:
2880       unexpected_eof ();
2881
2882     case ST_ENDDO:
2883       if (s.ext.end_do_label != NULL
2884           && s.ext.end_do_label != gfc_statement_label)
2885         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2886                        "DO label");
2887
2888       if (gfc_statement_label != NULL)
2889         {
2890           new_st.op = EXEC_NOP;
2891           add_statement ();
2892         }
2893       break;
2894
2895     case ST_IMPLIED_ENDDO:
2896      /* If the do-stmt of this DO construct has a do-construct-name,
2897         the corresponding end-do must be an end-do-stmt (with a matching
2898         name, but in that case we must have seen ST_ENDDO first).
2899         We only complain about this in pedantic mode.  */
2900      if (gfc_current_block () != NULL)
2901         gfc_error_now ("named block DO at %L requires matching ENDDO name",
2902                        &gfc_current_block()->declared_at);
2903
2904       break;
2905
2906     default:
2907       unexpected_statement (st);
2908       goto loop;
2909     }
2910
2911   pop_state ();
2912   accept_statement (st);
2913 }
2914
2915
2916 /* Parse the statements of OpenMP do/parallel do.  */
2917
2918 static gfc_statement
2919 parse_omp_do (gfc_statement omp_st)
2920 {
2921   gfc_statement st;
2922   gfc_code *cp, *np;
2923   gfc_state_data s;
2924
2925   accept_statement (omp_st);
2926
2927   cp = gfc_state_stack->tail;
2928   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2929   np = new_level (cp);
2930   np->op = cp->op;
2931   np->block = NULL;
2932
2933   for (;;)
2934     {
2935       st = next_statement ();
2936       if (st == ST_NONE)
2937         unexpected_eof ();
2938       else if (st == ST_DO)
2939         break;
2940       else
2941         unexpected_statement (st);
2942     }
2943
2944   parse_do_block ();
2945   if (gfc_statement_label != NULL
2946       && gfc_state_stack->previous != NULL
2947       && gfc_state_stack->previous->state == COMP_DO
2948       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2949     {
2950       /* In
2951          DO 100 I=1,10
2952            !$OMP DO
2953              DO J=1,10
2954              ...
2955              100 CONTINUE
2956          there should be no !$OMP END DO.  */
2957       pop_state ();
2958       return ST_IMPLIED_ENDDO;
2959     }
2960
2961   check_do_closure ();
2962   pop_state ();
2963
2964   st = next_statement ();
2965   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2966     {
2967       if (new_st.op == EXEC_OMP_END_NOWAIT)
2968         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2969       else
2970         gcc_assert (new_st.op == EXEC_NOP);
2971       gfc_clear_new_st ();
2972       gfc_commit_symbols ();
2973       gfc_warning_check ();
2974       st = next_statement ();
2975     }
2976   return st;
2977 }
2978
2979
2980 /* Parse the statements of OpenMP atomic directive.  */
2981
2982 static void
2983 parse_omp_atomic (void)
2984 {
2985   gfc_statement st;
2986   gfc_code *cp, *np;
2987   gfc_state_data s;
2988
2989   accept_statement (ST_OMP_ATOMIC);
2990
2991   cp = gfc_state_stack->tail;
2992   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2993   np = new_level (cp);
2994   np->op = cp->op;
2995   np->block = NULL;
2996
2997   for (;;)
2998     {
2999       st = next_statement ();
3000       if (st == ST_NONE)
3001         unexpected_eof ();
3002       else if (st == ST_ASSIGNMENT)
3003         break;
3004       else
3005         unexpected_statement (st);
3006     }
3007
3008   accept_statement (st);
3009
3010   pop_state ();
3011 }
3012
3013
3014 /* Parse the statements of an OpenMP structured block.  */
3015
3016 static void
3017 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3018 {
3019   gfc_statement st, omp_end_st;
3020   gfc_code *cp, *np;
3021   gfc_state_data s;
3022
3023   accept_statement (omp_st);
3024
3025   cp = gfc_state_stack->tail;
3026   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3027   np = new_level (cp);
3028   np->op = cp->op;
3029   np->block = NULL;
3030
3031   switch (omp_st)
3032     {
3033     case ST_OMP_PARALLEL:
3034       omp_end_st = ST_OMP_END_PARALLEL;
3035       break;
3036     case ST_OMP_PARALLEL_SECTIONS:
3037       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3038       break;
3039     case ST_OMP_SECTIONS:
3040       omp_end_st = ST_OMP_END_SECTIONS;
3041       break;
3042     case ST_OMP_ORDERED:
3043       omp_end_st = ST_OMP_END_ORDERED;
3044       break;
3045     case ST_OMP_CRITICAL:
3046       omp_end_st = ST_OMP_END_CRITICAL;
3047       break;
3048     case ST_OMP_MASTER:
3049       omp_end_st = ST_OMP_END_MASTER;
3050       break;
3051     case ST_OMP_SINGLE:
3052       omp_end_st = ST_OMP_END_SINGLE;
3053       break;
3054     case ST_OMP_TASK:
3055       omp_end_st = ST_OMP_END_TASK;
3056       break;
3057     case ST_OMP_WORKSHARE:
3058       omp_end_st = ST_OMP_END_WORKSHARE;
3059       break;
3060     case ST_OMP_PARALLEL_WORKSHARE:
3061       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3062       break;
3063     default:
3064       gcc_unreachable ();
3065     }
3066
3067   do
3068     {
3069       if (workshare_stmts_only)
3070         {
3071           /* Inside of !$omp workshare, only
3072              scalar assignments
3073              array assignments
3074              where statements and constructs
3075              forall statements and constructs
3076              !$omp atomic
3077              !$omp critical
3078              !$omp parallel
3079              are allowed.  For !$omp critical these
3080              restrictions apply recursively.  */
3081           bool cycle = true;
3082
3083           st = next_statement ();
3084           for (;;)
3085             {
3086               switch (st)
3087                 {
3088                 case ST_NONE:
3089                   unexpected_eof ();
3090
3091                 case ST_ASSIGNMENT:
3092                 case ST_WHERE:
3093                 case ST_FORALL:
3094                   accept_statement (st);
3095                   break;
3096
3097                 case ST_WHERE_BLOCK:
3098                   parse_where_block ();
3099                   break;
3100
3101                 case ST_FORALL_BLOCK:
3102                   parse_forall_block ();
3103                   break;
3104
3105                 case ST_OMP_PARALLEL:
3106                 case ST_OMP_PARALLEL_SECTIONS:
3107                   parse_omp_structured_block (st, false);
3108                   break;
3109
3110                 case ST_OMP_PARALLEL_WORKSHARE:
3111                 case ST_OMP_CRITICAL:
3112                   parse_omp_structured_block (st, true);
3113                   break;
3114
3115                 case ST_OMP_PARALLEL_DO:
3116                   st = parse_omp_do (st);
3117                   continue;
3118
3119                 case ST_OMP_ATOMIC:
3120                   parse_omp_atomic ();
3121                   break;
3122
3123                 default:
3124                   cycle = false;
3125                   break;
3126                 }
3127
3128               if (!cycle)
3129                 break;
3130
3131               st = next_statement ();
3132             }
3133         }
3134       else
3135         st = parse_executable (ST_NONE);
3136       if (st == ST_NONE)
3137         unexpected_eof ();
3138       else if (st == ST_OMP_SECTION
3139                && (omp_st == ST_OMP_SECTIONS
3140                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
3141         {
3142           np = new_level (np);
3143           np->op = cp->op;
3144           np->block = NULL;
3145         }
3146       else if (st != omp_end_st)
3147         unexpected_statement (st);
3148     }
3149   while (st != omp_end_st);
3150
3151   switch (new_st.op)
3152     {
3153     case EXEC_OMP_END_NOWAIT:
3154       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3155       break;
3156     case EXEC_OMP_CRITICAL:
3157       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3158           || (new_st.ext.omp_name != NULL
3159               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3160         gfc_error ("Name after !$omp critical and !$omp end critical does "
3161                    "not match at %C");
3162       gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
3163       break;
3164     case EXEC_OMP_END_SINGLE:
3165       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3166         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3167       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3168       gfc_free_omp_clauses (new_st.ext.omp_clauses);
3169       break;
3170     case EXEC_NOP:
3171       break;
3172     default:
3173       gcc_unreachable ();
3174     }
3175
3176   gfc_clear_new_st ();
3177   gfc_commit_symbols ();
3178   gfc_warning_check ();
3179   pop_state ();
3180 }
3181
3182
3183 /* Accept a series of executable statements.  We return the first
3184    statement that doesn't fit to the caller.  Any block statements are
3185    passed on to the correct handler, which usually passes the buck
3186    right back here.  */
3187
3188 static gfc_statement
3189 parse_executable (gfc_statement st)
3190 {
3191   int close_flag;
3192
3193   if (st == ST_NONE)
3194     st = next_statement ();
3195
3196   for (;;)
3197     {
3198       close_flag = check_do_closure ();
3199       if (close_flag)
3200         switch (st)
3201           {
3202           case ST_GOTO:
3203           case ST_END_PROGRAM:
3204           case ST_RETURN:
3205           case ST_EXIT:
3206           case ST_END_FUNCTION:
3207           case ST_CYCLE:
3208           case ST_PAUSE:
3209           case ST_STOP:
3210           case ST_END_SUBROUTINE:
3211
3212           case ST_DO:
3213           case ST_FORALL:
3214           case ST_WHERE:
3215           case ST_SELECT_CASE:
3216             gfc_error ("%s statement at %C cannot terminate a non-block "
3217                        "DO loop", gfc_ascii_statement (st));
3218             break;
3219
3220           default:
3221             break;
3222           }
3223
3224       switch (st)
3225         {
3226         case ST_NONE:
3227           unexpected_eof ();
3228
3229         case ST_FORMAT:
3230         case ST_DATA:
3231         case ST_ENTRY:
3232         case_executable:
3233           accept_statement (st);
3234           if (close_flag == 1)
3235             return ST_IMPLIED_ENDDO;
3236           break;
3237
3238         case ST_IF_BLOCK:
3239           parse_if_block ();
3240           break;
3241
3242         case ST_SELECT_CASE:
3243           parse_select_block ();
3244           break;
3245
3246         case ST_DO:
3247           parse_do_block ();
3248           if (check_do_closure () == 1)
3249             return ST_IMPLIED_ENDDO;
3250           break;
3251
3252         case ST_WHERE_BLOCK:
3253           parse_where_block ();
3254           break;
3255
3256         case ST_FORALL_BLOCK:
3257           parse_forall_block ();
3258           break;
3259
3260         case ST_OMP_PARALLEL:
3261         case ST_OMP_PARALLEL_SECTIONS:
3262         case ST_OMP_SECTIONS:
3263         case ST_OMP_ORDERED:
3264         case ST_OMP_CRITICAL:
3265         case ST_OMP_MASTER:
3266         case ST_OMP_SINGLE:
3267         case ST_OMP_TASK:
3268           parse_omp_structured_block (st, false);
3269           break;
3270
3271         case ST_OMP_WORKSHARE:
3272         case ST_OMP_PARALLEL_WORKSHARE:
3273           parse_omp_structured_block (st, true);
3274           break;
3275
3276         case ST_OMP_DO:
3277         case ST_OMP_PARALLEL_DO:
3278           st = parse_omp_do (st);
3279           if (st == ST_IMPLIED_ENDDO)
3280             return st;
3281           continue;
3282
3283         case ST_OMP_ATOMIC:
3284           parse_omp_atomic ();
3285           break;
3286
3287         default:
3288           return st;
3289         }
3290
3291       st = next_statement ();
3292     }
3293 }
3294
3295
3296 /* Parse a series of contained program units.  */
3297
3298 static void parse_progunit (gfc_statement);
3299
3300
3301 /* Fix the symbols for sibling functions.  These are incorrectly added to
3302    the child namespace as the parser didn't know about this procedure.  */
3303
3304 static void
3305 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3306 {
3307   gfc_namespace *ns;
3308   gfc_symtree *st;
3309   gfc_symbol *old_sym;
3310
3311   sym->attr.referenced = 1;
3312   for (ns = siblings; ns; ns = ns->sibling)
3313     {
3314       gfc_find_sym_tree (sym->name, ns, 0, &st);
3315
3316       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3317         continue;
3318
3319       old_sym = st->n.sym;
3320       if (old_sym->ns == ns
3321             && !old_sym->attr.contained
3322
3323             /* By 14.6.1.3, host association should be excluded
3324                for the following.  */
3325             && !(old_sym->attr.external
3326                   || (old_sym->ts.type != BT_UNKNOWN
3327                         && !old_sym->attr.implicit_type)
3328                   || old_sym->attr.flavor == FL_PARAMETER
3329                   || old_sym->attr.in_common
3330                   || old_sym->attr.in_equivalence
3331                   || old_sym->attr.data
3332                   || old_sym->attr.dummy
3333                   || old_sym->attr.result
3334                   || old_sym->attr.dimension
3335                   || old_sym->attr.allocatable
3336                   || old_sym->attr.intrinsic
3337                   || old_sym->attr.generic
3338                   || old_sym->attr.flavor == FL_NAMELIST
3339                   || old_sym->attr.proc == PROC_ST_FUNCTION))
3340         {
3341           /* Replace it with the symbol from the parent namespace.  */
3342           st->n.sym = sym;
3343           sym->refs++;
3344
3345           /* Free the old (local) symbol.  */
3346           old_sym->refs--;
3347           if (old_sym->refs == 0)
3348             gfc_free_symbol (old_sym);
3349         }
3350
3351       /* Do the same for any contained procedures.  */
3352       gfc_fixup_sibling_symbols (sym, ns->contained);
3353     }
3354 }
3355
3356 static void
3357 parse_contained (int module)
3358 {
3359   gfc_namespace *ns, *parent_ns, *tmp;
3360   gfc_state_data s1, s2;
3361   gfc_statement st;
3362   gfc_symbol *sym;
3363   gfc_entry_list *el;
3364   int contains_statements = 0;
3365   int seen_error = 0;
3366
3367   push_state (&s1, COMP_CONTAINS, NULL);
3368   parent_ns = gfc_current_ns;
3369
3370   do
3371     {
3372       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3373
3374       gfc_current_ns->sibling = parent_ns->contained;
3375       parent_ns->contained = gfc_current_ns;
3376
3377  next:
3378       /* Process the next available statement.  We come here if we got an error
3379          and rejected the last statement.  */
3380       st = next_statement ();
3381
3382       switch (st)
3383         {
3384         case ST_NONE:
3385           unexpected_eof ();
3386
3387         case ST_FUNCTION:
3388         case ST_SUBROUTINE:
3389           contains_statements = 1;
3390           accept_statement (st);
3391
3392           push_state (&s2,
3393                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3394                       gfc_new_block);
3395
3396           /* For internal procedures, create/update the symbol in the
3397              parent namespace.  */
3398
3399           if (!module)
3400             {
3401               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3402                 gfc_error ("Contained procedure '%s' at %C is already "
3403                            "ambiguous", gfc_new_block->name);
3404               else
3405                 {
3406                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3407                                          &gfc_new_block->declared_at) ==
3408                       SUCCESS)
3409                     {
3410                       if (st == ST_FUNCTION)
3411                         gfc_add_function (&sym->attr, sym->name,
3412                                           &gfc_new_block->declared_at);
3413                       else
3414                         gfc_add_subroutine (&sym->attr, sym->name,
3415                                             &gfc_new_block->declared_at);
3416                     }
3417                 }
3418
3419               gfc_commit_symbols ();
3420             }
3421           else
3422             sym = gfc_new_block;
3423
3424           /* Mark this as a contained function, so it isn't replaced
3425              by other module functions.  */
3426           sym->attr.contained = 1;
3427           sym->attr.referenced = 1;
3428
3429           parse_progunit (ST_NONE);
3430
3431           /* Fix up any sibling functions that refer to this one.  */
3432           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3433           /* Or refer to any of its alternate entry points.  */
3434           for (el = gfc_current_ns->entries; el; el = el->next)
3435             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3436
3437           gfc_current_ns->code = s2.head;
3438           gfc_current_ns = parent_ns;
3439
3440           pop_state ();
3441           break;
3442
3443         /* These statements are associated with the end of the host unit.  */
3444         case ST_END_FUNCTION:
3445         case ST_END_MODULE:
3446         case ST_END_PROGRAM:
3447         case ST_END_SUBROUTINE:
3448           accept_statement (st);
3449           break;
3450
3451         default:
3452           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3453                      gfc_ascii_statement (st));
3454           reject_statement ();
3455           seen_error = 1;
3456           goto next;
3457           break;
3458         }
3459     }
3460   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3461          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3462
3463   /* The first namespace in the list is guaranteed to not have
3464      anything (worthwhile) in it.  */
3465   tmp = gfc_current_ns;
3466   gfc_current_ns = parent_ns;
3467   if (seen_error && tmp->refs > 1)
3468     gfc_free_namespace (tmp);
3469
3470   ns = gfc_current_ns->contained;
3471   gfc_current_ns->contained = ns->sibling;
3472   gfc_free_namespace (ns);
3473
3474   pop_state ();
3475   if (!contains_statements)
3476     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3477                     "FUNCTION or SUBROUTINE statement at %C");
3478 }
3479
3480
3481 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
3482
3483 static void
3484 parse_progunit (gfc_statement st)
3485 {
3486   gfc_state_data *p;
3487   int n;
3488
3489   st = parse_spec (st);
3490   switch (st)
3491     {
3492     case ST_NONE:
3493       unexpected_eof ();
3494
3495     case ST_CONTAINS:
3496       goto contains;
3497
3498     case_end:
3499       accept_statement (st);
3500       goto done;
3501
3502     default:
3503       break;
3504     }
3505
3506   if (gfc_current_state () == COMP_FUNCTION)
3507     gfc_check_function_type (gfc_current_ns);
3508
3509 loop:
3510   for (;;)
3511     {
3512       st = parse_executable (st);
3513
3514       switch (st)
3515         {
3516         case ST_NONE:
3517           unexpected_eof ();
3518
3519         case ST_CONTAINS:
3520           goto contains;
3521
3522         case_end:
3523           accept_statement (st);
3524           goto done;
3525
3526         default:
3527           break;
3528         }
3529
3530       unexpected_statement (st);
3531       reject_statement ();
3532       st = next_statement ();
3533     }
3534
3535 contains:
3536   n = 0;
3537
3538   for (p = gfc_state_stack; p; p = p->previous)
3539     if (p->state == COMP_CONTAINS)
3540       n++;
3541
3542   if (gfc_find_state (COMP_MODULE) == SUCCESS)
3543     n--;
3544
3545   if (n > 0)
3546     {
3547       gfc_error ("CONTAINS statement at %C is already in a contained "
3548                  "program unit");
3549       st = next_statement ();
3550       goto loop;
3551     }
3552
3553   parse_contained (0);
3554
3555 done:
3556   gfc_current_ns->code = gfc_state_stack->head;
3557 }
3558
3559
3560 /* Come here to complain about a global symbol already in use as
3561    something else.  */
3562
3563 void
3564 gfc_global_used (gfc_gsymbol *sym, locus *where)
3565 {
3566   const char *name;
3567
3568   if (where == NULL)
3569     where = &gfc_current_locus;
3570
3571   switch(sym->type)
3572     {
3573     case GSYM_PROGRAM:
3574       name = "PROGRAM";
3575       break;
3576     case GSYM_FUNCTION:
3577       name = "FUNCTION";
3578       break;
3579     case GSYM_SUBROUTINE:
3580       name = "SUBROUTINE";
3581       break;
3582     case GSYM_COMMON:
3583       name = "COMMON";
3584       break;
3585     case GSYM_BLOCK_DATA:
3586       name = "BLOCK DATA";
3587       break;
3588     case GSYM_MODULE:
3589       name = "MODULE";
3590       break;
3591     default:
3592       gfc_internal_error ("gfc_global_used(): Bad type");
3593       name = NULL;
3594     }
3595
3596   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3597               sym->name, where, name, &sym->where);
3598 }
3599
3600
3601 /* Parse a block data program unit.  */
3602
3603 static void
3604 parse_block_data (void)
3605 {
3606   gfc_statement st;
3607   static locus blank_locus;
3608   static int blank_block=0;
3609   gfc_gsymbol *s;
3610
3611   gfc_current_ns->proc_name = gfc_new_block;
3612   gfc_current_ns->is_block_data = 1;
3613
3614   if (gfc_new_block == NULL)
3615     {
3616       if (blank_block)
3617        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3618                   "prior BLOCK DATA at %L", &blank_locus);
3619       else
3620        {
3621          blank_block = 1;
3622          blank_locus = gfc_current_locus;
3623        }
3624     }
3625   else
3626     {
3627       s = gfc_get_gsymbol (gfc_new_block->name);
3628       if (s->defined
3629           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3630        gfc_global_used(s, NULL);
3631       else
3632        {
3633          s->type = GSYM_BLOCK_DATA;
3634          s->where = gfc_current_locus;
3635          s->defined = 1;
3636        }
3637     }
3638
3639   st = parse_spec (ST_NONE);
3640
3641   while (st != ST_END_BLOCK_DATA)
3642     {
3643       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3644                  gfc_ascii_statement (st));
3645       reject_statement ();
3646       st = next_statement ();
3647     }
3648 }
3649
3650
3651 /* Parse a module subprogram.  */
3652
3653 static void
3654 parse_module (void)
3655 {
3656   gfc_statement st;
3657   gfc_gsymbol *s;
3658
3659   s = gfc_get_gsymbol (gfc_new_block->name);
3660   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3661     gfc_global_used(s, NULL);
3662   else
3663     {
3664       s->type = GSYM_MODULE;
3665       s->where = gfc_current_locus;
3666       s->defined = 1;
3667     }
3668
3669   st = parse_spec (ST_NONE);
3670
3671 loop:
3672   switch (st)
3673     {
3674     case ST_NONE:
3675       unexpected_eof ();
3676
3677     case ST_CONTAINS:
3678       parse_contained (1);
3679       break;
3680
3681     case ST_END_MODULE:
3682       accept_statement (st);
3683       break;
3684
3685     default:
3686       gfc_error ("Unexpected %s statement in MODULE at %C",
3687                  gfc_ascii_statement (st));
3688
3689       reject_statement ();
3690       st = next_statement ();
3691       goto loop;
3692     }
3693 }
3694
3695
3696 /* Add a procedure name to the global symbol table.  */
3697
3698 static void
3699 add_global_procedure (int sub)
3700 {
3701   gfc_gsymbol *s;
3702
3703   s = gfc_get_gsymbol(gfc_new_block->name);
3704
3705   if (s->defined
3706       || (s->type != GSYM_UNKNOWN
3707           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3708     gfc_global_used(s, NULL);
3709   else
3710     {
3711       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3712       s->where = gfc_current_locus;
3713       s->defined = 1;
3714     }
3715 }
3716
3717
3718 /* Add a program to the global symbol table.  */
3719
3720 static void
3721 add_global_program (void)
3722 {
3723   gfc_gsymbol *s;
3724
3725   if (gfc_new_block == NULL)
3726     return;
3727   s = gfc_get_gsymbol (gfc_new_block->name);
3728
3729   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3730     gfc_global_used(s, NULL);
3731   else
3732     {
3733       s->type = GSYM_PROGRAM;
3734       s->where = gfc_current_locus;
3735       s->defined = 1;
3736     }
3737 }
3738
3739
3740 /* Top level parser.  */
3741
3742 gfc_try
3743 gfc_parse_file (void)
3744 {
3745   int seen_program, errors_before, errors;
3746   gfc_state_data top, s;
3747   gfc_statement st;
3748   locus prog_locus;
3749
3750   gfc_start_source_files ();
3751
3752   top.state = COMP_NONE;
3753   top.sym = NULL;
3754   top.previous = NULL;
3755   top.head = top.tail = NULL;
3756   top.do_variable = NULL;
3757
3758   gfc_state_stack = &top;
3759
3760   gfc_clear_new_st ();
3761
3762   gfc_statement_label = NULL;
3763
3764   if (setjmp (eof_buf))
3765     return FAILURE;     /* Come here on unexpected EOF */
3766
3767   seen_program = 0;
3768
3769   /* Exit early for empty files.  */
3770   if (gfc_at_eof ())
3771     goto done;
3772
3773 loop:
3774   gfc_init_2 ();
3775   st = next_statement ();
3776   switch (st)
3777     {
3778     case ST_NONE:
3779       gfc_done_2 ();
3780       goto done;
3781
3782     case ST_PROGRAM:
3783       if (seen_program)
3784         goto duplicate_main;
3785       seen_program = 1;
3786       prog_locus = gfc_current_locus;
3787
3788       push_state (&s, COMP_PROGRAM, gfc_new_block);
3789       main_program_symbol(gfc_current_ns, gfc_new_block->name);
3790       accept_statement (st);
3791       add_global_program ();
3792       parse_progunit (ST_NONE);
3793       break;
3794
3795     case ST_SUBROUTINE:
3796       add_global_procedure (1);
3797       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3798       accept_statement (st);
3799       parse_progunit (ST_NONE);
3800       break;
3801
3802     case ST_FUNCTION:
3803       add_global_procedure (0);
3804       push_state (&s, COMP_FUNCTION, gfc_new_block);
3805       accept_statement (st);
3806       parse_progunit (ST_NONE);
3807       break;
3808
3809     case ST_BLOCK_DATA:
3810       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3811       accept_statement (st);
3812       parse_block_data ();
3813       break;
3814
3815     case ST_MODULE:
3816       push_state (&s, COMP_MODULE, gfc_new_block);
3817       accept_statement (st);
3818
3819       gfc_get_errors (NULL, &errors_before);
3820       parse_module ();
3821       break;
3822
3823     /* Anything else starts a nameless main program block.  */
3824     default:
3825       if (seen_program)
3826         goto duplicate_main;
3827       seen_program = 1;
3828       prog_locus = gfc_current_locus;
3829
3830       push_state (&s, COMP_PROGRAM, gfc_new_block);
3831       main_program_symbol (gfc_current_ns, "MAIN__");
3832       parse_progunit (st);
3833       break;
3834     }
3835
3836   gfc_current_ns->code = s.head;
3837
3838   gfc_resolve (gfc_current_ns);
3839
3840   /* Dump the parse tree if requested.  */
3841   if (gfc_option.dump_parse_tree)
3842     gfc_dump_parse_tree (gfc_current_ns, stdout);
3843
3844   gfc_get_errors (NULL, &errors);
3845   if (s.state == COMP_MODULE)
3846     {
3847       gfc_dump_module (s.sym->name, errors_before == errors);
3848       if (errors == 0)
3849         gfc_generate_module_code (gfc_current_ns);
3850     }
3851   else
3852     {
3853       if (errors == 0)
3854         gfc_generate_code (gfc_current_ns);
3855     }
3856
3857   pop_state ();
3858   gfc_done_2 ();
3859   goto loop;
3860
3861 done:
3862   gfc_end_source_files ();
3863   return SUCCESS;
3864
3865 duplicate_main:
3866   /* If we see a duplicate main program, shut down.  If the second
3867      instance is an implied main program, i.e. data decls or executable
3868      statements, we're in for lots of errors.  */
3869   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3870   reject_statement ();
3871   gfc_done_2 ();
3872   return SUCCESS;
3873 }