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