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