gcc/fortran/parse.c

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