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_ENTRY:
1062     case_executable:
1063     case_exec_markers:
1064       add_statement ();
1065       break;
1066
1067     default:
1068       break;
1069     }
1070
1071   gfc_commit_symbols ();
1072   gfc_warning_check ();
1073   gfc_clear_new_st ();
1074 }
1075
1076
1077 /* Undo anything tentative that has been built for the current
1078    statement.  */
1079
1080 static void
1081 reject_statement (void)
1082 {
1083
1084   gfc_undo_symbols ();
1085   gfc_clear_warning ();
1086   undo_new_statement ();
1087 }
1088
1089
1090 /* Generic complaint about an out of order statement.  We also do
1091    whatever is necessary to clean up.  */
1092
1093 static void
1094 unexpected_statement (gfc_statement st)
1095 {
1096
1097   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1098
1099   reject_statement ();
1100 }
1101
1102
1103 /* Given the next statement seen by the matcher, make sure that it is
1104    in proper order with the last.  This subroutine is initialized by
1105    calling it with an argument of ST_NONE.  If there is a problem, we
1106    issue an error and return FAILURE.  Otherwise we return SUCCESS.
1107
1108    Individual parsers need to verify that the statements seen are
1109    valid before calling here, ie ENTRY statements are not allowed in
1110    INTERFACE blocks.  The following diagram is taken from the standard:
1111
1112             +---------------------------------------+
1113             | program  subroutine  function  module |
1114             +---------------------------------------+
1115             |                 use                   |
1116             |---------------------------------------+
1117             |        |        implicit none         |
1118             |        +-----------+------------------+
1119             |        | parameter |  implicit        |
1120             |        +-----------+------------------+
1121             | format |           |  derived type    |
1122             | entry  | parameter |  interface       |
1123             |        |   data    |  specification   |
1124             |        |           |  statement func  |
1125             |        +-----------+------------------+
1126             |        |   data    |    executable    |
1127             +--------+-----------+------------------+
1128             |                contains               |
1129             +---------------------------------------+
1130             |      internal module/subprogram       |
1131             +---------------------------------------+
1132             |                   end                 |
1133             +---------------------------------------+
1134
1135 */
1136
1137 typedef struct
1138 {
1139   enum
1140   { ORDER_START, ORDER_USE, ORDER_IMPLICIT_NONE, ORDER_IMPLICIT,
1141     ORDER_SPEC, ORDER_EXEC
1142   }
1143   state;
1144   gfc_statement last_statement;
1145   locus where;
1146 }
1147 st_state;
1148
1149 static try
1150 verify_st_order (st_state * p, gfc_statement st)
1151 {
1152
1153   switch (st)
1154     {
1155     case ST_NONE:
1156       p->state = ORDER_START;
1157       break;
1158
1159     case ST_USE:
1160       if (p->state > ORDER_USE)
1161         goto order;
1162       p->state = ORDER_USE;
1163       break;
1164
1165     case ST_IMPLICIT_NONE:
1166       if (p->state > ORDER_IMPLICIT_NONE)
1167         goto order;
1168
1169    /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1170       statement disqualifies a USE but not an IMPLICIT NONE.
1171       Duplicate IMPLICIT NONEs are caught when the implicit types
1172       are set.  */
1173
1174       p->state = ORDER_IMPLICIT_NONE;
1175       break;
1176
1177     case ST_IMPLICIT:
1178       if (p->state > ORDER_IMPLICIT)
1179         goto order;
1180       p->state = ORDER_IMPLICIT;
1181       break;
1182
1183     case ST_FORMAT:
1184     case ST_ENTRY:
1185       if (p->state < ORDER_IMPLICIT_NONE)
1186         p->state = ORDER_IMPLICIT_NONE;
1187       break;
1188
1189     case ST_PARAMETER:
1190       if (p->state >= ORDER_EXEC)
1191         goto order;
1192       if (p->state < ORDER_IMPLICIT)
1193         p->state = ORDER_IMPLICIT;
1194       break;
1195
1196     case ST_DATA:
1197       if (p->state < ORDER_SPEC)
1198         p->state = ORDER_SPEC;
1199       break;
1200
1201     case ST_PUBLIC:
1202     case ST_PRIVATE:
1203     case ST_DERIVED_DECL:
1204     case_decl:
1205       if (p->state >= ORDER_EXEC)
1206         goto order;
1207       if (p->state < ORDER_SPEC)
1208         p->state = ORDER_SPEC;
1209       break;
1210
1211     case_executable:
1212     case_exec_markers:
1213       if (p->state < ORDER_EXEC)
1214         p->state = ORDER_EXEC;
1215       break;
1216
1217     default:
1218       gfc_internal_error
1219         ("Unexpected %s statement in verify_st_order() at %C",
1220          gfc_ascii_statement (st));
1221     }
1222
1223   /* All is well, record the statement in case we need it next time.  */
1224   p->where = gfc_current_locus;
1225   p->last_statement = st;
1226   return SUCCESS;
1227
1228 order:
1229   gfc_error ("%s statement at %C cannot follow %s statement at %L",
1230              gfc_ascii_statement (st),
1231              gfc_ascii_statement (p->last_statement), &p->where);
1232
1233   return FAILURE;
1234 }
1235
1236
1237 /* Handle an unexpected end of file.  This is a show-stopper...  */
1238
1239 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1240
1241 static void
1242 unexpected_eof (void)
1243 {
1244   gfc_state_data *p;
1245
1246   gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1247
1248   /* Memory cleanup.  Move to "second to last".  */
1249   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1250        p = p->previous);
1251
1252   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1253   gfc_done_2 ();
1254
1255   longjmp (eof, 1);
1256 }
1257
1258
1259 /* Parse a derived type.  */
1260
1261 static void
1262 parse_derived (void)
1263 {
1264   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1265   gfc_statement st;
1266   gfc_component *c;
1267   gfc_state_data s;
1268
1269   error_flag = 0;
1270
1271   accept_statement (ST_DERIVED_DECL);
1272   push_state (&s, COMP_DERIVED, gfc_new_block);
1273
1274   gfc_new_block->component_access = ACCESS_PUBLIC;
1275   seen_private = 0;
1276   seen_sequence = 0;
1277   seen_component = 0;
1278
1279   compiling_type = 1;
1280
1281   while (compiling_type)
1282     {
1283       st = next_statement ();
1284       switch (st)
1285         {
1286         case ST_NONE:
1287           unexpected_eof ();
1288
1289         case ST_DATA_DECL:
1290           accept_statement (st);
1291           seen_component = 1;
1292           break;
1293
1294         case ST_END_TYPE:
1295           compiling_type = 0;
1296
1297           if (!seen_component)
1298             {
1299               gfc_error ("Derived type definition at %C has no components");
1300               error_flag = 1;
1301             }
1302
1303           accept_statement (ST_END_TYPE);
1304           break;
1305
1306         case ST_PRIVATE:
1307           if (gfc_find_state (COMP_MODULE) == FAILURE)
1308             {
1309               gfc_error
1310                 ("PRIVATE statement in TYPE at %C must be inside a MODULE");
1311               error_flag = 1;
1312               break;
1313             }
1314
1315           if (seen_component)
1316             {
1317               gfc_error ("PRIVATE statement at %C must precede "
1318                          "structure components");
1319               error_flag = 1;
1320               break;
1321             }
1322
1323           if (seen_private)
1324             {
1325               gfc_error ("Duplicate PRIVATE statement at %C");
1326               error_flag = 1;
1327             }
1328
1329           s.sym->component_access = ACCESS_PRIVATE;
1330           accept_statement (ST_PRIVATE);
1331           seen_private = 1;
1332           break;
1333
1334         case ST_SEQUENCE:
1335           if (seen_component)
1336             {
1337               gfc_error ("SEQUENCE statement at %C must precede "
1338                          "structure components");
1339               error_flag = 1;
1340               break;
1341             }
1342
1343           if (gfc_current_block ()->attr.sequence)
1344             gfc_warning ("SEQUENCE attribute at %C already specified in "
1345                          "TYPE statement");
1346
1347           if (seen_sequence)
1348             {
1349               gfc_error ("Duplicate SEQUENCE statement at %C");
1350               error_flag = 1;
1351             }
1352
1353           seen_sequence = 1;
1354           gfc_add_sequence (&gfc_current_block ()->attr, NULL);
1355           break;
1356
1357         default:
1358           unexpected_statement (st);
1359           break;
1360         }
1361     }
1362
1363   /* Sanity checks on the structure.  If the structure has the
1364      SEQUENCE attribute, then all component structures must also have
1365      SEQUENCE.  */
1366   if (error_flag == 0 && gfc_current_block ()->attr.sequence)
1367     for (c = gfc_current_block ()->components; c; c = c->next)
1368       {
1369         if (c->ts.type == BT_DERIVED && c->ts.derived->attr.sequence == 0)
1370           {
1371             gfc_error
1372               ("Component %s of SEQUENCE type declared at %C does not "
1373                "have the SEQUENCE attribute", c->ts.derived->name);
1374           }
1375       }
1376
1377   pop_state ();
1378 }
1379
1380
1381
1382 /* Parse an interface.  We must be able to deal with the possibility
1383    of recursive interfaces.  The parse_spec() subroutine is mutually
1384    recursive with parse_interface().  */
1385
1386 static gfc_statement parse_spec (gfc_statement);
1387
1388 static void
1389 parse_interface (void)
1390 {
1391   gfc_compile_state new_state, current_state;
1392   gfc_symbol *prog_unit, *sym;
1393   gfc_interface_info save;
1394   gfc_state_data s1, s2;
1395   gfc_statement st;
1396
1397   accept_statement (ST_INTERFACE);
1398
1399   current_interface.ns = gfc_current_ns;
1400   save = current_interface;
1401
1402   sym = (current_interface.type == INTERFACE_GENERIC
1403          || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
1404
1405   push_state (&s1, COMP_INTERFACE, sym);
1406   current_state = COMP_NONE;
1407
1408 loop:
1409   gfc_current_ns = gfc_get_namespace (current_interface.ns);
1410
1411   st = next_statement ();
1412   switch (st)
1413     {
1414     case ST_NONE:
1415       unexpected_eof ();
1416
1417     case ST_SUBROUTINE:
1418       new_state = COMP_SUBROUTINE;
1419       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1420                                   gfc_new_block->formal, NULL);
1421       break;
1422
1423     case ST_FUNCTION:
1424       new_state = COMP_FUNCTION;
1425       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1426                                   gfc_new_block->formal, NULL);
1427       break;
1428
1429     case ST_MODULE_PROC:        /* The module procedure matcher makes
1430                                    sure the context is correct.  */
1431       accept_statement (st);
1432       gfc_free_namespace (gfc_current_ns);
1433       goto loop;
1434
1435     case ST_END_INTERFACE:
1436       gfc_free_namespace (gfc_current_ns);
1437       gfc_current_ns = current_interface.ns;
1438       goto done;
1439
1440     default:
1441       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1442                  gfc_ascii_statement (st));
1443       reject_statement ();
1444       gfc_free_namespace (gfc_current_ns);
1445       goto loop;
1446     }
1447
1448
1449   /* Make sure that a generic interface has only subroutines or
1450      functions and that the generic name has the right attribute.  */
1451   if (current_interface.type == INTERFACE_GENERIC)
1452     {
1453       if (current_state == COMP_NONE)
1454         {
1455           if (new_state == COMP_FUNCTION)
1456             gfc_add_function (&sym->attr, NULL);
1457           if (new_state == COMP_SUBROUTINE)
1458             gfc_add_subroutine (&sym->attr, NULL);
1459
1460           current_state = new_state;
1461         }
1462       else
1463         {
1464           if (new_state != current_state)
1465             {
1466               if (new_state == COMP_SUBROUTINE)
1467                 gfc_error
1468                   ("SUBROUTINE at %C does not belong in a generic function "
1469                    "interface");
1470
1471               if (new_state == COMP_FUNCTION)
1472                 gfc_error
1473                   ("FUNCTION at %C does not belong in a generic subroutine "
1474                    "interface");
1475             }
1476         }
1477     }
1478
1479   push_state (&s2, new_state, gfc_new_block);
1480   accept_statement (st);
1481   prog_unit = gfc_new_block;
1482   prog_unit->formal_ns = gfc_current_ns;
1483
1484 decl:
1485   /* Read data declaration statements.  */
1486   st = parse_spec (ST_NONE);
1487
1488   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
1489     {
1490       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1491                  gfc_ascii_statement (st));
1492       reject_statement ();
1493       goto decl;
1494     }
1495
1496   current_interface = save;
1497   gfc_add_interface (prog_unit);
1498
1499   pop_state ();
1500   goto loop;
1501
1502 done:
1503   pop_state ();
1504 }
1505
1506
1507 /* Parse a set of specification statements.  Returns the statement
1508    that doesn't fit.  */
1509
1510 static gfc_statement
1511 parse_spec (gfc_statement st)
1512 {
1513   st_state ss;
1514
1515   verify_st_order (&ss, ST_NONE);
1516   if (st == ST_NONE)
1517     st = next_statement ();
1518
1519 loop:
1520   switch (st)
1521     {
1522     case ST_NONE:
1523       unexpected_eof ();
1524
1525     case ST_FORMAT:
1526     case ST_ENTRY:
1527     case ST_DATA:       /* Not allowed in interfaces */
1528       if (gfc_current_state () == COMP_INTERFACE)
1529         break;
1530
1531       /* Fall through */
1532
1533     case ST_USE:
1534     case ST_IMPLICIT_NONE:
1535     case ST_IMPLICIT:
1536     case ST_PARAMETER:
1537     case ST_PUBLIC:
1538     case ST_PRIVATE:
1539     case ST_DERIVED_DECL:
1540     case_decl:
1541       if (verify_st_order (&ss, st) == FAILURE)
1542         {
1543           reject_statement ();
1544           st = next_statement ();
1545           goto loop;
1546         }
1547
1548       switch (st)
1549         {
1550         case ST_INTERFACE:
1551           parse_interface ();
1552           break;
1553
1554         case ST_DERIVED_DECL:
1555           parse_derived ();
1556           break;
1557
1558         case ST_PUBLIC:
1559         case ST_PRIVATE:
1560           if (gfc_current_state () != COMP_MODULE)
1561             {
1562               gfc_error ("%s statement must appear in a MODULE",
1563                          gfc_ascii_statement (st));
1564               break;
1565             }
1566
1567           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
1568             {
1569               gfc_error ("%s statement at %C follows another accessibility "
1570                          "specification", gfc_ascii_statement (st));
1571               break;
1572             }
1573
1574           gfc_current_ns->default_access = (st == ST_PUBLIC)
1575             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
1576
1577           break;
1578
1579         default:
1580           break;
1581         }
1582
1583       accept_statement (st);
1584       st = next_statement ();
1585       goto loop;
1586
1587     default:
1588       break;
1589     }
1590
1591   return st;
1592 }
1593
1594
1595 /* Parse a WHERE block, (not a simple WHERE statement).  */
1596
1597 static void
1598 parse_where_block (void)
1599 {
1600   int seen_empty_else;
1601   gfc_code *top, *d;
1602   gfc_state_data s;
1603   gfc_statement st;
1604
1605   accept_statement (ST_WHERE_BLOCK);
1606   top = gfc_state_stack->tail;
1607
1608   push_state (&s, COMP_WHERE, gfc_new_block);
1609
1610   d = add_statement ();
1611   d->expr = top->expr;
1612   d->op = EXEC_WHERE;
1613
1614   top->expr = NULL;
1615   top->block = d;
1616
1617   seen_empty_else = 0;
1618
1619   do
1620     {
1621       st = next_statement ();
1622       switch (st)
1623         {
1624         case ST_NONE:
1625           unexpected_eof ();
1626
1627         case ST_WHERE_BLOCK:
1628           parse_where_block ();
1629           /* Fall through */
1630
1631         case ST_ASSIGNMENT:
1632         case ST_WHERE:
1633           accept_statement (st);
1634           break;
1635
1636         case ST_ELSEWHERE:
1637           if (seen_empty_else)
1638             {
1639               gfc_error
1640                 ("ELSEWHERE statement at %C follows previous unmasked "
1641                  "ELSEWHERE");
1642               break;
1643             }
1644
1645           if (new_st.expr == NULL)
1646             seen_empty_else = 1;
1647
1648           d = new_level (gfc_state_stack->head);
1649           d->op = EXEC_WHERE;
1650           d->expr = new_st.expr;
1651
1652           accept_statement (st);
1653
1654           break;
1655
1656         case ST_END_WHERE:
1657           accept_statement (st);
1658           break;
1659
1660         default:
1661           gfc_error ("Unexpected %s statement in WHERE block at %C",
1662                      gfc_ascii_statement (st));
1663           reject_statement ();
1664           break;
1665         }
1666
1667     }
1668   while (st != ST_END_WHERE);
1669
1670   pop_state ();
1671 }
1672
1673
1674 /* Parse a FORALL block (not a simple FORALL statement).  */
1675
1676 static void
1677 parse_forall_block (void)
1678 {
1679   gfc_code *top, *d;
1680   gfc_state_data s;
1681   gfc_statement st;
1682
1683   accept_statement (ST_FORALL_BLOCK);
1684   top = gfc_state_stack->tail;
1685
1686   push_state (&s, COMP_FORALL, gfc_new_block);
1687
1688   d = add_statement ();
1689   d->op = EXEC_FORALL;
1690   top->block = d;
1691
1692   do
1693     {
1694       st = next_statement ();
1695       switch (st)
1696         {
1697
1698         case ST_ASSIGNMENT:
1699         case ST_POINTER_ASSIGNMENT:
1700         case ST_WHERE:
1701         case ST_FORALL:
1702           accept_statement (st);
1703           break;
1704
1705         case ST_WHERE_BLOCK:
1706           parse_where_block ();
1707           break;
1708
1709         case ST_FORALL_BLOCK:
1710           parse_forall_block ();
1711           break;
1712
1713         case ST_END_FORALL:
1714           accept_statement (st);
1715           break;
1716
1717         case ST_NONE:
1718           unexpected_eof ();
1719
1720         default:
1721           gfc_error ("Unexpected %s statement in FORALL block at %C",
1722                      gfc_ascii_statement (st));
1723
1724           reject_statement ();
1725           break;
1726         }
1727     }
1728   while (st != ST_END_FORALL);
1729
1730   pop_state ();
1731 }
1732
1733
1734 static gfc_statement parse_executable (gfc_statement);
1735
1736 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
1737
1738 static void
1739 parse_if_block (void)
1740 {
1741   gfc_code *top, *d;
1742   gfc_statement st;
1743   locus else_locus;
1744   gfc_state_data s;
1745   int seen_else;
1746
1747   seen_else = 0;
1748   accept_statement (ST_IF_BLOCK);
1749
1750   top = gfc_state_stack->tail;
1751   push_state (&s, COMP_IF, gfc_new_block);
1752
1753   new_st.op = EXEC_IF;
1754   d = add_statement ();
1755
1756   d->expr = top->expr;
1757   top->expr = NULL;
1758   top->block = d;
1759
1760   do
1761     {
1762       st = parse_executable (ST_NONE);
1763
1764       switch (st)
1765         {
1766         case ST_NONE:
1767           unexpected_eof ();
1768
1769         case ST_ELSEIF:
1770           if (seen_else)
1771             {
1772               gfc_error
1773                 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
1774                  &else_locus);
1775
1776               reject_statement ();
1777               break;
1778             }
1779
1780           d = new_level (gfc_state_stack->head);
1781           d->op = EXEC_IF;
1782           d->expr = new_st.expr;
1783
1784           accept_statement (st);
1785
1786           break;
1787
1788         case ST_ELSE:
1789           if (seen_else)
1790             {
1791               gfc_error ("Duplicate ELSE statements at %L and %C",
1792                          &else_locus);
1793               reject_statement ();
1794               break;
1795             }
1796
1797           seen_else = 1;
1798           else_locus = gfc_current_locus;
1799
1800           d = new_level (gfc_state_stack->head);
1801           d->op = EXEC_IF;
1802
1803           accept_statement (st);
1804
1805           break;
1806
1807         case ST_ENDIF:
1808           break;
1809
1810         default:
1811           unexpected_statement (st);
1812           break;
1813         }
1814     }
1815   while (st != ST_ENDIF);
1816
1817   pop_state ();
1818   accept_statement (st);
1819 }
1820
1821
1822 /* Parse a SELECT block.  */
1823
1824 static void
1825 parse_select_block (void)
1826 {
1827   gfc_statement st;
1828   gfc_code *cp;
1829   gfc_state_data s;
1830
1831   accept_statement (ST_SELECT_CASE);
1832
1833   cp = gfc_state_stack->tail;
1834   push_state (&s, COMP_SELECT, gfc_new_block);
1835
1836   /* Make sure that the next statement is a CASE or END SELECT.  */
1837   for (;;)
1838     {
1839       st = next_statement ();
1840       if (st == ST_NONE)
1841         unexpected_eof ();
1842       if (st == ST_END_SELECT)
1843         {
1844           /* Empty SELECT CASE is OK.  */
1845           accept_statement (st);
1846           pop_state ();
1847           return;
1848         }
1849       if (st == ST_CASE)
1850         break;
1851
1852       gfc_error
1853         ("Expected a CASE or END SELECT statement following SELECT CASE "
1854          "at %C");
1855
1856       reject_statement ();
1857     }
1858
1859   /* At this point, we're got a nonempty select block.  */
1860   cp = new_level (cp);
1861   *cp = new_st;
1862
1863   accept_statement (st);
1864
1865   do
1866     {
1867       st = parse_executable (ST_NONE);
1868       switch (st)
1869         {
1870         case ST_NONE:
1871           unexpected_eof ();
1872
1873         case ST_CASE:
1874           cp = new_level (gfc_state_stack->head);
1875           *cp = new_st;
1876           gfc_clear_new_st ();
1877
1878           accept_statement (st);
1879           /* Fall through */
1880
1881         case ST_END_SELECT:
1882           break;
1883
1884         /* Can't have an executable statement because of
1885            parse_executable().  */
1886         default:
1887           unexpected_statement (st);
1888           break;
1889         }
1890     }
1891   while (st != ST_END_SELECT);
1892
1893   pop_state ();
1894   accept_statement (st);
1895 }
1896
1897
1898 /* Given a symbol, make sure it is not an iteration variable for a DO
1899    statement.  This subroutine is called when the symbol is seen in a
1900    context that causes it to become redefined.  If the symbol is an
1901    iterator, we generate an error message and return nonzero.  */
1902
1903 int
1904 gfc_check_do_variable (gfc_symtree *st)
1905 {
1906   gfc_state_data *s;
1907
1908   for (s=gfc_state_stack; s; s = s->previous)
1909     if (s->do_variable == st)
1910       {
1911         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
1912                       "loop beginning at %L", st->name, &s->head->loc);
1913         return 1;
1914       }
1915
1916   return 0;
1917 }
1918
1919
1920 /* Checks to see if the current statement label closes an enddo.
1921    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
1922    an error) if it incorrectly closes an ENDDO.  */
1923
1924 static int
1925 check_do_closure (void)
1926 {
1927   gfc_state_data *p;
1928
1929   if (gfc_statement_label == NULL)
1930     return 0;
1931
1932   for (p = gfc_state_stack; p; p = p->previous)
1933     if (p->state == COMP_DO)
1934       break;
1935
1936   if (p == NULL)
1937     return 0;           /* No loops to close */
1938
1939   if (p->ext.end_do_label == gfc_statement_label)
1940     {
1941
1942       if (p == gfc_state_stack)
1943         return 1;
1944
1945       gfc_error
1946         ("End of nonblock DO statement at %C is within another block");
1947       return 2;
1948     }
1949
1950   /* At this point, the label doesn't terminate the innermost loop.
1951      Make sure it doesn't terminate another one.  */
1952   for (; p; p = p->previous)
1953     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
1954       {
1955         gfc_error ("End of nonblock DO statement at %C is interwoven "
1956                    "with another DO loop");
1957         return 2;
1958       }
1959
1960   return 0;
1961 }
1962
1963
1964 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
1965    handled inside of parse_executable(), because they aren't really
1966    loop statements.  */
1967
1968 static void
1969 parse_do_block (void)
1970 {
1971   gfc_statement st;
1972   gfc_code *top;
1973   gfc_state_data s;
1974   gfc_symtree *stree;
1975
1976   s.ext.end_do_label = new_st.label;
1977
1978   if (new_st.ext.iterator != NULL)
1979     stree = new_st.ext.iterator->var->symtree;
1980   else
1981     stree = NULL;
1982
1983   accept_statement (ST_DO);
1984
1985   top = gfc_state_stack->tail;
1986   push_state (&s, COMP_DO, gfc_new_block);
1987
1988   s.do_variable = stree;
1989
1990   top->block = new_level (top);
1991   top->block->op = EXEC_DO;
1992
1993 loop:
1994   st = parse_executable (ST_NONE);
1995
1996   switch (st)
1997     {
1998     case ST_NONE:
1999       unexpected_eof ();
2000
2001     case ST_ENDDO:
2002       if (s.ext.end_do_label != NULL
2003           && s.ext.end_do_label != gfc_statement_label)
2004         gfc_error_now
2005           ("Statement label in ENDDO at %C doesn't match DO label");
2006       /* Fall through */
2007
2008     case ST_IMPLIED_ENDDO:
2009       break;
2010
2011     default:
2012       unexpected_statement (st);
2013       goto loop;
2014     }
2015
2016   pop_state ();
2017   accept_statement (st);
2018 }
2019
2020
2021 /* Accept a series of executable statements.  We return the first
2022    statement that doesn't fit to the caller.  Any block statements are
2023    passed on to the correct handler, which usually passes the buck
2024    right back here.  */
2025
2026 static gfc_statement
2027 parse_executable (gfc_statement st)
2028 {
2029   int close_flag;
2030
2031   if (st == ST_NONE)
2032     st = next_statement ();
2033
2034   for (;; st = next_statement ())
2035     {
2036
2037       close_flag = check_do_closure ();
2038       if (close_flag)
2039         switch (st)
2040           {
2041           case ST_GOTO:
2042           case ST_END_PROGRAM:
2043           case ST_RETURN:
2044           case ST_EXIT:
2045           case ST_END_FUNCTION:
2046           case ST_CYCLE:
2047           case ST_PAUSE:
2048           case ST_STOP:
2049           case ST_END_SUBROUTINE:
2050
2051           case ST_DO:
2052           case ST_FORALL:
2053           case ST_WHERE:
2054           case ST_SELECT_CASE:
2055             gfc_error
2056               ("%s statement at %C cannot terminate a non-block DO loop",
2057                gfc_ascii_statement (st));
2058             break;
2059
2060           default:
2061             break;
2062           }
2063
2064       switch (st)
2065         {
2066         case ST_NONE:
2067           unexpected_eof ();
2068
2069         case ST_FORMAT:
2070         case ST_DATA:
2071         case ST_ENTRY:
2072         case_executable:
2073           accept_statement (st);
2074           if (close_flag == 1)
2075             return ST_IMPLIED_ENDDO;
2076           continue;
2077
2078         case ST_IF_BLOCK:
2079           parse_if_block ();
2080           continue;
2081
2082         case ST_SELECT_CASE:
2083           parse_select_block ();
2084           continue;
2085
2086         case ST_DO:
2087           parse_do_block ();
2088           if (check_do_closure () == 1)
2089             return ST_IMPLIED_ENDDO;
2090           continue;
2091
2092         case ST_WHERE_BLOCK:
2093           parse_where_block ();
2094           continue;
2095
2096         case ST_FORALL_BLOCK:
2097           parse_forall_block ();
2098           continue;
2099
2100         default:
2101           break;
2102         }
2103
2104       break;
2105     }
2106
2107   return st;
2108 }
2109
2110
2111 /* Parse a series of contained program units.  */
2112
2113 static void parse_progunit (gfc_statement);
2114
2115
2116 /* Fix the symbols for sibling functions.  These are incorrectly added to
2117    the child namespace as the parser didn't know about this procedure.  */
2118
2119 static void
2120 gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
2121 {
2122   gfc_namespace *ns;
2123   gfc_symtree *st;
2124   gfc_symbol *old_sym;
2125
2126   sym->attr.referenced = 1;
2127   for (ns = siblings; ns; ns = ns->sibling)
2128     {
2129       gfc_find_sym_tree (sym->name, ns, 0, &st);
2130       if (!st)
2131         continue;
2132
2133       old_sym = st->n.sym;
2134       if ((old_sym->attr.flavor == FL_PROCEDURE
2135            || old_sym->ts.type == BT_UNKNOWN)
2136           && old_sym->ns == ns
2137           && ! old_sym->attr.contained)
2138         {
2139           /* Replace it with the symbol from the parent namespace.  */
2140           st->n.sym = sym;
2141           sym->refs++;
2142
2143           /* Free the old (local) symbol.  */
2144           old_sym->refs--;
2145           if (old_sym->refs == 0)
2146             gfc_free_symbol (old_sym);
2147         }
2148
2149       /* Do the same for any contined procedures.  */
2150       gfc_fixup_sibling_symbols (sym, ns->contained);
2151     }
2152 }
2153
2154 static void
2155 parse_contained (int module)
2156 {
2157   gfc_namespace *ns, *parent_ns;
2158   gfc_state_data s1, s2;
2159   gfc_statement st;
2160   gfc_symbol *sym;
2161   gfc_entry_list *el;
2162
2163   push_state (&s1, COMP_CONTAINS, NULL);
2164   parent_ns = gfc_current_ns;
2165
2166   do
2167     {
2168       gfc_current_ns = gfc_get_namespace (parent_ns);
2169
2170       gfc_current_ns->sibling = parent_ns->contained;
2171       parent_ns->contained = gfc_current_ns;
2172
2173       st = next_statement ();
2174
2175       switch (st)
2176         {
2177         case ST_NONE:
2178           unexpected_eof ();
2179
2180         case ST_FUNCTION:
2181         case ST_SUBROUTINE:
2182           accept_statement (st);
2183
2184           push_state (&s2,
2185                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2186                       gfc_new_block);
2187
2188           /* For internal procedures, create/update the symbol in the
2189              parent namespace.  */
2190
2191           if (!module)
2192             {
2193               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2194                 gfc_error
2195                   ("Contained procedure '%s' at %C is already ambiguous",
2196                    gfc_new_block->name);
2197               else
2198                 {
2199                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
2200                                          &gfc_new_block->declared_at) ==
2201                       SUCCESS)
2202                     {
2203                       if (st == ST_FUNCTION)
2204                         gfc_add_function (&sym->attr,
2205                                           &gfc_new_block->declared_at);
2206                       else
2207                         gfc_add_subroutine (&sym->attr,
2208                                             &gfc_new_block->declared_at);
2209                     }
2210                 }
2211
2212               gfc_commit_symbols ();
2213             }
2214           else
2215             sym = gfc_new_block;
2216
2217           /* Mark this as a contained function, so it isn't replaced
2218              by other module functions.  */
2219           sym->attr.contained = 1;
2220           sym->attr.referenced = 1;
2221
2222           parse_progunit (ST_NONE);
2223
2224           /* Fix up any sibling functions that refer to this one.  */
2225           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2226           /* Or refer to any of its alternate entry points.  */
2227           for (el = gfc_current_ns->entries; el; el = el->next)
2228             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2229
2230           gfc_current_ns->code = s2.head;
2231           gfc_current_ns = parent_ns;
2232
2233           pop_state ();
2234           break;
2235
2236         /* These statements are associated with the end of the host
2237            unit.  */
2238         case ST_END_FUNCTION:
2239         case ST_END_MODULE:
2240         case ST_END_PROGRAM:
2241         case ST_END_SUBROUTINE:
2242           accept_statement (st);
2243           break;
2244
2245         default:
2246           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2247                      gfc_ascii_statement (st));
2248           reject_statement ();
2249           break;
2250         }
2251     }
2252   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2253          && st != ST_END_MODULE && st != ST_END_PROGRAM);
2254
2255   /* The first namespace in the list is guaranteed to not have
2256      anything (worthwhile) in it.  */
2257
2258   gfc_current_ns = parent_ns;
2259
2260   ns = gfc_current_ns->contained;
2261   gfc_current_ns->contained = ns->sibling;
2262   gfc_free_namespace (ns);
2263
2264   pop_state ();
2265 }
2266
2267
2268 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
2269
2270 static void
2271 parse_progunit (gfc_statement st)
2272 {
2273   gfc_state_data *p;
2274   int n;
2275
2276   st = parse_spec (st);
2277   switch (st)
2278     {
2279     case ST_NONE:
2280       unexpected_eof ();
2281
2282     case ST_CONTAINS:
2283       goto contains;
2284
2285     case_end:
2286       accept_statement (st);
2287       goto done;
2288
2289     default:
2290       break;
2291     }
2292
2293 loop:
2294   for (;;)
2295     {
2296       st = parse_executable (st);
2297
2298       switch (st)
2299         {
2300         case ST_NONE:
2301           unexpected_eof ();
2302
2303         case ST_CONTAINS:
2304           goto contains;
2305
2306         case_end:
2307           accept_statement (st);
2308           goto done;
2309
2310         default:
2311           break;
2312         }
2313
2314       unexpected_statement (st);
2315       reject_statement ();
2316       st = next_statement ();
2317     }
2318
2319 contains:
2320   n = 0;
2321
2322   for (p = gfc_state_stack; p; p = p->previous)
2323     if (p->state == COMP_CONTAINS)
2324       n++;
2325
2326   if (gfc_find_state (COMP_MODULE) == SUCCESS)
2327     n--;
2328
2329   if (n > 0)
2330     {
2331       gfc_error ("CONTAINS statement at %C is already in a contained "
2332                  "program unit");
2333       st = next_statement ();
2334       goto loop;
2335     }
2336
2337   parse_contained (0);
2338
2339 done:
2340   gfc_current_ns->code = gfc_state_stack->head;
2341 }
2342
2343
2344 /* Come here to complain about a global symbol already in use as
2345    something else.  */
2346
2347 static void
2348 global_used (gfc_gsymbol *sym, locus *where)
2349 {
2350   const char *name;
2351
2352   if (where == NULL)
2353     where = &gfc_current_locus;
2354
2355   switch(sym->type)
2356     {
2357     case GSYM_PROGRAM:
2358       name = "PROGRAM";
2359       break;
2360     case GSYM_FUNCTION:
2361       name = "FUNCTION";
2362       break;
2363     case GSYM_SUBROUTINE:
2364       name = "SUBROUTINE";
2365       break;
2366     case GSYM_COMMON:
2367       name = "COMMON";
2368       break;
2369     case GSYM_BLOCK_DATA:
2370       name = "BLOCK DATA";
2371       break;
2372     case GSYM_MODULE:
2373       name = "MODULE";
2374       break;
2375     default:
2376       gfc_internal_error ("gfc_gsymbol_type(): Bad type");
2377       name = NULL;
2378     }
2379
2380   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
2381            gfc_new_block->name, where, name, &sym->where);
2382 }
2383
2384
2385 /* Parse a block data program unit.  */
2386
2387 static void
2388 parse_block_data (void)
2389 {
2390   gfc_statement st;
2391   static locus blank_locus;
2392   static int blank_block=0;
2393   gfc_gsymbol *s;
2394
2395   gfc_current_ns->proc_name = gfc_new_block;
2396   gfc_current_ns->is_block_data = 1;
2397
2398   if (gfc_new_block == NULL)
2399     {
2400       if (blank_block)
2401        gfc_error ("Blank BLOCK DATA at %C conflicts with "
2402                   "prior BLOCK DATA at %L", &blank_locus);
2403       else
2404        {
2405          blank_block = 1;
2406          blank_locus = gfc_current_locus;
2407        }
2408     }
2409   else
2410     {
2411       s = gfc_get_gsymbol (gfc_new_block->name);
2412       if (s->type != GSYM_UNKNOWN)
2413        global_used(s, NULL);
2414       else
2415        {
2416          s->type = GSYM_BLOCK_DATA;
2417          s->where = gfc_current_locus;
2418        }
2419     }
2420
2421   st = parse_spec (ST_NONE);
2422
2423   while (st != ST_END_BLOCK_DATA)
2424     {
2425       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2426                  gfc_ascii_statement (st));
2427       reject_statement ();
2428       st = next_statement ();
2429     }
2430 }
2431
2432
2433 /* Parse a module subprogram.  */
2434
2435 static void
2436 parse_module (void)
2437 {
2438   gfc_statement st;
2439   gfc_gsymbol *s;
2440
2441   s = gfc_get_gsymbol (gfc_new_block->name);
2442   if (s->type != GSYM_UNKNOWN)
2443     global_used(s, NULL);
2444   else
2445     {
2446       s->type = GSYM_MODULE;
2447       s->where = gfc_current_locus;
2448     }
2449
2450   st = parse_spec (ST_NONE);
2451
2452 loop:
2453   switch (st)
2454     {
2455     case ST_NONE:
2456       unexpected_eof ();
2457
2458     case ST_CONTAINS:
2459       parse_contained (1);
2460       break;
2461
2462     case ST_END_MODULE:
2463       accept_statement (st);
2464       break;
2465
2466     default:
2467       gfc_error ("Unexpected %s statement in MODULE at %C",
2468                  gfc_ascii_statement (st));
2469
2470       reject_statement ();
2471       st = next_statement ();
2472       goto loop;
2473     }
2474 }
2475
2476
2477 /* Add a procedure name to the global symbol table.  */
2478
2479 static void
2480 add_global_procedure (int sub)
2481 {
2482   gfc_gsymbol *s;
2483
2484   s = gfc_get_gsymbol(gfc_new_block->name);
2485
2486   if (s->type != GSYM_UNKNOWN)
2487     global_used(s, NULL);
2488   else
2489     {
2490       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2491       s->where = gfc_current_locus;
2492     }
2493 }
2494
2495
2496 /* Add a program to the global symbol table.  */
2497
2498 static void
2499 add_global_program (void)
2500 {
2501   gfc_gsymbol *s;
2502
2503   if (gfc_new_block == NULL)
2504     return;
2505   s = gfc_get_gsymbol (gfc_new_block->name);
2506
2507   if (s->type != GSYM_UNKNOWN)
2508     global_used(s, NULL);
2509   else
2510     {
2511       s->type = GSYM_PROGRAM;
2512       s->where = gfc_current_locus;
2513     }
2514 }
2515
2516
2517 /* Top level parser.  */
2518
2519 try
2520 gfc_parse_file (void)
2521 {
2522   int seen_program, errors_before, errors;
2523   gfc_state_data top, s;
2524   gfc_statement st;
2525   locus prog_locus;
2526
2527   top.state = COMP_NONE;
2528   top.sym = NULL;
2529   top.previous = NULL;
2530   top.head = top.tail = NULL;
2531   top.do_variable = NULL;
2532
2533   gfc_state_stack = &top;
2534
2535   gfc_clear_new_st ();
2536
2537   gfc_statement_label = NULL;
2538
2539   if (setjmp (eof))
2540     return FAILURE;     /* Come here on unexpected EOF */
2541
2542   seen_program = 0;
2543
2544 loop:
2545   gfc_init_2 ();
2546   st = next_statement ();
2547   switch (st)
2548     {
2549     case ST_NONE:
2550       gfc_done_2 ();
2551       goto done;
2552
2553     case ST_PROGRAM:
2554       if (seen_program)
2555         goto duplicate_main;
2556       seen_program = 1;
2557       prog_locus = gfc_current_locus;
2558
2559       push_state (&s, COMP_PROGRAM, gfc_new_block);
2560       accept_statement (st);
2561       add_global_program ();
2562       parse_progunit (ST_NONE);
2563       break;
2564
2565     case ST_SUBROUTINE:
2566       add_global_procedure (1);
2567       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
2568       accept_statement (st);
2569       parse_progunit (ST_NONE);
2570       break;
2571
2572     case ST_FUNCTION:
2573       add_global_procedure (0);
2574       push_state (&s, COMP_FUNCTION, gfc_new_block);
2575       accept_statement (st);
2576       parse_progunit (ST_NONE);
2577       break;
2578
2579     case ST_BLOCK_DATA:
2580       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
2581       accept_statement (st);
2582       parse_block_data ();
2583       break;
2584
2585     case ST_MODULE:
2586       push_state (&s, COMP_MODULE, gfc_new_block);
2587       accept_statement (st);
2588
2589       gfc_get_errors (NULL, &errors_before);
2590       parse_module ();
2591       break;
2592
2593     /* Anything else starts a nameless main program block.  */
2594     default:
2595       if (seen_program)
2596         goto duplicate_main;
2597       seen_program = 1;
2598       prog_locus = gfc_current_locus;
2599
2600       push_state (&s, COMP_PROGRAM, gfc_new_block);
2601       parse_progunit (st);
2602       break;
2603     }
2604
2605   gfc_current_ns->code = s.head;
2606
2607   gfc_resolve (gfc_current_ns);
2608
2609   /* Dump the parse tree if requested.  */
2610   if (gfc_option.verbose)
2611     gfc_show_namespace (gfc_current_ns);
2612
2613   gfc_get_errors (NULL, &errors);
2614   if (s.state == COMP_MODULE)
2615     {
2616       gfc_dump_module (s.sym->name, errors_before == errors);
2617       if (errors == 0 && ! gfc_option.flag_no_backend)
2618         gfc_generate_module_code (gfc_current_ns);
2619     }
2620   else
2621     {
2622       if (errors == 0 && ! gfc_option.flag_no_backend)
2623         gfc_generate_code (gfc_current_ns);
2624     }
2625
2626   pop_state ();
2627   gfc_done_2 ();
2628   goto loop;
2629
2630 done:
2631   return SUCCESS;
2632
2633 duplicate_main:
2634   /* If we see a duplicate main program, shut down.  If the second
2635      instance is an implied main program, ie data decls or executable
2636      statements, we're in for lots of errors.  */
2637   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
2638   reject_statement ();
2639   gfc_done_2 ();
2640   return SUCCESS;
2641 }