gcc/fortran/parse.c

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