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