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