gcc/fortran/parse.c

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