gcc/fortran/parse.c

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