gcc/fortran/parse.c

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