gcc/fortran/parse.c

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