gcc/fortran/parse.c

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