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