gcc/fortran/parse.c

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