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