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