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