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