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