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