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   int seen_body;
1413
1414   accept_statement (ST_INTERFACE);
1415
1416   current_interface.ns = gfc_current_ns;
1417   save = current_interface;
1418
1419   sym = (current_interface.type == INTERFACE_GENERIC
1420          || current_interface.type == INTERFACE_USER_OP) ? gfc_new_block : NULL;
1421
1422   push_state (&s1, COMP_INTERFACE, sym);
1423   seen_body = 0;
1424   current_state = COMP_NONE;
1425
1426 loop:
1427   gfc_current_ns = gfc_get_namespace (current_interface.ns);
1428
1429   st = next_statement ();
1430   switch (st)
1431     {
1432     case ST_NONE:
1433       unexpected_eof ();
1434
1435     case ST_SUBROUTINE:
1436       new_state = COMP_SUBROUTINE;
1437       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1438                                   gfc_new_block->formal, NULL);
1439       break;
1440
1441     case ST_FUNCTION:
1442       new_state = COMP_FUNCTION;
1443       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1444                                   gfc_new_block->formal, NULL);
1445       break;
1446
1447     case ST_MODULE_PROC:        /* The module procedure matcher makes
1448                                    sure the context is correct.  */
1449       seen_body = 1;
1450       accept_statement (st);
1451       gfc_free_namespace (gfc_current_ns);
1452       goto loop;
1453
1454     case ST_END_INTERFACE:
1455       gfc_free_namespace (gfc_current_ns);
1456       gfc_current_ns = current_interface.ns;
1457       goto done;
1458
1459     default:
1460       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1461                  gfc_ascii_statement (st));
1462       reject_statement ();
1463       gfc_free_namespace (gfc_current_ns);
1464       goto loop;
1465     }
1466
1467
1468   /* Make sure that a generic interface has only subroutines or
1469      functions and that the generic name has the right attribute.  */
1470   if (current_interface.type == INTERFACE_GENERIC)
1471     {
1472       if (current_state == COMP_NONE)
1473         {
1474           if (new_state == COMP_FUNCTION)
1475             gfc_add_function (&sym->attr, NULL);
1476           if (new_state == COMP_SUBROUTINE)
1477             gfc_add_subroutine (&sym->attr, NULL);
1478
1479           current_state = new_state;
1480         }
1481       else
1482         {
1483           if (new_state != current_state)
1484             {
1485               if (new_state == COMP_SUBROUTINE)
1486                 gfc_error
1487                   ("SUBROUTINE at %C does not belong in a generic function "
1488                    "interface");
1489
1490               if (new_state == COMP_FUNCTION)
1491                 gfc_error
1492                   ("FUNCTION at %C does not belong in a generic subroutine "
1493                    "interface");
1494             }
1495         }
1496     }
1497
1498   push_state (&s2, new_state, gfc_new_block);
1499   accept_statement (st);
1500   prog_unit = gfc_new_block;
1501   prog_unit->formal_ns = gfc_current_ns;
1502
1503 decl:
1504   /* Read data declaration statements.  */
1505   st = parse_spec (ST_NONE);
1506
1507   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
1508     {
1509       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
1510                  gfc_ascii_statement (st));
1511       reject_statement ();
1512       goto decl;
1513     }
1514
1515   seen_body = 1;
1516
1517   current_interface = save;
1518   gfc_add_interface (prog_unit);
1519
1520   pop_state ();
1521   goto loop;
1522
1523 done:
1524   if (!seen_body)
1525     gfc_error ("INTERFACE block at %C is empty");
1526
1527   pop_state ();
1528 }
1529
1530
1531 /* Parse a set of specification statements.  Returns the statement
1532    that doesn't fit.  */
1533
1534 static gfc_statement
1535 parse_spec (gfc_statement st)
1536 {
1537   st_state ss;
1538
1539   verify_st_order (&ss, ST_NONE);
1540   if (st == ST_NONE)
1541     st = next_statement ();
1542
1543 loop:
1544   switch (st)
1545     {
1546     case ST_NONE:
1547       unexpected_eof ();
1548
1549     case ST_FORMAT:
1550     case ST_ENTRY:
1551     case ST_DATA:       /* Not allowed in interfaces */
1552       if (gfc_current_state () == COMP_INTERFACE)
1553         break;
1554
1555       /* Fall through */
1556
1557     case ST_USE:
1558     case ST_IMPLICIT_NONE:
1559     case ST_IMPLICIT:
1560     case ST_PARAMETER:
1561     case ST_PUBLIC:
1562     case ST_PRIVATE:
1563     case ST_DERIVED_DECL:
1564     case_decl:
1565       if (verify_st_order (&ss, st) == FAILURE)
1566         {
1567           reject_statement ();
1568           st = next_statement ();
1569           goto loop;
1570         }
1571
1572       switch (st)
1573         {
1574         case ST_INTERFACE:
1575           parse_interface ();
1576           break;
1577
1578         case ST_DERIVED_DECL:
1579           parse_derived ();
1580           break;
1581
1582         case ST_PUBLIC:
1583         case ST_PRIVATE:
1584           if (gfc_current_state () != COMP_MODULE)
1585             {
1586               gfc_error ("%s statement must appear in a MODULE",
1587                          gfc_ascii_statement (st));
1588               break;
1589             }
1590
1591           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
1592             {
1593               gfc_error ("%s statement at %C follows another accessibility "
1594                          "specification", gfc_ascii_statement (st));
1595               break;
1596             }
1597
1598           gfc_current_ns->default_access = (st == ST_PUBLIC)
1599             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
1600
1601           break;
1602
1603         default:
1604           break;
1605         }
1606
1607       accept_statement (st);
1608       st = next_statement ();
1609       goto loop;
1610
1611     default:
1612       break;
1613     }
1614
1615   return st;
1616 }
1617
1618
1619 /* Parse a WHERE block, (not a simple WHERE statement).  */
1620
1621 static void
1622 parse_where_block (void)
1623 {
1624   int seen_empty_else;
1625   gfc_code *top, *d;
1626   gfc_state_data s;
1627   gfc_statement st;
1628
1629   accept_statement (ST_WHERE_BLOCK);
1630   top = gfc_state_stack->tail;
1631
1632   push_state (&s, COMP_WHERE, gfc_new_block);
1633
1634   d = add_statement ();
1635   d->expr = top->expr;
1636   d->op = EXEC_WHERE;
1637
1638   top->expr = NULL;
1639   top->block = d;
1640
1641   seen_empty_else = 0;
1642
1643   do
1644     {
1645       st = next_statement ();
1646       switch (st)
1647         {
1648         case ST_NONE:
1649           unexpected_eof ();
1650
1651         case ST_WHERE_BLOCK:
1652           parse_where_block ();
1653           /* Fall through */
1654
1655         case ST_ASSIGNMENT:
1656         case ST_WHERE:
1657           accept_statement (st);
1658           break;
1659
1660         case ST_ELSEWHERE:
1661           if (seen_empty_else)
1662             {
1663               gfc_error
1664                 ("ELSEWHERE statement at %C follows previous unmasked "
1665                  "ELSEWHERE");
1666               break;
1667             }
1668
1669           if (new_st.expr == NULL)
1670             seen_empty_else = 1;
1671
1672           d = new_level (gfc_state_stack->head);
1673           d->op = EXEC_WHERE;
1674           d->expr = new_st.expr;
1675
1676           accept_statement (st);
1677
1678           break;
1679
1680         case ST_END_WHERE:
1681           accept_statement (st);
1682           break;
1683
1684         default:
1685           gfc_error ("Unexpected %s statement in WHERE block at %C",
1686                      gfc_ascii_statement (st));
1687           reject_statement ();
1688           break;
1689         }
1690
1691     }
1692   while (st != ST_END_WHERE);
1693
1694   pop_state ();
1695 }
1696
1697
1698 /* Parse a FORALL block (not a simple FORALL statement).  */
1699
1700 static void
1701 parse_forall_block (void)
1702 {
1703   gfc_code *top, *d;
1704   gfc_state_data s;
1705   gfc_statement st;
1706
1707   accept_statement (ST_FORALL_BLOCK);
1708   top = gfc_state_stack->tail;
1709
1710   push_state (&s, COMP_FORALL, gfc_new_block);
1711
1712   d = add_statement ();
1713   d->op = EXEC_FORALL;
1714   top->block = d;
1715
1716   do
1717     {
1718       st = next_statement ();
1719       switch (st)
1720         {
1721
1722         case ST_ASSIGNMENT:
1723         case ST_POINTER_ASSIGNMENT:
1724         case ST_WHERE:
1725         case ST_FORALL:
1726           accept_statement (st);
1727           break;
1728
1729         case ST_WHERE_BLOCK:
1730           parse_where_block ();
1731           break;
1732
1733         case ST_FORALL_BLOCK:
1734           parse_forall_block ();
1735           break;
1736
1737         case ST_END_FORALL:
1738           accept_statement (st);
1739           break;
1740
1741         case ST_NONE:
1742           unexpected_eof ();
1743
1744         default:
1745           gfc_error ("Unexpected %s statement in FORALL block at %C",
1746                      gfc_ascii_statement (st));
1747
1748           reject_statement ();
1749           break;
1750         }
1751     }
1752   while (st != ST_END_FORALL);
1753
1754   pop_state ();
1755 }
1756
1757
1758 static gfc_statement parse_executable (gfc_statement);
1759
1760 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
1761
1762 static void
1763 parse_if_block (void)
1764 {
1765   gfc_code *top, *d;
1766   gfc_statement st;
1767   locus else_locus;
1768   gfc_state_data s;
1769   int seen_else;
1770
1771   seen_else = 0;
1772   accept_statement (ST_IF_BLOCK);
1773
1774   top = gfc_state_stack->tail;
1775   push_state (&s, COMP_IF, gfc_new_block);
1776
1777   new_st.op = EXEC_IF;
1778   d = add_statement ();
1779
1780   d->expr = top->expr;
1781   top->expr = NULL;
1782   top->block = d;
1783
1784   do
1785     {
1786       st = parse_executable (ST_NONE);
1787
1788       switch (st)
1789         {
1790         case ST_NONE:
1791           unexpected_eof ();
1792
1793         case ST_ELSEIF:
1794           if (seen_else)
1795             {
1796               gfc_error
1797                 ("ELSE IF statement at %C cannot follow ELSE statement at %L",
1798                  &else_locus);
1799
1800               reject_statement ();
1801               break;
1802             }
1803
1804           d = new_level (gfc_state_stack->head);
1805           d->op = EXEC_IF;
1806           d->expr = new_st.expr;
1807
1808           accept_statement (st);
1809
1810           break;
1811
1812         case ST_ELSE:
1813           if (seen_else)
1814             {
1815               gfc_error ("Duplicate ELSE statements at %L and %C",
1816                          &else_locus);
1817               reject_statement ();
1818               break;
1819             }
1820
1821           seen_else = 1;
1822           else_locus = *gfc_current_locus ();
1823
1824           d = new_level (gfc_state_stack->head);
1825           d->op = EXEC_IF;
1826
1827           accept_statement (st);
1828
1829           break;
1830
1831         case ST_ENDIF:
1832           break;
1833
1834         default:
1835           unexpected_statement (st);
1836           break;
1837         }
1838     }
1839   while (st != ST_ENDIF);
1840
1841   pop_state ();
1842   accept_statement (st);
1843 }
1844
1845
1846 /* Parse a SELECT block.  */
1847
1848 static void
1849 parse_select_block (void)
1850 {
1851   gfc_statement st;
1852   gfc_code *cp;
1853   gfc_state_data s;
1854
1855   accept_statement (ST_SELECT_CASE);
1856
1857   cp = gfc_state_stack->tail;
1858   push_state (&s, COMP_SELECT, gfc_new_block);
1859
1860   /* Make sure that the next statement is a CASE or END SELECT.  */
1861   for (;;)
1862     {
1863       st = next_statement ();
1864       if (st == ST_NONE)
1865         unexpected_eof ();
1866       if (st == ST_END_SELECT)
1867         {
1868           /* Empty SELECT CASE is OK.  */
1869           accept_statement (st);
1870           pop_state ();
1871           return;
1872         }
1873       if (st == ST_CASE)
1874         break;
1875
1876       gfc_error
1877         ("Expected a CASE or END SELECT statement following SELECT CASE "
1878          "at %C");
1879
1880       reject_statement ();
1881     }
1882
1883   /* At this point, we're got a nonempty select block.  */
1884   cp = new_level (cp);
1885   *cp = new_st;
1886
1887   accept_statement (st);
1888
1889   do
1890     {
1891       st = parse_executable (ST_NONE);
1892       switch (st)
1893         {
1894         case ST_NONE:
1895           unexpected_eof ();
1896
1897         case ST_CASE:
1898           cp = new_level (gfc_state_stack->head);
1899           *cp = new_st;
1900           gfc_clear_new_st ();
1901
1902           accept_statement (st);
1903           /* Fall through */
1904
1905         case ST_END_SELECT:
1906           break;
1907
1908         /* Can't have an executable statement because of
1909            parse_executable().  */
1910         default:
1911           unexpected_statement (st);
1912           break;
1913         }
1914     }
1915   while (st != ST_END_SELECT);
1916
1917   pop_state ();
1918   accept_statement (st);
1919 }
1920
1921
1922 /* Checks to see if the current statement label closes an enddo.
1923    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
1924    an error) if it incorrectly closes an ENDDO.  */
1925
1926 static int
1927 check_do_closure (void)
1928 {
1929   gfc_state_data *p;
1930
1931   if (gfc_statement_label == NULL)
1932     return 0;
1933
1934   for (p = gfc_state_stack; p; p = p->previous)
1935     if (p->state == COMP_DO)
1936       break;
1937
1938   if (p == NULL)
1939     return 0;           /* No loops to close */
1940
1941   if (p->ext.end_do_label == gfc_statement_label)
1942     {
1943
1944       if (p == gfc_state_stack)
1945         return 1;
1946
1947       gfc_error
1948         ("End of nonblock DO statement at %C is within another block");
1949       return 2;
1950     }
1951
1952   /* At this point, the label doesn't terminate the innermost loop.
1953      Make sure it doesn't terminate another one.  */
1954   for (; p; p = p->previous)
1955     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
1956       {
1957         gfc_error ("End of nonblock DO statement at %C is interwoven "
1958                    "with another DO loop");
1959         return 2;
1960       }
1961
1962   return 0;
1963 }
1964
1965
1966 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
1967    handled inside of parse_executable(), because they aren't really
1968    loop statements.  */
1969
1970 static void
1971 parse_do_block (void)
1972 {
1973   gfc_statement st;
1974   gfc_code *top;
1975   gfc_state_data s;
1976
1977   s.ext.end_do_label = new_st.label;
1978
1979   accept_statement (ST_DO);
1980
1981   top = gfc_state_stack->tail;
1982   push_state (&s, COMP_DO, gfc_new_block);
1983
1984   top->block = new_level (top);
1985   top->block->op = EXEC_DO;
1986
1987 loop:
1988   st = parse_executable (ST_NONE);
1989
1990   switch (st)
1991     {
1992     case ST_NONE:
1993       unexpected_eof ();
1994
1995     case ST_ENDDO:
1996       if (s.ext.end_do_label != NULL
1997           && s.ext.end_do_label != gfc_statement_label)
1998         gfc_error_now
1999           ("Statement label in ENDDO at %C doesn't match DO label");
2000       /* Fall through */
2001
2002     case ST_IMPLIED_ENDDO:
2003       break;
2004
2005     default:
2006       unexpected_statement (st);
2007       goto loop;
2008     }
2009
2010   pop_state ();
2011   accept_statement (st);
2012 }
2013
2014
2015 /* Accept a series of executable statements.  We return the first
2016    statement that doesn't fit to the caller.  Any block statements are
2017    passed on to the correct handler, which usually passes the buck
2018    right back here.  */
2019
2020 static gfc_statement
2021 parse_executable (gfc_statement st)
2022 {
2023   int close_flag;
2024
2025   if (st == ST_NONE)
2026     st = next_statement ();
2027
2028   for (;; st = next_statement ())
2029     {
2030
2031       close_flag = check_do_closure ();
2032       if (close_flag)
2033         switch (st)
2034           {
2035           case ST_GOTO:
2036           case ST_END_PROGRAM:
2037           case ST_RETURN:
2038           case ST_EXIT:
2039           case ST_END_FUNCTION:
2040           case ST_CYCLE:
2041           case ST_PAUSE:
2042           case ST_STOP:
2043           case ST_END_SUBROUTINE:
2044
2045           case ST_DO:
2046           case ST_FORALL:
2047           case ST_WHERE:
2048           case ST_SELECT_CASE:
2049             gfc_error
2050               ("%s statement at %C cannot terminate a non-block DO loop",
2051                gfc_ascii_statement (st));
2052             break;
2053
2054           default:
2055             break;
2056           }
2057
2058       switch (st)
2059         {
2060         case ST_NONE:
2061           unexpected_eof ();
2062
2063         case ST_FORMAT:
2064         case ST_DATA:
2065         case ST_ENTRY:
2066         case_executable:
2067           accept_statement (st);
2068           if (close_flag == 1)
2069             return ST_IMPLIED_ENDDO;
2070           continue;
2071
2072         case ST_IF_BLOCK:
2073           parse_if_block ();
2074           continue;
2075
2076         case ST_SELECT_CASE:
2077           parse_select_block ();
2078           continue;
2079
2080         case ST_DO:
2081           parse_do_block ();
2082           if (check_do_closure () == 1)
2083             return ST_IMPLIED_ENDDO;
2084           continue;
2085
2086         case ST_WHERE_BLOCK:
2087           parse_where_block ();
2088           continue;
2089
2090         case ST_FORALL_BLOCK:
2091           parse_forall_block ();
2092           continue;
2093
2094         default:
2095           break;
2096         }
2097
2098       break;
2099     }
2100
2101   return st;
2102 }
2103
2104
2105 /* Parse a series of contained program units.  */
2106
2107 static void parse_progunit (gfc_statement);
2108
2109
2110 /* Fix the symbols for sibling functions.  These are incorrectly added to
2111    the child namespace as the parser didn't know about this procedure.  */
2112
2113 static void
2114 gfc_fixup_sibling_symbols (gfc_symbol * sym, gfc_namespace * siblings)
2115 {
2116   gfc_namespace *ns;
2117   gfc_symtree *st;
2118   gfc_symbol *old_sym;
2119
2120   for (ns = siblings; ns; ns = ns->sibling)
2121     {
2122       gfc_find_sym_tree (sym->name, ns, 0, &st);
2123       if (!st)
2124         continue;
2125
2126       old_sym = st->n.sym;
2127       if (old_sym->attr.flavor == FL_PROCEDURE && old_sym->ns == ns
2128           && ! old_sym->attr.contained)
2129         {
2130           /* Replace it with the symbol from the parent namespace.  */
2131           st->n.sym = sym;
2132           sym->refs++;
2133
2134           /* Free the old (local) symbol.  */
2135           old_sym->refs--;
2136           if (old_sym->refs == 0)
2137             gfc_free_symbol (old_sym);
2138         }
2139
2140       /* Do the same for any contined procedures.  */
2141       gfc_fixup_sibling_symbols (sym, ns->contained);
2142     }
2143 }
2144
2145 static void
2146 parse_contained (int module)
2147 {
2148   gfc_namespace *ns, *parent_ns;
2149   gfc_state_data s1, s2;
2150   gfc_statement st;
2151   gfc_symbol *sym;
2152
2153   push_state (&s1, COMP_CONTAINS, NULL);
2154   parent_ns = gfc_current_ns;
2155
2156   do
2157     {
2158       gfc_current_ns = gfc_get_namespace (parent_ns);
2159
2160       gfc_current_ns->sibling = parent_ns->contained;
2161       parent_ns->contained = gfc_current_ns;
2162
2163       st = next_statement ();
2164
2165       switch (st)
2166         {
2167         case ST_NONE:
2168           unexpected_eof ();
2169
2170         case ST_FUNCTION:
2171         case ST_SUBROUTINE:
2172           accept_statement (st);
2173
2174           push_state (&s2,
2175                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2176                       gfc_new_block);
2177
2178           /* For internal procedures, create/update the symbol in the
2179            * parent namespace */
2180
2181           if (!module)
2182             {
2183               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2184                 gfc_error
2185                   ("Contained procedure '%s' at %C is already ambiguous",
2186                    gfc_new_block->name);
2187               else
2188                 {
2189                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
2190                                          &gfc_new_block->declared_at) ==
2191                       SUCCESS)
2192                     {
2193                       if (st == ST_FUNCTION)
2194                         gfc_add_function (&sym->attr,
2195                                           &gfc_new_block->declared_at);
2196                       else
2197                         gfc_add_subroutine (&sym->attr,
2198                                             &gfc_new_block->declared_at);
2199                     }
2200                 }
2201
2202               gfc_commit_symbols ();
2203             }
2204           else
2205             sym = gfc_new_block;
2206
2207           /* Mark this as a contained function, so it isn't replaced
2208              by other module functions.  */
2209           sym->attr.contained = 1;
2210
2211           /* Fix up any sibling functions that refer to this one.  */
2212           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2213
2214           parse_progunit (ST_NONE);
2215
2216           gfc_current_ns->code = s2.head;
2217           gfc_current_ns = parent_ns;
2218
2219           pop_state ();
2220           break;
2221
2222         /* These statements are associated with the end of the host
2223            unit.  */
2224         case ST_END_FUNCTION:
2225         case ST_END_MODULE:
2226         case ST_END_PROGRAM:
2227         case ST_END_SUBROUTINE:
2228           accept_statement (st);
2229           break;
2230
2231         default:
2232           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2233                      gfc_ascii_statement (st));
2234           reject_statement ();
2235           break;
2236         }
2237     }
2238   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
2239          && st != ST_END_MODULE && st != ST_END_PROGRAM);
2240
2241   /* The first namespace in the list is guaranteed to not have
2242      anything (worthwhile) in it.  */
2243
2244   gfc_current_ns = parent_ns;
2245
2246   ns = gfc_current_ns->contained;
2247   gfc_current_ns->contained = ns->sibling;
2248   gfc_free_namespace (ns);
2249
2250   pop_state ();
2251 }
2252
2253
2254 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
2255
2256 static void
2257 parse_progunit (gfc_statement st)
2258 {
2259   gfc_state_data *p;
2260   int n;
2261
2262   st = parse_spec (st);
2263   switch (st)
2264     {
2265     case ST_NONE:
2266       unexpected_eof ();
2267
2268     case ST_CONTAINS:
2269       goto contains;
2270
2271     case_end:
2272       accept_statement (st);
2273       goto done;
2274
2275     default:
2276       break;
2277     }
2278
2279 loop:
2280   for (;;)
2281     {
2282       st = parse_executable (st);
2283
2284       switch (st)
2285         {
2286         case ST_NONE:
2287           unexpected_eof ();
2288
2289         case ST_CONTAINS:
2290           goto contains;
2291
2292         case_end:
2293           accept_statement (st);
2294           goto done;
2295
2296         default:
2297           break;
2298         }
2299
2300       unexpected_statement (st);
2301       reject_statement ();
2302       st = next_statement ();
2303     }
2304
2305 contains:
2306   n = 0;
2307
2308   for (p = gfc_state_stack; p; p = p->previous)
2309     if (p->state == COMP_CONTAINS)
2310       n++;
2311
2312   if (gfc_find_state (COMP_MODULE) == SUCCESS)
2313     n--;
2314
2315   if (n > 0)
2316     {
2317       gfc_error ("CONTAINS statement at %C is already in a contained "
2318                  "program unit");
2319       st = next_statement ();
2320       goto loop;
2321     }
2322
2323   parse_contained (0);
2324
2325 done:
2326   gfc_current_ns->code = gfc_state_stack->head;
2327 }
2328
2329
2330 /* Parse a block data program unit.  */
2331
2332 static void
2333 parse_block_data (void)
2334 {
2335   gfc_statement st;
2336
2337   st = parse_spec (ST_NONE);
2338
2339   while (st != ST_END_BLOCK_DATA)
2340     {
2341       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
2342                  gfc_ascii_statement (st));
2343       reject_statement ();
2344       st = next_statement ();
2345     }
2346 }
2347
2348
2349 /* Parse a module subprogram.  */
2350
2351 static void
2352 parse_module (void)
2353 {
2354   gfc_statement st;
2355
2356   st = parse_spec (ST_NONE);
2357
2358 loop:
2359   switch (st)
2360     {
2361     case ST_NONE:
2362       unexpected_eof ();
2363
2364     case ST_CONTAINS:
2365       parse_contained (1);
2366       break;
2367
2368     case ST_END_MODULE:
2369       accept_statement (st);
2370       break;
2371
2372     default:
2373       gfc_error ("Unexpected %s statement in MODULE at %C",
2374                  gfc_ascii_statement (st));
2375
2376       reject_statement ();
2377       st = next_statement ();
2378       goto loop;
2379     }
2380 }
2381
2382
2383 /* Top level parser.  */
2384
2385 try
2386 gfc_parse_file (void)
2387 {
2388   int seen_program, errors_before, errors;
2389   gfc_state_data top, s;
2390   gfc_statement st;
2391   locus prog_locus;
2392
2393   top.state = COMP_NONE;
2394   top.sym = NULL;
2395   top.previous = NULL;
2396   top.head = top.tail = NULL;
2397
2398   gfc_state_stack = &top;
2399
2400   gfc_clear_new_st ();
2401
2402   gfc_statement_label = NULL;
2403
2404   if (setjmp (eof))
2405     return FAILURE;     /* Come here on unexpected EOF */
2406
2407   seen_program = 0;
2408
2409 loop:
2410   gfc_init_2 ();
2411   st = next_statement ();
2412   switch (st)
2413     {
2414     case ST_NONE:
2415       gfc_done_2 ();
2416       goto done;
2417
2418     case ST_PROGRAM:
2419       if (seen_program)
2420         goto duplicate_main;
2421       seen_program = 1;
2422       prog_locus = *gfc_current_locus ();
2423
2424       push_state (&s, COMP_PROGRAM, gfc_new_block);
2425       accept_statement (st);
2426       parse_progunit (ST_NONE);
2427       break;
2428
2429     case ST_SUBROUTINE:
2430       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
2431       accept_statement (st);
2432       parse_progunit (ST_NONE);
2433       break;
2434
2435     case ST_FUNCTION:
2436       push_state (&s, COMP_FUNCTION, gfc_new_block);
2437       accept_statement (st);
2438       parse_progunit (ST_NONE);
2439       break;
2440
2441     case ST_BLOCK_DATA:
2442       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
2443       accept_statement (st);
2444       parse_block_data ();
2445       break;
2446
2447     case ST_MODULE:
2448       push_state (&s, COMP_MODULE, gfc_new_block);
2449       accept_statement (st);
2450
2451       gfc_get_errors (NULL, &errors_before);
2452       parse_module ();
2453       break;
2454
2455     /* Anything else starts a nameless main program block.  */
2456     default:
2457       if (seen_program)
2458         goto duplicate_main;
2459       seen_program = 1;
2460       prog_locus = *gfc_current_locus ();
2461
2462       push_state (&s, COMP_PROGRAM, gfc_new_block);
2463       parse_progunit (st);
2464       break;
2465     }
2466
2467   gfc_current_ns->code = s.head;
2468
2469   gfc_resolve (gfc_current_ns);
2470
2471   /* Dump the parse tree if requested.  */
2472   if (gfc_option.verbose)
2473     gfc_show_namespace (gfc_current_ns);
2474
2475   gfc_get_errors (NULL, &errors);
2476   if (s.state == COMP_MODULE)
2477     {
2478       gfc_dump_module (s.sym->name, errors_before == errors);
2479       if (errors == 0 && ! gfc_option.flag_no_backend)
2480         gfc_generate_module_code (gfc_current_ns);
2481     }
2482   else
2483     {
2484       if (errors == 0 && ! gfc_option.flag_no_backend)
2485         gfc_generate_code (gfc_current_ns);
2486     }
2487
2488   pop_state ();
2489   gfc_done_2 ();
2490   goto loop;
2491
2492 done:
2493   return SUCCESS;
2494
2495 duplicate_main:
2496   /* If we see a duplicate main program, shut down.  If the second
2497      instance is an implied main program, ie data decls or executable
2498      statements, we're in for lots of errors.  */
2499   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
2500   reject_statement ();
2501   gfc_done_2 ();
2502   return SUCCESS;
2503 }