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