gcc/fortran/parse.c

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