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