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