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