gcc/fortran/parse.c

   1 /* Main parser.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
   3    Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23
  24 #include "config.h"
  25 #include "system.h"
  26 #include <setjmp.h>
  27 #include "gfortran.h"
  28 #include "match.h"
  29 #include "parse.h"
  30
  31 /* Current statement label.  Zero means no statement label.  Because
  32    new_st can get wiped during statement matching, we have to keep it
  33    separate.  */
  34
  35 gfc_st_label *gfc_statement_label;
  36
  37 static locus label_locus;
  38 static jmp_buf eof_buf;
  39
  40 gfc_state_data *gfc_state_stack;
  41
  42 /* TODO: Re-order functions to kill these forward decls.  */
  43 static void check_statement_label (gfc_statement);
  44 static void undo_new_statement (void);
  45 static void reject_statement (void);
  46
  47 /* A sort of half-matching function.  We try to match the word on the
  48    input with the passed string.  If this succeeds, we call the
  49    keyword-dependent matching function that will match the rest of the
  50    statement.  For single keywords, the matching subroutine is
  51    gfc_match_eos().  */
  52
  53 static match
  54 match_word (const char *str, match (*subr) (void), locus * old_locus)
  55 {
  56   match m;
  57
  58   if (str != NULL)
  59     {
  60       m = gfc_match (str);
  61       if (m != MATCH_YES)
  62         return m;
  63     }
  64
  65   m = (*subr) ();
  66
  67   if (m != MATCH_YES)
  68     {
  69       gfc_current_locus = *old_locus;
  70       reject_statement ();
  71     }
  72
  73   return m;
  74 }
  75
  76
  77 /* Figure out what the next statement is, (mostly) regardless of
  78    proper ordering.  The do...while(0) is there to prevent if/else
  79    ambiguity.  */
  80
  81 #define match(keyword, subr, st)                                \
  82     do {                                                        \
  83       if (match_word(keyword, subr, &old_locus) == MATCH_YES)   \
  84         return st;                                              \
  85       else                                                      \
  86         undo_new_statement ();                                  \
  87     } while (0);
  88
  89 static gfc_statement
  90 decode_statement (void)
  91 {
  92   gfc_statement st;
  93   locus old_locus;
  94   match m;
  95   int c;
  96
  97 #ifdef GFC_DEBUG
  98   gfc_symbol_state ();
  99 #endif
 100
 101   gfc_clear_error ();   /* Clear any pending errors.  */
 102   gfc_clear_warning (); /* Clear any pending warnings.  */
 103
 104   if (gfc_match_eos () == MATCH_YES)
 105     return ST_NONE;
 106
 107   old_locus = gfc_current_locus;
 108
 109   /* Try matching a data declaration or function declaration. The
 110       input "REALFUNCTIONA(N)" can mean several things in different
 111       contexts, so it (and its relatives) get special treatment.  */
 112
 113   if (gfc_current_state () == COMP_NONE
 114       || gfc_current_state () == COMP_INTERFACE
 115       || gfc_current_state () == COMP_CONTAINS)
 116     {
 117       m = gfc_match_function_decl ();
 118       if (m == MATCH_YES)
 119         return ST_FUNCTION;
 120       else if (m == MATCH_ERROR)
 121         reject_statement ();
 122
 123       gfc_undo_symbols ();
 124       gfc_current_locus = old_locus;
 125     }
 126
 127   /* Match statements whose error messages are meant to be overwritten
 128      by something better.  */
 129
 130   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
 131   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
 132   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 133
 134   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 135   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 136
 137   /* Try to match a subroutine statement, which has the same optional
 138      prefixes that functions can have.  */
 139
 140   if (gfc_match_subroutine () == MATCH_YES)
 141     return ST_SUBROUTINE;
 142   gfc_undo_symbols ();
 143   gfc_current_locus = old_locus;
 144
 145   /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
 146      might begin with a block label.  The match functions for these
 147      statements are unusual in that their keyword is not seen before
 148      the matcher is called.  */
 149
 150   if (gfc_match_if (&st) == MATCH_YES)
 151     return st;
 152   gfc_undo_symbols ();
 153   gfc_current_locus = old_locus;
 154
 155   if (gfc_match_where (&st) == MATCH_YES)
 156     return st;
 157   gfc_undo_symbols ();
 158   gfc_current_locus = old_locus;
 159
 160   if (gfc_match_forall (&st) == MATCH_YES)
 161     return st;
 162   gfc_undo_symbols ();
 163   gfc_current_locus = old_locus;
 164
 165   match (NULL, gfc_match_do, ST_DO);
 166   match (NULL, gfc_match_select, ST_SELECT_CASE);
 167
 168   /* General statement matching: Instead of testing every possible
 169      statement, we eliminate most possibilities by peeking at the
 170      first character.  */
 171
 172   c = gfc_peek_char ();
 173
 174   switch (c)
 175     {
 176     case 'a':
 177       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
 178       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
 179       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
 180       break;
 181
 182     case 'b':
 183       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
 184       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
 185       break;
 186
 187     case 'c':
 188       match ("call", gfc_match_call, ST_CALL);
 189       match ("close", gfc_match_close, ST_CLOSE);
 190       match ("continue", gfc_match_continue, ST_CONTINUE);
 191       match ("cycle", gfc_match_cycle, ST_CYCLE);
 192       match ("case", gfc_match_case, ST_CASE);
 193       match ("common", gfc_match_common, ST_COMMON);
 194       match ("contains", gfc_match_eos, ST_CONTAINS);
 195       break;
 196
 197     case 'd':
 198       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
 199       match ("data", gfc_match_data, ST_DATA);
 200       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 201       break;
 202
 203     case 'e':
 204       match ("end file", gfc_match_endfile, ST_END_FILE);
 205       match ("exit", gfc_match_exit, ST_EXIT);
 206       match ("else", gfc_match_else, ST_ELSE);
 207       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
 208       match ("else if", gfc_match_elseif, ST_ELSEIF);
 209       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 210
 211       if (gfc_match_end (&st) == MATCH_YES)
 212         return st;
 213
 214       match ("entry% ", gfc_match_entry, ST_ENTRY);
 215       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 216       match ("external", gfc_match_external, ST_ATTR_DECL);
 217       break;
 218
 219     case 'f':
 220       match ("flush", gfc_match_flush, ST_FLUSH);
 221       match ("format", gfc_match_format, ST_FORMAT);
 222       break;
 223
 224     case 'g':
 225       match ("go to", gfc_match_goto, ST_GOTO);
 226       break;
 227
 228     case 'i':
 229       match ("inquire", gfc_match_inquire, ST_INQUIRE);
 230       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 231       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 232       match ("interface", gfc_match_interface, ST_INTERFACE);
 233       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 234       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 235       break;
 236
 237     case 'm':
 238       match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
 239       match ("module", gfc_match_module, ST_MODULE);
 240       break;
 241
 242     case 'n':
 243       match ("nullify", gfc_match_nullify, ST_NULLIFY);
 244       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 245       break;
 246
 247     case 'o':
 248       match ("open", gfc_match_open, ST_OPEN);
 249       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 250       break;
 251
 252     case 'p':
 253       match ("print", gfc_match_print, ST_WRITE);
 254       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 255       match ("pause", gfc_match_pause, ST_PAUSE);
 256       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 257       if (gfc_match_private (&st) == MATCH_YES)
 258         return st;
 259       match ("program", gfc_match_program, ST_PROGRAM);
 260       if (gfc_match_public (&st) == MATCH_YES)
 261         return st;
 262       break;
 263
 264     case 'r':
 265       match ("read", gfc_match_read, ST_READ);
 266       match ("return", gfc_match_return, ST_RETURN);
 267       match ("rewind", gfc_match_rewind, ST_REWIND);
 268       break;
 269
 270     case 's':
 271       match ("sequence", gfc_match_eos, ST_SEQUENCE);
 272       match ("stop", gfc_match_stop, ST_STOP);
 273       match ("save", gfc_match_save, ST_ATTR_DECL);
 274       break;
 275
 276     case 't':
 277       match ("target", gfc_match_target, ST_ATTR_DECL);
 278       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 279       break;
 280
 281     case 'u':
 282       match ("use% ", gfc_match_use, ST_USE);
 283       break;
 284
 285     case 'w':
 286       match ("write", gfc_match_write, ST_WRITE);
 287       break;
 288     }
 289
 290   /* All else has failed, so give up.  See if any of the matchers has
 291      stored an error message of some sort.  */
 292
 293   if (gfc_error_check () == 0)
 294     gfc_error_now ("Unclassifiable statement at %C");
 295
 296   reject_statement ();
 297
 298   gfc_error_recovery ();
 299
 300   return ST_NONE;
 301 }
 302
 303 static gfc_statement
 304 decode_omp_directive (void)
 305 {
 306   locus old_locus;
 307   int c;
 308
 309 #ifdef GFC_DEBUG
 310   gfc_symbol_state ();
 311 #endif
 312
 313   gfc_clear_error ();   /* Clear any pending errors.  */
 314   gfc_clear_warning (); /* Clear any pending warnings.  */
 315
 316   if (gfc_pure (NULL))
 317     {
 318       gfc_error_now ("OpenMP directives at %C may not appear in PURE or ELEMENTAL procedures");
 319       gfc_error_recovery ();
 320       return ST_NONE;
 321     }
 322
 323   old_locus = gfc_current_locus;
 324
 325   /* General OpenMP directive matching: Instead of testing every possible
 326      statement, we eliminate most possibilities by peeking at the
 327      first character.  */
 328
 329   c = gfc_peek_char ();
 330
 331   switch (c)
 332     {
 333     case 'a':
 334       match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
 335       break;
 336     case 'b':
 337       match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
 338       break;
 339     case 'c':
 340       match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
 341       break;
 342     case 'd':
 343       match ("do", gfc_match_omp_do, ST_OMP_DO);
 344       break;
 345     case 'e':
 346       match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
 347       match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
 348       match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
 349       match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
 350       match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
 351       match ("end parallel sections", gfc_match_omp_eos,
 352              ST_OMP_END_PARALLEL_SECTIONS);
 353       match ("end parallel workshare", gfc_match_omp_eos,
 354              ST_OMP_END_PARALLEL_WORKSHARE);
 355       match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
 356       match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
 357       match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
 358       match ("end workshare", gfc_match_omp_end_nowait,
 359              ST_OMP_END_WORKSHARE);
 360       break;
 361     case 'f':
 362       match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
 363       break;
 364     case 'm':
 365       match ("master", gfc_match_omp_master, ST_OMP_MASTER);
 366       break;
 367     case 'o':
 368       match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
 369       break;
 370     case 'p':
 371       match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
 372       match ("parallel sections", gfc_match_omp_parallel_sections,
 373              ST_OMP_PARALLEL_SECTIONS);
 374       match ("parallel workshare", gfc_match_omp_parallel_workshare,
 375              ST_OMP_PARALLEL_WORKSHARE);
 376       match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
 377       break;
 378     case 's':
 379       match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
 380       match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
 381       match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
 382       break;
 383     case 't':
 384       match ("threadprivate", gfc_match_omp_threadprivate,
 385              ST_OMP_THREADPRIVATE);
 386     case 'w':
 387       match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
 388       break;
 389     }
 390
 391   /* All else has failed, so give up.  See if any of the matchers has
 392      stored an error message of some sort.  */
 393
 394   if (gfc_error_check () == 0)
 395     gfc_error_now ("Unclassifiable OpenMP directive at %C");
 396
 397   reject_statement ();
 398
 399   gfc_error_recovery ();
 400
 401   return ST_NONE;
 402 }
 403
 404 #undef match
 405
 406
 407 /* Get the next statement in free form source.  */
 408
 409 static gfc_statement
 410 next_free (void)
 411 {
 412   match m;
 413   int c, d, cnt;
 414
 415   gfc_gobble_whitespace ();
 416
 417   c = gfc_peek_char ();
 418
 419   if (ISDIGIT (c))
 420     {
 421       /* Found a statement label?  */
 422       m = gfc_match_st_label (&gfc_statement_label);
 423
 424       d = gfc_peek_char ();
 425       if (m != MATCH_YES || !gfc_is_whitespace (d))
 426         {
 427           gfc_match_small_literal_int (&c, &cnt);
 428
 429           if (cnt > 5)
 430             gfc_error_now ("Too many digits in statement label at %C");
 431
 432           if (c == 0)
 433             gfc_error_now ("Zero is not a valid statement label at %C");
 434
 435           do
 436             c = gfc_next_char ();
 437           while (ISDIGIT(c));
 438
 439           if (!gfc_is_whitespace (c))
 440             gfc_error_now ("Non-numeric character in statement label at %C");
 441
 442         }
 443       else
 444         {
 445           label_locus = gfc_current_locus;
 446
 447           gfc_gobble_whitespace ();
 448
 449           if (gfc_match_eos () == MATCH_YES)
 450             {
 451               gfc_warning_now
 452                 ("Ignoring statement label in empty statement at %C");
 453               gfc_free_st_label (gfc_statement_label);
 454               gfc_statement_label = NULL;
 455               return ST_NONE;
 456             }
 457         }
 458     }
 459   else if (c == '!')
 460     {
 461       /* Comments have already been skipped by the time we get here,
 462          except for OpenMP directives.  */
 463       if (gfc_option.flag_openmp)
 464         {
 465           int i;
 466
 467           c = gfc_next_char ();
 468           for (i = 0; i < 5; i++, c = gfc_next_char ())
 469             gcc_assert (c == "!$omp"[i]);
 470
 471           gcc_assert (c == ' ');
 472           return decode_omp_directive ();
 473         }
 474     }
 475
 476   return decode_statement ();
 477 }
 478
 479
 480 /* Get the next statement in fixed-form source.  */
 481
 482 static gfc_statement
 483 next_fixed (void)
 484 {
 485   int label, digit_flag, i;
 486   locus loc;
 487   char c;
 488
 489   if (!gfc_at_bol ())
 490     return decode_statement ();
 491
 492   /* Skip past the current label field, parsing a statement label if
 493      one is there.  This is a weird number parser, since the number is
 494      contained within five columns and can have any kind of embedded
 495      spaces.  We also check for characters that make the rest of the
 496      line a comment.  */
 497
 498   label = 0;
 499   digit_flag = 0;
 500
 501   for (i = 0; i < 5; i++)
 502     {
 503       c = gfc_next_char_literal (0);
 504
 505       switch (c)
 506         {
 507         case ' ':
 508           break;
 509
 510         case '0':
 511         case '1':
 512         case '2':
 513         case '3':
 514         case '4':
 515         case '5':
 516         case '6':
 517         case '7':
 518         case '8':
 519         case '9':
 520           label = label * 10 + c - '0';
 521           label_locus = gfc_current_locus;
 522           digit_flag = 1;
 523           break;
 524
 525           /* Comments have already been skipped by the time we get
 526              here, except for OpenMP directives.  */
 527         case '*':
 528           if (gfc_option.flag_openmp)
 529             {
 530               for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
 531                 gcc_assert (TOLOWER (c) == "*$omp"[i]);
 532
 533               if (c != ' ' && c != '0')
 534                 {
 535                   gfc_buffer_error (0);
 536                   gfc_error ("Bad continuation line at %C");
 537                   return ST_NONE;
 538                 }
 539
 540               return decode_omp_directive ();
 541             }
 542           /* FALLTHROUGH */
 543
 544           /* Comments have already been skipped by the time we get
 545              here so don't bother checking for them.  */
 546
 547         default:
 548           gfc_buffer_error (0);
 549           gfc_error ("Non-numeric character in statement label at %C");
 550           return ST_NONE;
 551         }
 552     }
 553
 554   if (digit_flag)
 555     {
 556       if (label == 0)
 557         gfc_warning_now ("Zero is not a valid statement label at %C");
 558       else
 559         {
 560           /* We've found a valid statement label.  */
 561           gfc_statement_label = gfc_get_st_label (label);
 562         }
 563     }
 564
 565   /* Since this line starts a statement, it cannot be a continuation
 566      of a previous statement.  If we see something here besides a
 567      space or zero, it must be a bad continuation line.  */
 568
 569   c = gfc_next_char_literal (0);
 570   if (c == '\n')
 571     goto blank_line;
 572
 573   if (c != ' ' && c!= '0')
 574     {
 575       gfc_buffer_error (0);
 576       gfc_error ("Bad continuation line at %C");
 577       return ST_NONE;
 578     }
 579
 580   /* Now that we've taken care of the statement label columns, we have
 581      to make sure that the first nonblank character is not a '!'.  If
 582      it is, the rest of the line is a comment.  */
 583
 584   do
 585     {
 586       loc = gfc_current_locus;
 587       c = gfc_next_char_literal (0);
 588     }
 589   while (gfc_is_whitespace (c));
 590
 591   if (c == '!')
 592     goto blank_line;
 593   gfc_current_locus = loc;
 594
 595   if (gfc_match_eos () == MATCH_YES)
 596     goto blank_line;
 597
 598   /* At this point, we've got a nonblank statement to parse.  */
 599   return decode_statement ();
 600
 601 blank_line:
 602   if (digit_flag)
 603     gfc_warning ("Ignoring statement label in empty statement at %C");
 604   gfc_advance_line ();
 605   return ST_NONE;
 606 }
 607
 608
 609 /* Return the next non-ST_NONE statement to the caller.  We also worry
 610    about including files and the ends of include files at this stage.  */
 611
 612 static gfc_statement
 613 next_statement (void)
 614 {
 615   gfc_statement st;
 616
 617   gfc_new_block = NULL;
 618
 619   for (;;)
 620     {
 621       gfc_statement_label = NULL;
 622       gfc_buffer_error (1);
 623
 624       if (gfc_at_eol ())
 625         {
 626           if (gfc_option.warn_line_truncation
 627               && gfc_current_locus.lb->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       gfc_commit_symbols ();
2352       gfc_warning_check ();
2353       st = next_statement ();
2354     }
2355   return st;
2356 }
2357
2358
2359 /* Parse the statements of OpenMP atomic directive.  */
2360
2361 static void
2362 parse_omp_atomic (void)
2363 {
2364   gfc_statement st;
2365   gfc_code *cp, *np;
2366   gfc_state_data s;
2367
2368   accept_statement (ST_OMP_ATOMIC);
2369
2370   cp = gfc_state_stack->tail;
2371   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2372   np = new_level (cp);
2373   np->op = cp->op;
2374   np->block = NULL;
2375
2376   for (;;)
2377     {
2378       st = next_statement ();
2379       if (st == ST_NONE)
2380         unexpected_eof ();
2381       else if (st == ST_ASSIGNMENT)
2382         break;
2383       else
2384         unexpected_statement (st);
2385     }
2386
2387   accept_statement (st);
2388
2389   pop_state ();
2390 }
2391
2392
2393 /* Parse the statements of an OpenMP structured block.  */
2394
2395 static void
2396 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2397 {
2398   gfc_statement st, omp_end_st;
2399   gfc_code *cp, *np;
2400   gfc_state_data s;
2401
2402   accept_statement (omp_st);
2403
2404   cp = gfc_state_stack->tail;
2405   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2406   np = new_level (cp);
2407   np->op = cp->op;
2408   np->block = NULL;
2409
2410   switch (omp_st)
2411     {
2412     case ST_OMP_PARALLEL:
2413       omp_end_st = ST_OMP_END_PARALLEL;
2414       break;
2415     case ST_OMP_PARALLEL_SECTIONS:
2416       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2417       break;
2418     case ST_OMP_SECTIONS:
2419       omp_end_st = ST_OMP_END_SECTIONS;
2420       break;
2421     case ST_OMP_ORDERED:
2422       omp_end_st = ST_OMP_END_ORDERED;
2423       break;
2424     case ST_OMP_CRITICAL:
2425       omp_end_st = ST_OMP_END_CRITICAL;
2426       break;
2427     case ST_OMP_MASTER:
2428       omp_end_st = ST_OMP_END_MASTER;
2429       break;
2430     case ST_OMP_SINGLE:
2431       omp_end_st = ST_OMP_END_SINGLE;
2432       break;
2433     case ST_OMP_WORKSHARE:
2434       omp_end_st = ST_OMP_END_WORKSHARE;
2435       break;
2436     case ST_OMP_PARALLEL_WORKSHARE:
2437       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2438       break;
2439     default:
2440       gcc_unreachable ();
2441     }
2442
2443   do
2444     {
2445       if (workshare_stmts_only)
2446         {
2447           /* Inside of !$omp workshare, only
2448              scalar assignments
2449              array assignments
2450              where statements and constructs
2451              forall statements and constructs
2452              !$omp atomic
2453              !$omp critical
2454              !$omp parallel
2455              are allowed.  For !$omp critical these
2456              restrictions apply recursively.  */
2457           bool cycle = true;
2458
2459           st = next_statement ();
2460           for (;;)
2461             {
2462               switch (st)
2463                 {
2464                 case ST_NONE:
2465                   unexpected_eof ();
2466
2467                 case ST_ASSIGNMENT:
2468                 case ST_WHERE:
2469                 case ST_FORALL:
2470                   accept_statement (st);
2471                   break;
2472
2473                 case ST_WHERE_BLOCK:
2474                   parse_where_block ();
2475                   break;
2476
2477                 case ST_FORALL_BLOCK:
2478                   parse_forall_block ();
2479                   break;
2480
2481                 case ST_OMP_PARALLEL:
2482                 case ST_OMP_PARALLEL_SECTIONS:
2483                   parse_omp_structured_block (st, false);
2484                   break;
2485
2486                 case ST_OMP_PARALLEL_WORKSHARE:
2487                 case ST_OMP_CRITICAL:
2488                   parse_omp_structured_block (st, true);
2489                   break;
2490
2491                 case ST_OMP_PARALLEL_DO:
2492                   st = parse_omp_do (st);
2493                   continue;
2494
2495                 case ST_OMP_ATOMIC:
2496                   parse_omp_atomic ();
2497                   break;
2498
2499                 default:
2500                   cycle = false;
2501                   break;
2502                 }
2503
2504               if (!cycle)
2505                 break;
2506
2507               st = next_statement ();
2508             }
2509         }
2510       else
2511         st = parse_executable (ST_NONE);
2512       if (st == ST_NONE)
2513         unexpected_eof ();
2514       else if (st == ST_OMP_SECTION
2515                && (omp_st == ST_OMP_SECTIONS
2516                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
2517         {
2518           np = new_level (np);
2519           np->op = cp->op;
2520           np->block = NULL;
2521         }
2522       else if (st != omp_end_st)
2523         unexpected_statement (st);
2524     }
2525   while (st != omp_end_st);
2526
2527   switch (new_st.op)
2528     {
2529     case EXEC_OMP_END_NOWAIT:
2530       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2531       break;
2532     case EXEC_OMP_CRITICAL:
2533       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2534           || (new_st.ext.omp_name != NULL
2535               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2536         gfc_error ("Name after !$omp critical and !$omp end critical does"
2537                    " not match at %C");
2538       gfc_free ((char *) new_st.ext.omp_name);
2539       break;
2540     case EXEC_OMP_END_SINGLE:
2541       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2542         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2543       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2544       gfc_free_omp_clauses (new_st.ext.omp_clauses);
2545       break;
2546     case EXEC_NOP:
2547       break;
2548     default:
2549       gcc_unreachable ();
2550     }
2551
2552   gfc_clear_new_st ();
2553   gfc_commit_symbols ();
2554   gfc_warning_check ();
2555   pop_state ();
2556 }
2557
2558
2559 /* Accept a series of executable statements.  We return the first
2560    statement that doesn't fit to the caller.  Any block statements are
2561    passed on to the correct handler, which usually passes the buck
2562    right back here.  */
2563
2564 static gfc_statement
2565 parse_executable (gfc_statement st)
2566 {
2567   int close_flag;
2568
2569   if (st == ST_NONE)
2570     st = next_statement ();
2571
2572   for (;;)
2573     {
2574       close_flag = check_do_closure ();
2575       if (close_flag)
2576         switch (st)
2577           {
2578           case ST_GOTO:
2579           case ST_END_PROGRAM:
2580           case ST_RETURN:
2581           case ST_EXIT:
2582           case ST_END_FUNCTION:
2583           case ST_CYCLE:
2584           case ST_PAUSE:
2585           case ST_STOP:
2586           case ST_END_SUBROUTINE:
2587
2588           case ST_DO:
2589           case ST_FORALL:
2590           case ST_WHERE:
2591           case ST_SELECT_CASE:
2592             gfc_error
2593               ("%s statement at %C cannot terminate a non-block DO loop",
2594                gfc_ascii_statement (st));
2595             break;
2596
2597           default:
2598             break;
2599           }
2600
2601       switch (st)
2602         {
2603         case ST_NONE:
2604           unexpected_eof ();
2605
2606         case ST_FORMAT:
2607         case ST_DATA:
2608         case ST_ENTRY:
2609         case_executable:
2610           accept_statement (st);
2611           if (close_flag == 1)
2612             return ST_IMPLIED_ENDDO;
2613           break;
2614
2615         case ST_IF_BLOCK:
2616           parse_if_block ();
2617           break;
2618
2619         case ST_SELECT_CASE:
2620           parse_select_block ();
2621           break;
2622
2623         case ST_DO:
2624           parse_do_block ();
2625           if (check_do_closure () == 1)
2626             return ST_IMPLIED_ENDDO;
2627           break;
2628
2629         case ST_WHERE_BLOCK:
2630           parse_where_block ();
2631           break;
2632
2633         case ST_FORALL_BLOCK:
2634           parse_forall_block ();
2635           break;
2636
2637         case ST_OMP_PARALLEL:
2638         case ST_OMP_PARALLEL_SECTIONS:
2639         case ST_OMP_SECTIONS:
2640         case ST_OMP_ORDERED:
2641         case ST_OMP_CRITICAL:
2642         case ST_OMP_MASTER:
2643         case ST_OMP_SINGLE:
2644           parse_omp_structured_block (st, false);
2645           break;
2646
2647         case ST_OMP_WORKSHARE:
2648         case ST_OMP_PARALLEL_WORKSHARE:
2649           parse_omp_structured_block (st, true);
2650           break;
2651
2652         case ST_OMP_DO:
2653         case ST_OMP_PARALLEL_DO:
2654           st = parse_omp_do (st);
2655           if (st == ST_IMPLIED_ENDDO)
2656             return st;
2657           continue;
2658
2659         case ST_OMP_ATOMIC:
2660           parse_omp_atomic ();
2661           break;
2662
2663         default:
2664           return st;
2665         }
2666
2667       st = next_statement ();
2668     }
2669 }
2670
2671
2672 /* Parse a series of contained program units.  */
2673
2674 static void parse_progunit (gfc_statement);
2675
2676
2677 /* Fix the symbols for sibling functions.  These are incorrectly added to
2678    the child namespace as the parser didn't know about this procedure.  */
2679
2680 static void
2681 gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
2682 {
2683   gfc_namespace *ns;
2684   gfc_symtree *st;
2685   gfc_symbol *old_sym;
2686
2687   sym->attr.referenced = 1;
2688   for (ns = siblings; ns; ns = ns->sibling)
2689     {
2690       gfc_find_sym_tree (sym->name, ns, 0, &st);
2691       if (!st)
2692         continue;
2693
2694       old_sym = st->n.sym;
2695       if ((old_sym->attr.flavor == FL_PROCEDURE
2696            || old_sym->ts.type == BT_UNKNOWN)
2697           && old_sym->ns == ns
2698           && ! old_sym->attr.contained)
2699         {
2700           /* Replace it with the symbol from the parent namespace.  */
2701           st->n.sym = sym;
2702           sym->refs++;
2703
2704           /* Free the old (local) symbol.  */
2705           old_sym->refs--;
2706           if (old_sym->refs == 0)
2707             gfc_free_symbol (old_sym);
2708         }
2709
2710       /* Do the same for any contained procedures.  */
2711       gfc_fixup_sibling_symbols (sym, ns->contained);
2712     }
2713 }
2714
2715 static void
2716 parse_contained (int module)
2717 {
2718   gfc_namespace *ns, *parent_ns;
2719   gfc_state_data s1, s2;
2720   gfc_statement st;
2721   gfc_symbol *sym;
2722   gfc_entry_list *el;
2723
2724   push_state (&s1, COMP_CONTAINS, NULL);
2725   parent_ns = gfc_current_ns;
2726
2727   do
2728     {
2729       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
2730
2731       gfc_current_ns->sibling = parent_ns->contained;
2732       parent_ns->contained = gfc_current_ns;
2733
2734       st = next_statement ();
2735
2736       switch (st)
2737         {
2738         case ST_NONE:
2739           unexpected_eof ();
2740
2741         case ST_FUNCTION:
2742         case ST_SUBROUTINE:
2743           accept_statement (st);
2744
2745           push_state (&s2,
2746                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2747                       gfc_new_block);
2748
2749           /* For internal procedures, create/update the symbol in the
2750              parent namespace.  */
2751
2752           if (!module)
2753             {
2754               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2755                 gfc_error
2756                   ("Contained procedure '%s' at %C is already ambiguous",
2757                    gfc_new_block->name);
2758               else
2759                 {
2760                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
2761                                          &gfc_new_block->declared_at) ==
2762                       SUCCESS)
2763                     {
2764                       if (st == ST_FUNCTION)
2765                         gfc_add_function (&sym->attr, sym->name,
2766                                           &gfc_new_block->declared_at);
2767                       else
2768                         gfc_add_subroutine (&sym->attr, sym->name,
2769                                             &gfc_new_block->declared_at);
2770                     }
2771                 }
2772
2773               gfc_commit_symbols ();
2774             }
2775           else
2776             sym = gfc_new_block;
2777
2778           /* Mark this as a contained function, so it isn't replaced
2779              by other module functions.  */
2780           sym->attr.contained = 1;
2781           sym->attr.referenced = 1;
2782
2783           parse_progunit (ST_NONE);
2784
2785           /* Fix up any sibling functions that refer to this one.  */
2786           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2787           /* Or refer to any of its alternate entry points.  */
2788           for (el = gfc_current_ns->entries; el; el = el->next)
2789             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2790
2791           gfc_current_ns->code = s2.head;
2792           gfc_current_ns = parent_ns;
2793
2794           pop_state ();
2795           break;
2796
2797         /* These statements are associated with the end of the host
2798            unit.  */
2799         case ST_END_FUNCTION:
2800         case ST_END_MODULE:
2801         case ST_END_PROGRAM:
2802         case ST_END_SUBROUTINE:
2803           accept_statement (st);
2804           break;
2805
2806         default:
2807           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2808                      gfc_ascii_statement (st));
2809           reject_statement ();
2810           break;
2811         }
2812     }
2813   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2814          && st != ST_END_MODULE && st != ST_END_PROGRAM);
2815
2816   /* The first namespace in the list is guaranteed to not have
2817      anything (worthwhile) in it.  */
2818
2819   gfc_current_ns = parent_ns;
2820
2821   ns = gfc_current_ns->contained;
2822   gfc_current_ns->contained = ns->sibling;
2823   gfc_free_namespace (ns);
2824
2825   pop_state ();
2826 }
2827
2828
2829 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
2830
2831 static void
2832 parse_progunit (gfc_statement st)
2833 {
2834   gfc_state_data *p;
2835   int n;
2836
2837   st = parse_spec (st);
2838   switch (st)
2839     {
2840     case ST_NONE:
2841       unexpected_eof ();
2842
2843     case ST_CONTAINS:
2844       goto contains;
2845
2846     case_end:
2847       accept_statement (st);
2848       goto done;
2849
2850     default:
2851       break;
2852     }
2853
2854 loop:
2855   for (;;)
2856     {
2857       st = parse_executable (st);
2858
2859       switch (st)
2860         {
2861         case ST_NONE:
2862           unexpected_eof ();
2863
2864         case ST_CONTAINS:
2865           goto contains;
2866
2867         case_end:
2868           accept_statement (st);
2869           goto done;
2870
2871         default:
2872           break;
2873         }
2874
2875       unexpected_statement (st);
2876       reject_statement ();
2877       st = next_statement ();
2878     }
2879
2880 contains:
2881   n = 0;
2882
2883   for (p = gfc_state_stack; p; p = p->previous)
2884     if (p->state == COMP_CONTAINS)
2885       n++;
2886
2887   if (gfc_find_state (COMP_MODULE) == SUCCESS)
2888     n--;
2889
2890   if (n > 0)
2891     {
2892       gfc_error ("CONTAINS statement at %C is already in a contained "
2893                  "program unit");
2894       st = next_statement ();
2895       goto loop;
2896     }
2897
2898   parse_contained (0);
2899
2900 done:
2901   gfc_current_ns->code = gfc_state_stack->head;
2902 }
2903
2904
2905 /* Come here to complain about a global symbol already in use as
2906    something else.  */
2907
2908 void
2909 global_used (gfc_gsymbol *sym, locus *where)
2910 {
2911   const char *name;
2912
2913   if (where == NULL)
2914     where = &gfc_current_locus;
2915
2916   switch(sym->type)
2917     {
2918     case GSYM_PROGRAM:
2919       name = "PROGRAM";
2920       break;
2921     case GSYM_FUNCTION:
2922       name = "FUNCTION";
2923       break;
2924     case GSYM_SUBROUTINE:
2925       name = "SUBROUTINE";
2926       break;
2927     case GSYM_COMMON:
2928       name = "COMMON";
2929       break;
2930     case GSYM_BLOCK_DATA:
2931       name = "BLOCK DATA";
2932       break;
2933     case GSYM_MODULE:
2934       name = "MODULE";
2935       break;
2936     default:
2937       gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2938       name = NULL;
2939     }
2940
2941   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2942               sym->name, where, name, &sym->where);
2943 }
2944
2945
2946 /* Parse a block data program unit.  */
2947
2948 static void
2949 parse_block_data (void)
2950 {
2951   gfc_statement st;
2952   static locus blank_locus;
2953   static int blank_block=0;
2954   gfc_gsymbol *s;
2955
2956   gfc_current_ns->proc_name = gfc_new_block;
2957   gfc_current_ns->is_block_data = 1;
2958
2959   if (gfc_new_block == NULL)
2960     {
2961       if (blank_block)
2962        gfc_error ("Blank BLOCK DATA at %C conflicts with "
2963                   "prior BLOCK DATA at %L", &blank_locus);
2964       else
2965        {
2966          blank_block = 1;
2967          blank_locus = gfc_current_locus;
2968        }
2969     }
2970   else
2971     {
2972       s = gfc_get_gsymbol (gfc_new_block->name);
2973       if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
2974        global_used(s, NULL);
2975       else
2976        {
2977          s->type = GSYM_BLOCK_DATA;
2978          s->where = gfc_current_locus;
2979          s->defined = 1;
2980        }
2981     }
2982
2983   st = parse_spec (ST_NONE);
2984
2985   while (st != ST_END_BLOCK_DATA)
2986     {
2987       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2988                  gfc_ascii_statement (st));
2989       reject_statement ();
2990       st = next_statement ();
2991     }
2992 }
2993
2994
2995 /* Parse a module subprogram.  */
2996
2997 static void
2998 parse_module (void)
2999 {
3000   gfc_statement st;
3001   gfc_gsymbol *s;
3002
3003   s = gfc_get_gsymbol (gfc_new_block->name);
3004   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3005     global_used(s, NULL);
3006   else
3007     {
3008       s->type = GSYM_MODULE;
3009       s->where = gfc_current_locus;
3010       s->defined = 1;
3011     }
3012
3013   st = parse_spec (ST_NONE);
3014
3015 loop:
3016   switch (st)
3017     {
3018     case ST_NONE:
3019       unexpected_eof ();
3020
3021     case ST_CONTAINS:
3022       parse_contained (1);
3023       break;
3024
3025     case ST_END_MODULE:
3026       accept_statement (st);
3027       break;
3028
3029     default:
3030       gfc_error ("Unexpected %s statement in MODULE at %C",
3031                  gfc_ascii_statement (st));
3032
3033       reject_statement ();
3034       st = next_statement ();
3035       goto loop;
3036     }
3037 }
3038
3039
3040 /* Add a procedure name to the global symbol table.  */
3041
3042 static void
3043 add_global_procedure (int sub)
3044 {
3045   gfc_gsymbol *s;
3046
3047   s = gfc_get_gsymbol(gfc_new_block->name);
3048
3049   if (s->defined
3050         || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3051     global_used(s, NULL);
3052   else
3053     {
3054       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3055       s->where = gfc_current_locus;
3056       s->defined = 1;
3057     }
3058 }
3059
3060
3061 /* Add a program to the global symbol table.  */
3062
3063 static void
3064 add_global_program (void)
3065 {
3066   gfc_gsymbol *s;
3067
3068   if (gfc_new_block == NULL)
3069     return;
3070   s = gfc_get_gsymbol (gfc_new_block->name);
3071
3072   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3073     global_used(s, NULL);
3074   else
3075     {
3076       s->type = GSYM_PROGRAM;
3077       s->where = gfc_current_locus;
3078       s->defined = 1;
3079     }
3080 }
3081
3082
3083 /* Top level parser.  */
3084
3085 try
3086 gfc_parse_file (void)
3087 {
3088   int seen_program, errors_before, errors;
3089   gfc_state_data top, s;
3090   gfc_statement st;
3091   locus prog_locus;
3092
3093   top.state = COMP_NONE;
3094   top.sym = NULL;
3095   top.previous = NULL;
3096   top.head = top.tail = NULL;
3097   top.do_variable = NULL;
3098
3099   gfc_state_stack = &top;
3100
3101   gfc_clear_new_st ();
3102
3103   gfc_statement_label = NULL;
3104
3105   if (setjmp (eof_buf))
3106     return FAILURE;     /* Come here on unexpected EOF */
3107
3108   seen_program = 0;
3109
3110   /* Exit early for empty files.  */
3111   if (gfc_at_eof ())
3112     goto done;
3113
3114 loop:
3115   gfc_init_2 ();
3116   st = next_statement ();
3117   switch (st)
3118     {
3119     case ST_NONE:
3120       gfc_done_2 ();
3121       goto done;
3122
3123     case ST_PROGRAM:
3124       if (seen_program)
3125         goto duplicate_main;
3126       seen_program = 1;
3127       prog_locus = gfc_current_locus;
3128
3129       push_state (&s, COMP_PROGRAM, gfc_new_block);
3130       main_program_symbol(gfc_current_ns);
3131       accept_statement (st);
3132       add_global_program ();
3133       parse_progunit (ST_NONE);
3134       break;
3135
3136     case ST_SUBROUTINE:
3137       add_global_procedure (1);
3138       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3139       accept_statement (st);
3140       parse_progunit (ST_NONE);
3141       break;
3142
3143     case ST_FUNCTION:
3144       add_global_procedure (0);
3145       push_state (&s, COMP_FUNCTION, gfc_new_block);
3146       accept_statement (st);
3147       parse_progunit (ST_NONE);
3148       break;
3149
3150     case ST_BLOCK_DATA:
3151       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3152       accept_statement (st);
3153       parse_block_data ();
3154       break;
3155
3156     case ST_MODULE:
3157       push_state (&s, COMP_MODULE, gfc_new_block);
3158       accept_statement (st);
3159
3160       gfc_get_errors (NULL, &errors_before);
3161       parse_module ();
3162       break;
3163
3164     /* Anything else starts a nameless main program block.  */
3165     default:
3166       if (seen_program)
3167         goto duplicate_main;
3168       seen_program = 1;
3169       prog_locus = gfc_current_locus;
3170
3171       push_state (&s, COMP_PROGRAM, gfc_new_block);
3172       main_program_symbol(gfc_current_ns);
3173       parse_progunit (st);
3174       break;
3175     }
3176
3177   gfc_current_ns->code = s.head;
3178
3179   gfc_resolve (gfc_current_ns);
3180
3181   /* Dump the parse tree if requested.  */
3182   if (gfc_option.verbose)
3183     gfc_show_namespace (gfc_current_ns);
3184
3185   gfc_get_errors (NULL, &errors);
3186   if (s.state == COMP_MODULE)
3187     {
3188       gfc_dump_module (s.sym->name, errors_before == errors);
3189       if (errors == 0 && ! gfc_option.flag_no_backend)
3190         gfc_generate_module_code (gfc_current_ns);
3191     }
3192   else
3193     {
3194       if (errors == 0 && ! gfc_option.flag_no_backend)
3195         gfc_generate_code (gfc_current_ns);
3196     }
3197
3198   pop_state ();
3199   gfc_done_2 ();
3200   goto loop;
3201
3202 done:
3203   return SUCCESS;
3204
3205 duplicate_main:
3206   /* If we see a duplicate main program, shut down.  If the second
3207      instance is an implied main program, ie data decls or executable
3208      statements, we're in for lots of errors.  */
3209   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3210   reject_statement ();
3211   gfc_done_2 ();
3212   return SUCCESS;
3213 }