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
1698   accept_statement (ST_INTERFACE);
1699
1700   current_interface.ns = gfc_current_ns;
1701   save = current_interface;
1702
1703   sym = (current_interface.type == INTERFACE_GENERIC
1704          || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
1705
1706   push_state (&s1, COMP_INTERFACE, sym);
1707   current_state = COMP_NONE;
1708
1709 loop:
1710   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
1711
1712   st = next_statement ();
1713   switch (st)
1714     {
1715     case ST_NONE:
1716       unexpected_eof ();
1717
1718     case ST_SUBROUTINE:
1719       new_state = COMP_SUBROUTINE;
1720       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1721                                   gfc_new_block->formal, NULL);
1722       break;
1723
1724     case ST_FUNCTION:
1725       new_state = COMP_FUNCTION;
1726       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1727                                   gfc_new_block->formal, NULL);
1728       break;
1729
1730     case ST_MODULE_PROC:        /* The module procedure matcher makes
1731                                    sure the context is correct.  */
1732       accept_statement (st);
1733       gfc_free_namespace (gfc_current_ns);
1734       goto loop;
1735
1736     case ST_END_INTERFACE:
1737       gfc_free_namespace (gfc_current_ns);
1738       gfc_current_ns = current_interface.ns;
1739       goto done;
1740
1741     default:
1742       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1743                  gfc_ascii_statement (st));
1744       reject_statement ();
1745       gfc_free_namespace (gfc_current_ns);
1746       goto loop;
1747     }
1748
1749
1750   /* Make sure that a generic interface has only subroutines or
1751      functions and that the generic name has the right attribute.  */
1752   if (current_interface.type == INTERFACE_GENERIC)
1753     {
1754       if (current_state == COMP_NONE)
1755         {
1756           if (new_state == COMP_FUNCTION)
1757             gfc_add_function (&sym->attr, sym->name, NULL);
1758           else if (new_state == COMP_SUBROUTINE)
1759             gfc_add_subroutine (&sym->attr, sym->name, NULL);
1760
1761           current_state = new_state;
1762         }
1763       else
1764         {
1765           if (new_state != current_state)
1766             {
1767               if (new_state == COMP_SUBROUTINE)
1768                 gfc_error
1769                   ("SUBROUTINE at %C does not belong in a generic function "
1770                    "interface");
1771
1772               if (new_state == COMP_FUNCTION)
1773                 gfc_error
1774                   ("FUNCTION at %C does not belong in a generic subroutine "
1775                    "interface");
1776             }
1777         }
1778     }
1779
1780   push_state (&s2, new_state, gfc_new_block);
1781   accept_statement (st);
1782   prog_unit = gfc_new_block;
1783   prog_unit->formal_ns = gfc_current_ns;
1784
1785 decl:
1786   /* Read data declaration statements.  */
1787   st = parse_spec (ST_NONE);
1788
1789   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
1790     {
1791       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1792                  gfc_ascii_statement (st));
1793       reject_statement ();
1794       goto decl;
1795     }
1796
1797   current_interface = save;
1798   gfc_add_interface (prog_unit);
1799
1800   pop_state ();
1801   goto loop;
1802
1803 done:
1804   pop_state ();
1805 }
1806
1807
1808 /* Parse a set of specification statements.  Returns the statement
1809    that doesn't fit.  */
1810
1811 static gfc_statement
1812 parse_spec (gfc_statement st)
1813 {
1814   st_state ss;
1815
1816   verify_st_order (&ss, ST_NONE);
1817   if (st == ST_NONE)
1818     st = next_statement ();
1819
1820 loop:
1821   switch (st)
1822     {
1823     case ST_NONE:
1824       unexpected_eof ();
1825
1826     case ST_FORMAT:
1827     case ST_ENTRY:
1828     case ST_DATA:       /* Not allowed in interfaces */
1829       if (gfc_current_state () == COMP_INTERFACE)
1830         break;
1831
1832       /* Fall through */
1833
1834     case ST_USE:
1835     case ST_IMPORT:
1836     case ST_IMPLICIT_NONE:
1837     case ST_IMPLICIT:
1838     case ST_PARAMETER:
1839     case ST_PUBLIC:
1840     case ST_PRIVATE:
1841     case ST_DERIVED_DECL:
1842     case_decl:
1843       if (verify_st_order (&ss, st) == FAILURE)
1844         {
1845           reject_statement ();
1846           st = next_statement ();
1847           goto loop;
1848         }
1849
1850       switch (st)
1851         {
1852         case ST_INTERFACE:
1853           parse_interface ();
1854           break;
1855
1856         case ST_DERIVED_DECL:
1857           parse_derived ();
1858           break;
1859
1860         case ST_PUBLIC:
1861         case ST_PRIVATE:
1862           if (gfc_current_state () != COMP_MODULE)
1863             {
1864               gfc_error ("%s statement must appear in a MODULE",
1865                          gfc_ascii_statement (st));
1866               break;
1867             }
1868
1869           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
1870             {
1871               gfc_error ("%s statement at %C follows another accessibility "
1872                          "specification", gfc_ascii_statement (st));
1873               break;
1874             }
1875
1876           gfc_current_ns->default_access = (st == ST_PUBLIC)
1877             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
1878
1879           break;
1880
1881         default:
1882           break;
1883         }
1884
1885       accept_statement (st);
1886       st = next_statement ();
1887       goto loop;
1888
1889     case ST_ENUM:
1890       accept_statement (st);
1891       parse_enum();
1892       st = next_statement ();
1893       goto loop;
1894
1895     default:
1896       break;
1897     }
1898
1899   return st;
1900 }
1901
1902
1903 /* Parse a WHERE block, (not a simple WHERE statement).  */
1904
1905 static void
1906 parse_where_block (void)
1907 {
1908   int seen_empty_else;
1909   gfc_code *top, *d;
1910   gfc_state_data s;
1911   gfc_statement st;
1912
1913   accept_statement (ST_WHERE_BLOCK);
1914   top = gfc_state_stack->tail;
1915
1916   push_state (&s, COMP_WHERE, gfc_new_block);
1917
1918   d = add_statement ();
1919   d->expr = top->expr;
1920   d->op = EXEC_WHERE;
1921
1922   top->expr = NULL;
1923   top->block = d;
1924
1925   seen_empty_else = 0;
1926
1927   do
1928     {
1929       st = next_statement ();
1930       switch (st)
1931         {
1932         case ST_NONE:
1933           unexpected_eof ();
1934
1935         case ST_WHERE_BLOCK:
1936           parse_where_block ();
1937           break;
1938
1939         case ST_ASSIGNMENT:
1940         case ST_WHERE:
1941           accept_statement (st);
1942           break;
1943
1944         case ST_ELSEWHERE:
1945           if (seen_empty_else)
1946             {
1947               gfc_error
1948                 ("ELSEWHERE statement at %C follows previous unmasked "
1949                  "ELSEWHERE");
1950               break;
1951             }
1952
1953           if (new_st.expr == NULL)
1954             seen_empty_else = 1;
1955
1956           d = new_level (gfc_state_stack->head);
1957           d->op = EXEC_WHERE;
1958           d->expr = new_st.expr;
1959
1960           accept_statement (st);
1961
1962           break;
1963
1964         case ST_END_WHERE:
1965           accept_statement (st);
1966           break;
1967
1968         default:
1969           gfc_error ("Unexpected %s statement in WHERE block at %C",
1970                      gfc_ascii_statement (st));
1971           reject_statement ();
1972           break;
1973         }
1974
1975     }
1976   while (st != ST_END_WHERE);
1977
1978   pop_state ();
1979 }
1980
1981
1982 /* Parse a FORALL block (not a simple FORALL statement).  */
1983
1984 static void
1985 parse_forall_block (void)
1986 {
1987   gfc_code *top, *d;
1988   gfc_state_data s;
1989   gfc_statement st;
1990
1991   accept_statement (ST_FORALL_BLOCK);
1992   top = gfc_state_stack->tail;
1993
1994   push_state (&s, COMP_FORALL, gfc_new_block);
1995
1996   d = add_statement ();
1997   d->op = EXEC_FORALL;
1998   top->block = d;
1999
2000   do
2001     {
2002       st = next_statement ();
2003       switch (st)
2004         {
2005
2006         case ST_ASSIGNMENT:
2007         case ST_POINTER_ASSIGNMENT:
2008         case ST_WHERE:
2009         case ST_FORALL:
2010           accept_statement (st);
2011           break;
2012
2013         case ST_WHERE_BLOCK:
2014           parse_where_block ();
2015           break;
2016
2017         case ST_FORALL_BLOCK:
2018           parse_forall_block ();
2019           break;
2020
2021         case ST_END_FORALL:
2022           accept_statement (st);
2023           break;
2024
2025         case ST_NONE:
2026           unexpected_eof ();
2027
2028         default:
2029           gfc_error ("Unexpected %s statement in FORALL block at %C",
2030                      gfc_ascii_statement (st));
2031
2032           reject_statement ();
2033           break;
2034         }
2035     }
2036   while (st != ST_END_FORALL);
2037
2038   pop_state ();
2039 }
2040
2041
2042 static gfc_statement parse_executable (gfc_statement);
2043
2044 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2045
2046 static void
2047 parse_if_block (void)
2048 {
2049   gfc_code *top, *d;
2050   gfc_statement st;
2051   locus else_locus;
2052   gfc_state_data s;
2053   int seen_else;
2054
2055   seen_else = 0;
2056   accept_statement (ST_IF_BLOCK);
2057
2058   top = gfc_state_stack->tail;
2059   push_state (&s, COMP_IF, gfc_new_block);
2060
2061   new_st.op = EXEC_IF;
2062   d = add_statement ();
2063
2064   d->expr = top->expr;
2065   top->expr = NULL;
2066   top->block = d;
2067
2068   do
2069     {
2070       st = parse_executable (ST_NONE);
2071
2072       switch (st)
2073         {
2074         case ST_NONE:
2075           unexpected_eof ();
2076
2077         case ST_ELSEIF:
2078           if (seen_else)
2079             {
2080               gfc_error
2081                 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
2082                  &else_locus);
2083
2084               reject_statement ();
2085               break;
2086             }
2087
2088           d = new_level (gfc_state_stack->head);
2089           d->op = EXEC_IF;
2090           d->expr = new_st.expr;
2091
2092           accept_statement (st);
2093
2094           break;
2095
2096         case ST_ELSE:
2097           if (seen_else)
2098             {
2099               gfc_error ("Duplicate ELSE statements at %L and %C",
2100                          &else_locus);
2101               reject_statement ();
2102               break;
2103             }
2104
2105           seen_else = 1;
2106           else_locus = gfc_current_locus;
2107
2108           d = new_level (gfc_state_stack->head);
2109           d->op = EXEC_IF;
2110
2111           accept_statement (st);
2112
2113           break;
2114
2115         case ST_ENDIF:
2116           break;
2117
2118         default:
2119           unexpected_statement (st);
2120           break;
2121         }
2122     }
2123   while (st != ST_ENDIF);
2124
2125   pop_state ();
2126   accept_statement (st);
2127 }
2128
2129
2130 /* Parse a SELECT block.  */
2131
2132 static void
2133 parse_select_block (void)
2134 {
2135   gfc_statement st;
2136   gfc_code *cp;
2137   gfc_state_data s;
2138
2139   accept_statement (ST_SELECT_CASE);
2140
2141   cp = gfc_state_stack->tail;
2142   push_state (&s, COMP_SELECT, gfc_new_block);
2143
2144   /* Make sure that the next statement is a CASE or END SELECT.  */
2145   for (;;)
2146     {
2147       st = next_statement ();
2148       if (st == ST_NONE)
2149         unexpected_eof ();
2150       if (st == ST_END_SELECT)
2151         {
2152           /* Empty SELECT CASE is OK.  */
2153           accept_statement (st);
2154           pop_state ();
2155           return;
2156         }
2157       if (st == ST_CASE)
2158         break;
2159
2160       gfc_error
2161         ("Expected a CASE or END SELECT statement following SELECT CASE "
2162          "at %C");
2163
2164       reject_statement ();
2165     }
2166
2167   /* At this point, we're got a nonempty select block.  */
2168   cp = new_level (cp);
2169   *cp = new_st;
2170
2171   accept_statement (st);
2172
2173   do
2174     {
2175       st = parse_executable (ST_NONE);
2176       switch (st)
2177         {
2178         case ST_NONE:
2179           unexpected_eof ();
2180
2181         case ST_CASE:
2182           cp = new_level (gfc_state_stack->head);
2183           *cp = new_st;
2184           gfc_clear_new_st ();
2185
2186           accept_statement (st);
2187           /* Fall through */
2188
2189         case ST_END_SELECT:
2190           break;
2191
2192         /* Can't have an executable statement because of
2193            parse_executable().  */
2194         default:
2195           unexpected_statement (st);
2196           break;
2197         }
2198     }
2199   while (st != ST_END_SELECT);
2200
2201   pop_state ();
2202   accept_statement (st);
2203 }
2204
2205
2206 /* Given a symbol, make sure it is not an iteration variable for a DO
2207    statement.  This subroutine is called when the symbol is seen in a
2208    context that causes it to become redefined.  If the symbol is an
2209    iterator, we generate an error message and return nonzero.  */
2210
2211 int
2212 gfc_check_do_variable (gfc_symtree *st)
2213 {
2214   gfc_state_data *s;
2215
2216   for (s=gfc_state_stack; s; s = s->previous)
2217     if (s->do_variable == st)
2218       {
2219         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2220                       "loop beginning at %L", st->name, &s->head->loc);
2221         return 1;
2222       }
2223
2224   return 0;
2225 }
2226
2227
2228 /* Checks to see if the current statement label closes an enddo.
2229    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2230    an error) if it incorrectly closes an ENDDO.  */
2231
2232 static int
2233 check_do_closure (void)
2234 {
2235   gfc_state_data *p;
2236
2237   if (gfc_statement_label == NULL)
2238     return 0;
2239
2240   for (p = gfc_state_stack; p; p = p->previous)
2241     if (p->state == COMP_DO)
2242       break;
2243
2244   if (p == NULL)
2245     return 0;           /* No loops to close */
2246
2247   if (p->ext.end_do_label == gfc_statement_label)
2248     {
2249
2250       if (p == gfc_state_stack)
2251         return 1;
2252
2253       gfc_error
2254         ("End of nonblock DO statement at %C is within another block");
2255       return 2;
2256     }
2257
2258   /* At this point, the label doesn't terminate the innermost loop.
2259      Make sure it doesn't terminate another one.  */
2260   for (; p; p = p->previous)
2261     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2262       {
2263         gfc_error ("End of nonblock DO statement at %C is interwoven "
2264                    "with another DO loop");
2265         return 2;
2266       }
2267
2268   return 0;
2269 }
2270
2271
2272 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
2273    handled inside of parse_executable(), because they aren't really
2274    loop statements.  */
2275
2276 static void
2277 parse_do_block (void)
2278 {
2279   gfc_statement st;
2280   gfc_code *top;
2281   gfc_state_data s;
2282   gfc_symtree *stree;
2283
2284   s.ext.end_do_label = new_st.label;
2285
2286   if (new_st.ext.iterator != NULL)
2287     stree = new_st.ext.iterator->var->symtree;
2288   else
2289     stree = NULL;
2290
2291   accept_statement (ST_DO);
2292
2293   top = gfc_state_stack->tail;
2294   push_state (&s, COMP_DO, gfc_new_block);
2295
2296   s.do_variable = stree;
2297
2298   top->block = new_level (top);
2299   top->block->op = EXEC_DO;
2300
2301 loop:
2302   st = parse_executable (ST_NONE);
2303
2304   switch (st)
2305     {
2306     case ST_NONE:
2307       unexpected_eof ();
2308
2309     case ST_ENDDO:
2310       if (s.ext.end_do_label != NULL
2311           && s.ext.end_do_label != gfc_statement_label)
2312         gfc_error_now
2313           ("Statement label in ENDDO at %C doesn't match DO label");
2314
2315       if (gfc_statement_label != NULL)
2316         {
2317           new_st.op = EXEC_NOP;
2318           add_statement ();
2319         }
2320       break;
2321
2322     case ST_IMPLIED_ENDDO:
2323      /* If the do-stmt of this DO construct has a do-construct-name,
2324         the corresponding end-do must be an end-do-stmt (with a matching
2325         name, but in that case we must have seen ST_ENDDO first).
2326         We only complain about this in pedantic mode.  */
2327      if (gfc_current_block () != NULL)
2328         gfc_error_now
2329           ("named block DO at %L requires matching ENDDO name",
2330            &gfc_current_block()->declared_at);
2331
2332       break;
2333
2334     default:
2335       unexpected_statement (st);
2336       goto loop;
2337     }
2338
2339   pop_state ();
2340   accept_statement (st);
2341 }
2342
2343
2344 /* Parse the statements of OpenMP do/parallel do.  */
2345
2346 static gfc_statement
2347 parse_omp_do (gfc_statement omp_st)
2348 {
2349   gfc_statement st;
2350   gfc_code *cp, *np;
2351   gfc_state_data s;
2352
2353   accept_statement (omp_st);
2354
2355   cp = gfc_state_stack->tail;
2356   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2357   np = new_level (cp);
2358   np->op = cp->op;
2359   np->block = NULL;
2360
2361   for (;;)
2362     {
2363       st = next_statement ();
2364       if (st == ST_NONE)
2365         unexpected_eof ();
2366       else if (st == ST_DO)
2367         break;
2368       else
2369         unexpected_statement (st);
2370     }
2371
2372   parse_do_block ();
2373   if (gfc_statement_label != NULL
2374       && gfc_state_stack->previous != NULL
2375       && gfc_state_stack->previous->state == COMP_DO
2376       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2377     {
2378       /* In
2379          DO 100 I=1,10
2380            !$OMP DO
2381              DO J=1,10
2382              ...
2383              100 CONTINUE
2384          there should be no !$OMP END DO.  */
2385       pop_state ();
2386       return ST_IMPLIED_ENDDO;
2387     }
2388
2389   check_do_closure ();
2390   pop_state ();
2391
2392   st = next_statement ();
2393   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2394     {
2395       if (new_st.op == EXEC_OMP_END_NOWAIT)
2396         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2397       else
2398         gcc_assert (new_st.op == EXEC_NOP);
2399       gfc_clear_new_st ();
2400       gfc_commit_symbols ();
2401       gfc_warning_check ();
2402       st = next_statement ();
2403     }
2404   return st;
2405 }
2406
2407
2408 /* Parse the statements of OpenMP atomic directive.  */
2409
2410 static void
2411 parse_omp_atomic (void)
2412 {
2413   gfc_statement st;
2414   gfc_code *cp, *np;
2415   gfc_state_data s;
2416
2417   accept_statement (ST_OMP_ATOMIC);
2418
2419   cp = gfc_state_stack->tail;
2420   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2421   np = new_level (cp);
2422   np->op = cp->op;
2423   np->block = NULL;
2424
2425   for (;;)
2426     {
2427       st = next_statement ();
2428       if (st == ST_NONE)
2429         unexpected_eof ();
2430       else if (st == ST_ASSIGNMENT)
2431         break;
2432       else
2433         unexpected_statement (st);
2434     }
2435
2436   accept_statement (st);
2437
2438   pop_state ();
2439 }
2440
2441
2442 /* Parse the statements of an OpenMP structured block.  */
2443
2444 static void
2445 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2446 {
2447   gfc_statement st, omp_end_st;
2448   gfc_code *cp, *np;
2449   gfc_state_data s;
2450
2451   accept_statement (omp_st);
2452
2453   cp = gfc_state_stack->tail;
2454   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2455   np = new_level (cp);
2456   np->op = cp->op;
2457   np->block = NULL;
2458
2459   switch (omp_st)
2460     {
2461     case ST_OMP_PARALLEL:
2462       omp_end_st = ST_OMP_END_PARALLEL;
2463       break;
2464     case ST_OMP_PARALLEL_SECTIONS:
2465       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2466       break;
2467     case ST_OMP_SECTIONS:
2468       omp_end_st = ST_OMP_END_SECTIONS;
2469       break;
2470     case ST_OMP_ORDERED:
2471       omp_end_st = ST_OMP_END_ORDERED;
2472       break;
2473     case ST_OMP_CRITICAL:
2474       omp_end_st = ST_OMP_END_CRITICAL;
2475       break;
2476     case ST_OMP_MASTER:
2477       omp_end_st = ST_OMP_END_MASTER;
2478       break;
2479     case ST_OMP_SINGLE:
2480       omp_end_st = ST_OMP_END_SINGLE;
2481       break;
2482     case ST_OMP_WORKSHARE:
2483       omp_end_st = ST_OMP_END_WORKSHARE;
2484       break;
2485     case ST_OMP_PARALLEL_WORKSHARE:
2486       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2487       break;
2488     default:
2489       gcc_unreachable ();
2490     }
2491
2492   do
2493     {
2494       if (workshare_stmts_only)
2495         {
2496           /* Inside of !$omp workshare, only
2497              scalar assignments
2498              array assignments
2499              where statements and constructs
2500              forall statements and constructs
2501              !$omp atomic
2502              !$omp critical
2503              !$omp parallel
2504              are allowed.  For !$omp critical these
2505              restrictions apply recursively.  */
2506           bool cycle = true;
2507
2508           st = next_statement ();
2509           for (;;)
2510             {
2511               switch (st)
2512                 {
2513                 case ST_NONE:
2514                   unexpected_eof ();
2515
2516                 case ST_ASSIGNMENT:
2517                 case ST_WHERE:
2518                 case ST_FORALL:
2519                   accept_statement (st);
2520                   break;
2521
2522                 case ST_WHERE_BLOCK:
2523                   parse_where_block ();
2524                   break;
2525
2526                 case ST_FORALL_BLOCK:
2527                   parse_forall_block ();
2528                   break;
2529
2530                 case ST_OMP_PARALLEL:
2531                 case ST_OMP_PARALLEL_SECTIONS:
2532                   parse_omp_structured_block (st, false);
2533                   break;
2534
2535                 case ST_OMP_PARALLEL_WORKSHARE:
2536                 case ST_OMP_CRITICAL:
2537                   parse_omp_structured_block (st, true);
2538                   break;
2539
2540                 case ST_OMP_PARALLEL_DO:
2541                   st = parse_omp_do (st);
2542                   continue;
2543
2544                 case ST_OMP_ATOMIC:
2545                   parse_omp_atomic ();
2546                   break;
2547
2548                 default:
2549                   cycle = false;
2550                   break;
2551                 }
2552
2553               if (!cycle)
2554                 break;
2555
2556               st = next_statement ();
2557             }
2558         }
2559       else
2560         st = parse_executable (ST_NONE);
2561       if (st == ST_NONE)
2562         unexpected_eof ();
2563       else if (st == ST_OMP_SECTION
2564                && (omp_st == ST_OMP_SECTIONS
2565                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
2566         {
2567           np = new_level (np);
2568           np->op = cp->op;
2569           np->block = NULL;
2570         }
2571       else if (st != omp_end_st)
2572         unexpected_statement (st);
2573     }
2574   while (st != omp_end_st);
2575
2576   switch (new_st.op)
2577     {
2578     case EXEC_OMP_END_NOWAIT:
2579       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2580       break;
2581     case EXEC_OMP_CRITICAL:
2582       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2583           || (new_st.ext.omp_name != NULL
2584               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2585         gfc_error ("Name after !$omp critical and !$omp end critical does"
2586                    " not match at %C");
2587       gfc_free ((char *) new_st.ext.omp_name);
2588       break;
2589     case EXEC_OMP_END_SINGLE:
2590       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2591         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2592       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2593       gfc_free_omp_clauses (new_st.ext.omp_clauses);
2594       break;
2595     case EXEC_NOP:
2596       break;
2597     default:
2598       gcc_unreachable ();
2599     }
2600
2601   gfc_clear_new_st ();
2602   gfc_commit_symbols ();
2603   gfc_warning_check ();
2604   pop_state ();
2605 }
2606
2607
2608 /* Accept a series of executable statements.  We return the first
2609    statement that doesn't fit to the caller.  Any block statements are
2610    passed on to the correct handler, which usually passes the buck
2611    right back here.  */
2612
2613 static gfc_statement
2614 parse_executable (gfc_statement st)
2615 {
2616   int close_flag;
2617
2618   if (st == ST_NONE)
2619     st = next_statement ();
2620
2621   for (;;)
2622     {
2623       close_flag = check_do_closure ();
2624       if (close_flag)
2625         switch (st)
2626           {
2627           case ST_GOTO:
2628           case ST_END_PROGRAM:
2629           case ST_RETURN:
2630           case ST_EXIT:
2631           case ST_END_FUNCTION:
2632           case ST_CYCLE:
2633           case ST_PAUSE:
2634           case ST_STOP:
2635           case ST_END_SUBROUTINE:
2636
2637           case ST_DO:
2638           case ST_FORALL:
2639           case ST_WHERE:
2640           case ST_SELECT_CASE:
2641             gfc_error
2642               ("%s statement at %C cannot terminate a non-block DO loop",
2643                gfc_ascii_statement (st));
2644             break;
2645
2646           default:
2647             break;
2648           }
2649
2650       switch (st)
2651         {
2652         case ST_NONE:
2653           unexpected_eof ();
2654
2655         case ST_FORMAT:
2656         case ST_DATA:
2657         case ST_ENTRY:
2658         case_executable:
2659           accept_statement (st);
2660           if (close_flag == 1)
2661             return ST_IMPLIED_ENDDO;
2662           break;
2663
2664         case ST_IF_BLOCK:
2665           parse_if_block ();
2666           break;
2667
2668         case ST_SELECT_CASE:
2669           parse_select_block ();
2670           break;
2671
2672         case ST_DO:
2673           parse_do_block ();
2674           if (check_do_closure () == 1)
2675             return ST_IMPLIED_ENDDO;
2676           break;
2677
2678         case ST_WHERE_BLOCK:
2679           parse_where_block ();
2680           break;
2681
2682         case ST_FORALL_BLOCK:
2683           parse_forall_block ();
2684           break;
2685
2686         case ST_OMP_PARALLEL:
2687         case ST_OMP_PARALLEL_SECTIONS:
2688         case ST_OMP_SECTIONS:
2689         case ST_OMP_ORDERED:
2690         case ST_OMP_CRITICAL:
2691         case ST_OMP_MASTER:
2692         case ST_OMP_SINGLE:
2693           parse_omp_structured_block (st, false);
2694           break;
2695
2696         case ST_OMP_WORKSHARE:
2697         case ST_OMP_PARALLEL_WORKSHARE:
2698           parse_omp_structured_block (st, true);
2699           break;
2700
2701         case ST_OMP_DO:
2702         case ST_OMP_PARALLEL_DO:
2703           st = parse_omp_do (st);
2704           if (st == ST_IMPLIED_ENDDO)
2705             return st;
2706           continue;
2707
2708         case ST_OMP_ATOMIC:
2709           parse_omp_atomic ();
2710           break;
2711
2712         default:
2713           return st;
2714         }
2715
2716       st = next_statement ();
2717     }
2718 }
2719
2720
2721 /* Parse a series of contained program units.  */
2722
2723 static void parse_progunit (gfc_statement);
2724
2725
2726 /* Fix the symbols for sibling functions.  These are incorrectly added to
2727    the child namespace as the parser didn't know about this procedure.  */
2728
2729 static void
2730 gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
2731 {
2732   gfc_namespace *ns;
2733   gfc_symtree *st;
2734   gfc_symbol *old_sym;
2735
2736   sym->attr.referenced = 1;
2737   for (ns = siblings; ns; ns = ns->sibling)
2738     {
2739       gfc_find_sym_tree (sym->name, ns, 0, &st);
2740
2741       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
2742         continue;
2743
2744       old_sym = st->n.sym;
2745       if ((old_sym->attr.flavor == FL_PROCEDURE
2746            || old_sym->ts.type == BT_UNKNOWN)
2747           && old_sym->ns == ns
2748           && ! old_sym->attr.contained)
2749         {
2750           /* Replace it with the symbol from the parent namespace.  */
2751           st->n.sym = sym;
2752           sym->refs++;
2753
2754           /* Free the old (local) symbol.  */
2755           old_sym->refs--;
2756           if (old_sym->refs == 0)
2757             gfc_free_symbol (old_sym);
2758         }
2759
2760       /* Do the same for any contained procedures.  */
2761       gfc_fixup_sibling_symbols (sym, ns->contained);
2762     }
2763 }
2764
2765 static void
2766 parse_contained (int module)
2767 {
2768   gfc_namespace *ns, *parent_ns;
2769   gfc_state_data s1, s2;
2770   gfc_statement st;
2771   gfc_symbol *sym;
2772   gfc_entry_list *el;
2773   int contains_statements = 0;
2774
2775   push_state (&s1, COMP_CONTAINS, NULL);
2776   parent_ns = gfc_current_ns;
2777
2778   do
2779     {
2780       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
2781
2782       gfc_current_ns->sibling = parent_ns->contained;
2783       parent_ns->contained = gfc_current_ns;
2784
2785       st = next_statement ();
2786
2787       switch (st)
2788         {
2789         case ST_NONE:
2790           unexpected_eof ();
2791
2792         case ST_FUNCTION:
2793         case ST_SUBROUTINE:
2794           contains_statements = 1;
2795           accept_statement (st);
2796
2797           push_state (&s2,
2798                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2799                       gfc_new_block);
2800
2801           /* For internal procedures, create/update the symbol in the
2802              parent namespace.  */
2803
2804           if (!module)
2805             {
2806               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2807                 gfc_error
2808                   ("Contained procedure '%s' at %C is already ambiguous",
2809                    gfc_new_block->name);
2810               else
2811                 {
2812                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
2813                                          &gfc_new_block->declared_at) ==
2814                       SUCCESS)
2815                     {
2816                       if (st == ST_FUNCTION)
2817                         gfc_add_function (&sym->attr, sym->name,
2818                                           &gfc_new_block->declared_at);
2819                       else
2820                         gfc_add_subroutine (&sym->attr, sym->name,
2821                                             &gfc_new_block->declared_at);
2822                     }
2823                 }
2824
2825               gfc_commit_symbols ();
2826             }
2827           else
2828             sym = gfc_new_block;
2829
2830           /* Mark this as a contained function, so it isn't replaced
2831              by other module functions.  */
2832           sym->attr.contained = 1;
2833           sym->attr.referenced = 1;
2834
2835           parse_progunit (ST_NONE);
2836
2837           /* Fix up any sibling functions that refer to this one.  */
2838           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2839           /* Or refer to any of its alternate entry points.  */
2840           for (el = gfc_current_ns->entries; el; el = el->next)
2841             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2842
2843           gfc_current_ns->code = s2.head;
2844           gfc_current_ns = parent_ns;
2845
2846           pop_state ();
2847           break;
2848
2849         /* These statements are associated with the end of the host
2850            unit.  */
2851         case ST_END_FUNCTION:
2852         case ST_END_MODULE:
2853         case ST_END_PROGRAM:
2854         case ST_END_SUBROUTINE:
2855           accept_statement (st);
2856           break;
2857
2858         default:
2859           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2860                      gfc_ascii_statement (st));
2861           reject_statement ();
2862           break;
2863         }
2864     }
2865   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2866          && st != ST_END_MODULE && st != ST_END_PROGRAM);
2867
2868   /* The first namespace in the list is guaranteed to not have
2869      anything (worthwhile) in it.  */
2870
2871   gfc_current_ns = parent_ns;
2872
2873   ns = gfc_current_ns->contained;
2874   gfc_current_ns->contained = ns->sibling;
2875   gfc_free_namespace (ns);
2876
2877   pop_state ();
2878   if (!contains_statements)
2879     /* This is valid in Fortran 2008.  */
2880     gfc_notify_std (GFC_STD_GNU, "Extension: "
2881                     "CONTAINS statement without FUNCTION "
2882                     "or SUBROUTINE statement at %C");
2883 }
2884
2885
2886 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
2887
2888 static void
2889 parse_progunit (gfc_statement st)
2890 {
2891   gfc_state_data *p;
2892   int n;
2893
2894   st = parse_spec (st);
2895   switch (st)
2896     {
2897     case ST_NONE:
2898       unexpected_eof ();
2899
2900     case ST_CONTAINS:
2901       goto contains;
2902
2903     case_end:
2904       accept_statement (st);
2905       goto done;
2906
2907     default:
2908       break;
2909     }
2910
2911 loop:
2912   for (;;)
2913     {
2914       st = parse_executable (st);
2915
2916       switch (st)
2917         {
2918         case ST_NONE:
2919           unexpected_eof ();
2920
2921         case ST_CONTAINS:
2922           goto contains;
2923
2924         case_end:
2925           accept_statement (st);
2926           goto done;
2927
2928         default:
2929           break;
2930         }
2931
2932       unexpected_statement (st);
2933       reject_statement ();
2934       st = next_statement ();
2935     }
2936
2937 contains:
2938   n = 0;
2939
2940   for (p = gfc_state_stack; p; p = p->previous)
2941     if (p->state == COMP_CONTAINS)
2942       n++;
2943
2944   if (gfc_find_state (COMP_MODULE) == SUCCESS)
2945     n--;
2946
2947   if (n > 0)
2948     {
2949       gfc_error ("CONTAINS statement at %C is already in a contained "
2950                  "program unit");
2951       st = next_statement ();
2952       goto loop;
2953     }
2954
2955   parse_contained (0);
2956
2957 done:
2958   gfc_current_ns->code = gfc_state_stack->head;
2959 }
2960
2961
2962 /* Come here to complain about a global symbol already in use as
2963    something else.  */
2964
2965 void
2966 global_used (gfc_gsymbol *sym, locus *where)
2967 {
2968   const char *name;
2969
2970   if (where == NULL)
2971     where = &gfc_current_locus;
2972
2973   switch(sym->type)
2974     {
2975     case GSYM_PROGRAM:
2976       name = "PROGRAM";
2977       break;
2978     case GSYM_FUNCTION:
2979       name = "FUNCTION";
2980       break;
2981     case GSYM_SUBROUTINE:
2982       name = "SUBROUTINE";
2983       break;
2984     case GSYM_COMMON:
2985       name = "COMMON";
2986       break;
2987     case GSYM_BLOCK_DATA:
2988       name = "BLOCK DATA";
2989       break;
2990     case GSYM_MODULE:
2991       name = "MODULE";
2992       break;
2993     default:
2994       gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2995       name = NULL;
2996     }
2997
2998   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2999               sym->name, where, name, &sym->where);
3000 }
3001
3002
3003 /* Parse a block data program unit.  */
3004
3005 static void
3006 parse_block_data (void)
3007 {
3008   gfc_statement st;
3009   static locus blank_locus;
3010   static int blank_block=0;
3011   gfc_gsymbol *s;
3012
3013   gfc_current_ns->proc_name = gfc_new_block;
3014   gfc_current_ns->is_block_data = 1;
3015
3016   if (gfc_new_block == NULL)
3017     {
3018       if (blank_block)
3019        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3020                   "prior BLOCK DATA at %L", &blank_locus);
3021       else
3022        {
3023          blank_block = 1;
3024          blank_locus = gfc_current_locus;
3025        }
3026     }
3027   else
3028     {
3029       s = gfc_get_gsymbol (gfc_new_block->name);
3030       if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3031        global_used(s, NULL);
3032       else
3033        {
3034          s->type = GSYM_BLOCK_DATA;
3035          s->where = gfc_current_locus;
3036          s->defined = 1;
3037        }
3038     }
3039
3040   st = parse_spec (ST_NONE);
3041
3042   while (st != ST_END_BLOCK_DATA)
3043     {
3044       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3045                  gfc_ascii_statement (st));
3046       reject_statement ();
3047       st = next_statement ();
3048     }
3049 }
3050
3051
3052 /* Parse a module subprogram.  */
3053
3054 static void
3055 parse_module (void)
3056 {
3057   gfc_statement st;
3058   gfc_gsymbol *s;
3059
3060   s = gfc_get_gsymbol (gfc_new_block->name);
3061   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3062     global_used(s, NULL);
3063   else
3064     {
3065       s->type = GSYM_MODULE;
3066       s->where = gfc_current_locus;
3067       s->defined = 1;
3068     }
3069
3070   st = parse_spec (ST_NONE);
3071
3072 loop:
3073   switch (st)
3074     {
3075     case ST_NONE:
3076       unexpected_eof ();
3077
3078     case ST_CONTAINS:
3079       parse_contained (1);
3080       break;
3081
3082     case ST_END_MODULE:
3083       accept_statement (st);
3084       break;
3085
3086     default:
3087       gfc_error ("Unexpected %s statement in MODULE at %C",
3088                  gfc_ascii_statement (st));
3089
3090       reject_statement ();
3091       st = next_statement ();
3092       goto loop;
3093     }
3094 }
3095
3096
3097 /* Add a procedure name to the global symbol table.  */
3098
3099 static void
3100 add_global_procedure (int sub)
3101 {
3102   gfc_gsymbol *s;
3103
3104   s = gfc_get_gsymbol(gfc_new_block->name);
3105
3106   if (s->defined
3107         || (s->type != GSYM_UNKNOWN && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3108     global_used(s, NULL);
3109   else
3110     {
3111       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3112       s->where = gfc_current_locus;
3113       s->defined = 1;
3114     }
3115 }
3116
3117
3118 /* Add a program to the global symbol table.  */
3119
3120 static void
3121 add_global_program (void)
3122 {
3123   gfc_gsymbol *s;
3124
3125   if (gfc_new_block == NULL)
3126     return;
3127   s = gfc_get_gsymbol (gfc_new_block->name);
3128
3129   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3130     global_used(s, NULL);
3131   else
3132     {
3133       s->type = GSYM_PROGRAM;
3134       s->where = gfc_current_locus;
3135       s->defined = 1;
3136     }
3137 }
3138
3139
3140 /* Top level parser.  */
3141
3142 try
3143 gfc_parse_file (void)
3144 {
3145   int seen_program, errors_before, errors;
3146   gfc_state_data top, s;
3147   gfc_statement st;
3148   locus prog_locus;
3149
3150   top.state = COMP_NONE;
3151   top.sym = NULL;
3152   top.previous = NULL;
3153   top.head = top.tail = NULL;
3154   top.do_variable = NULL;
3155
3156   gfc_state_stack = &top;
3157
3158   gfc_clear_new_st ();
3159
3160   gfc_statement_label = NULL;
3161
3162   if (setjmp (eof_buf))
3163     return FAILURE;     /* Come here on unexpected EOF */
3164
3165   seen_program = 0;
3166
3167   /* Exit early for empty files.  */
3168   if (gfc_at_eof ())
3169     goto done;
3170
3171 loop:
3172   gfc_init_2 ();
3173   st = next_statement ();
3174   switch (st)
3175     {
3176     case ST_NONE:
3177       gfc_done_2 ();
3178       goto done;
3179
3180     case ST_PROGRAM:
3181       if (seen_program)
3182         goto duplicate_main;
3183       seen_program = 1;
3184       prog_locus = gfc_current_locus;
3185
3186       push_state (&s, COMP_PROGRAM, gfc_new_block);
3187       main_program_symbol(gfc_current_ns);
3188       accept_statement (st);
3189       add_global_program ();
3190       parse_progunit (ST_NONE);
3191       break;
3192
3193     case ST_SUBROUTINE:
3194       add_global_procedure (1);
3195       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3196       accept_statement (st);
3197       parse_progunit (ST_NONE);
3198       break;
3199
3200     case ST_FUNCTION:
3201       add_global_procedure (0);
3202       push_state (&s, COMP_FUNCTION, gfc_new_block);
3203       accept_statement (st);
3204       parse_progunit (ST_NONE);
3205       break;
3206
3207     case ST_BLOCK_DATA:
3208       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3209       accept_statement (st);
3210       parse_block_data ();
3211       break;
3212
3213     case ST_MODULE:
3214       push_state (&s, COMP_MODULE, gfc_new_block);
3215       accept_statement (st);
3216
3217       gfc_get_errors (NULL, &errors_before);
3218       parse_module ();
3219       break;
3220
3221     /* Anything else starts a nameless main program block.  */
3222     default:
3223       if (seen_program)
3224         goto duplicate_main;
3225       seen_program = 1;
3226       prog_locus = gfc_current_locus;
3227
3228       push_state (&s, COMP_PROGRAM, gfc_new_block);
3229       main_program_symbol(gfc_current_ns);
3230       parse_progunit (st);
3231       break;
3232     }
3233
3234   gfc_current_ns->code = s.head;
3235
3236   gfc_resolve (gfc_current_ns);
3237
3238   /* Dump the parse tree if requested.  */
3239   if (gfc_option.verbose)
3240     gfc_show_namespace (gfc_current_ns);
3241
3242   gfc_get_errors (NULL, &errors);
3243   if (s.state == COMP_MODULE)
3244     {
3245       gfc_dump_module (s.sym->name, errors_before == errors);
3246       if (errors == 0)
3247         gfc_generate_module_code (gfc_current_ns);
3248     }
3249   else
3250     {
3251       if (errors == 0)
3252         gfc_generate_code (gfc_current_ns);
3253     }
3254
3255   pop_state ();
3256   gfc_done_2 ();
3257   goto loop;
3258
3259 done:
3260   return SUCCESS;
3261
3262 duplicate_main:
3263   /* If we see a duplicate main program, shut down.  If the second
3264      instance is an implied main program, ie data decls or executable
3265      statements, we're in for lots of errors.  */
3266   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3267   reject_statement ();
3268   gfc_done_2 ();
3269   return SUCCESS;
3270 }