gcc/fortran/parse.c

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