gcc/fortran/parse.c

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