gcc/fortran/parse.c

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