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