gcc/fortran/parse.c

   1 /* Main parser.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 3, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING3.  If not see
  20 <http://www.gnu.org/licenses/>.  */
  21
  22 #include "config.h"
  23 #include "system.h"
  24 #include <setjmp.h>
  25 #include "gfortran.h"
  26 #include "match.h"
  27 #include "parse.h"
  28 #include "debug.h"
  29
  30 /* Current statement label.  Zero means no statement label.  Because new_st
  31    can get wiped during statement matching, we have to keep it separate.  */
  32
  33 gfc_st_label *gfc_statement_label;
  34
  35 static locus label_locus;
  36 static jmp_buf eof_buf;
  37
  38 gfc_state_data *gfc_state_stack;
  39
  40 /* TODO: Re-order functions to kill these forward decls.  */
  41 static void check_statement_label (gfc_statement);
  42 static void undo_new_statement (void);
  43 static void reject_statement (void);
  44
  45
  46 /* A sort of half-matching function.  We try to match the word on the
  47    input with the passed string.  If this succeeds, we call the
  48    keyword-dependent matching function that will match the rest of the
  49    statement.  For single keywords, the matching subroutine is
  50    gfc_match_eos().  */
  51
  52 static match
  53 match_word (const char *str, match (*subr) (void), locus *old_locus)
  54 {
  55   match m;
  56
  57   if (str != NULL)
  58     {
  59       m = gfc_match (str);
  60       if (m != MATCH_YES)
  61         return m;
  62     }
  63
  64   m = (*subr) ();
  65
  66   if (m != MATCH_YES)
  67     {
  68       gfc_current_locus = *old_locus;
  69       reject_statement ();
  70     }
  71
  72   return m;
  73 }
  74
  75
  76 /* Figure out what the next statement is, (mostly) regardless of
  77    proper ordering.  The do...while(0) is there to prevent if/else
  78    ambiguity.  */
  79
  80 #define match(keyword, subr, st)                                \
  81     do {                                                        \
  82       if (match_word(keyword, subr, &old_locus) == MATCH_YES)   \
  83         return st;                                              \
  84       else                                                      \
  85         undo_new_statement ();                            \
  86     } while (0);
  87
  88
  89 /* This is a specialist version of decode_statement that is used
  90    for the specification statements in a function, whose
  91    characteristics are deferred into the specification statements.
  92    eg.:  INTEGER (king = mykind) foo ()
  93          USE mymodule, ONLY mykind.....
  94    The KIND parameter needs a return after USE or IMPORT, whereas
  95    derived type declarations can occur anywhere, up the executable
  96    block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
  97    out of the correct kind of specification statements.  */
  98 static gfc_statement
  99 decode_specification_statement (void)
 100 {
 101   gfc_statement st;
 102   locus old_locus;
 103   int c;
 104
 105   if (gfc_match_eos () == MATCH_YES)
 106     return ST_NONE;
 107
 108   old_locus = gfc_current_locus;
 109
 110   match ("import", gfc_match_import, ST_IMPORT);
 111   match ("use", gfc_match_use, ST_USE);
 112
 113   if (gfc_current_block ()->ts.type != BT_DERIVED)
 114     goto end_of_block;
 115
 116   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 117   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 118   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 119
 120   /* General statement matching: Instead of testing every possible
 121      statement, we eliminate most possibilities by peeking at the
 122      first character.  */
 123
 124   c = gfc_peek_char ();
 125
 126   switch (c)
 127     {
 128     case 'a':
 129       match ("abstract% interface", gfc_match_abstract_interface,
 130              ST_INTERFACE);
 131       break;
 132
 133     case 'b':
 134       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 135       break;
 136
 137     case 'c':
 138       break;
 139
 140     case 'd':
 141       match ("data", gfc_match_data, ST_DATA);
 142       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 143       break;
 144
 145     case 'e':
 146       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 147       match ("entry% ", gfc_match_entry, ST_ENTRY);
 148       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 149       match ("external", gfc_match_external, ST_ATTR_DECL);
 150       break;
 151
 152     case 'f':
 153       match ("format", gfc_match_format, ST_FORMAT);
 154       break;
 155
 156     case 'g':
 157       break;
 158
 159     case 'i':
 160       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 161       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 162       match ("interface", gfc_match_interface, ST_INTERFACE);
 163       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 164       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 165       break;
 166
 167     case 'm':
 168       break;
 169
 170     case 'n':
 171       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 172       break;
 173
 174     case 'o':
 175       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 176       break;
 177
 178     case 'p':
 179       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 180       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 181       if (gfc_match_private (&st) == MATCH_YES)
 182         return st;
 183       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 184       if (gfc_match_public (&st) == MATCH_YES)
 185         return st;
 186       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 187       break;
 188
 189     case 'r':
 190       break;
 191
 192     case 's':
 193       match ("save", gfc_match_save, ST_ATTR_DECL);
 194       break;
 195
 196     case 't':
 197       match ("target", gfc_match_target, ST_ATTR_DECL);
 198       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 199       break;
 200
 201     case 'u':
 202       break;
 203
 204     case 'v':
 205       match ("value", gfc_match_value, ST_ATTR_DECL);
 206       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 207       break;
 208
 209     case 'w':
 210       break;
 211     }
 212
 213   /* This is not a specification statement.  See if any of the matchers
 214      has stored an error message of some sort.  */
 215
 216 end_of_block:
 217   gfc_clear_error ();
 218   gfc_buffer_error (0);
 219   gfc_current_locus = old_locus;
 220
 221   return ST_GET_FCN_CHARACTERISTICS;
 222 }
 223
 224
 225 /* This is the primary 'decode_statement'.  */
 226 static gfc_statement
 227 decode_statement (void)
 228 {
 229   gfc_statement st;
 230   locus old_locus;
 231   match m;
 232   int c;
 233
 234 #ifdef GFC_DEBUG
 235   gfc_symbol_state ();
 236 #endif
 237
 238   gfc_clear_error ();   /* Clear any pending errors.  */
 239   gfc_clear_warning (); /* Clear any pending warnings.  */
 240
 241   gfc_matching_function = false;
 242
 243   if (gfc_match_eos () == MATCH_YES)
 244     return ST_NONE;
 245
 246   if (gfc_current_state () == COMP_FUNCTION
 247         && gfc_current_block ()->result->ts.kind == -1)
 248     return decode_specification_statement ();
 249
 250   old_locus = gfc_current_locus;
 251
 252   /* Try matching a data declaration or function declaration. The
 253       input "REALFUNCTIONA(N)" can mean several things in different
 254       contexts, so it (and its relatives) get special treatment.  */
 255
 256   if (gfc_current_state () == COMP_NONE
 257       || gfc_current_state () == COMP_INTERFACE
 258       || gfc_current_state () == COMP_CONTAINS)
 259     {
 260       gfc_matching_function = true;
 261       m = gfc_match_function_decl ();
 262       if (m == MATCH_YES)
 263         return ST_FUNCTION;
 264       else if (m == MATCH_ERROR)
 265         reject_statement ();
 266       else
 267         gfc_undo_symbols ();
 268       gfc_current_locus = old_locus;
 269     }
 270   gfc_matching_function = false;
 271
 272
 273   /* Match statements whose error messages are meant to be overwritten
 274      by something better.  */
 275
 276   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
 277   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
 278   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 279
 280   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 281   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 282
 283   /* Try to match a subroutine statement, which has the same optional
 284      prefixes that functions can have.  */
 285
 286   if (gfc_match_subroutine () == MATCH_YES)
 287     return ST_SUBROUTINE;
 288   gfc_undo_symbols ();
 289   gfc_current_locus = old_locus;
 290
 291   /* Check for the IF, DO, SELECT, WHERE and FORALL statements, which
 292      might begin with a block label.  The match functions for these
 293      statements are unusual in that their keyword is not seen before
 294      the matcher is called.  */
 295
 296   if (gfc_match_if (&st) == MATCH_YES)
 297     return st;
 298   gfc_undo_symbols ();
 299   gfc_current_locus = old_locus;
 300
 301   if (gfc_match_where (&st) == MATCH_YES)
 302     return st;
 303   gfc_undo_symbols ();
 304   gfc_current_locus = old_locus;
 305
 306   if (gfc_match_forall (&st) == MATCH_YES)
 307     return st;
 308   gfc_undo_symbols ();
 309   gfc_current_locus = old_locus;
 310
 311   match (NULL, gfc_match_do, ST_DO);
 312   match (NULL, gfc_match_select, ST_SELECT_CASE);
 313
 314   /* General statement matching: Instead of testing every possible
 315      statement, we eliminate most possibilities by peeking at the
 316      first character.  */
 317
 318   c = gfc_peek_char ();
 319
 320   switch (c)
 321     {
 322     case 'a':
 323       match ("abstract% interface", gfc_match_abstract_interface,
 324              ST_INTERFACE);
 325       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
 326       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
 327       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
 328       break;
 329
 330     case 'b':
 331       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
 332       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
 333       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 334       break;
 335
 336     case 'c':
 337       match ("call", gfc_match_call, ST_CALL);
 338       match ("close", gfc_match_close, ST_CLOSE);
 339       match ("continue", gfc_match_continue, ST_CONTINUE);
 340       match ("cycle", gfc_match_cycle, ST_CYCLE);
 341       match ("case", gfc_match_case, ST_CASE);
 342       match ("common", gfc_match_common, ST_COMMON);
 343       match ("contains", gfc_match_eos, ST_CONTAINS);
 344       break;
 345
 346     case 'd':
 347       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
 348       match ("data", gfc_match_data, ST_DATA);
 349       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 350       break;
 351
 352     case 'e':
 353       match ("end file", gfc_match_endfile, ST_END_FILE);
 354       match ("exit", gfc_match_exit, ST_EXIT);
 355       match ("else", gfc_match_else, ST_ELSE);
 356       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
 357       match ("else if", gfc_match_elseif, ST_ELSEIF);
 358       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 359
 360       if (gfc_match_end (&st) == MATCH_YES)
 361         return st;
 362
 363       match ("entry% ", gfc_match_entry, ST_ENTRY);
 364       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 365       match ("external", gfc_match_external, ST_ATTR_DECL);
 366       break;
 367
 368     case 'f':
 369       match ("flush", gfc_match_flush, ST_FLUSH);
 370       match ("format", gfc_match_format, ST_FORMAT);
 371       break;
 372
 373     case 'g':
 374       match ("go to", gfc_match_goto, ST_GOTO);
 375       break;
 376
 377     case 'i':
 378       match ("inquire", gfc_match_inquire, ST_INQUIRE);
 379       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 380       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 381       match ("import", gfc_match_import, ST_IMPORT);
 382       match ("interface", gfc_match_interface, ST_INTERFACE);
 383       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 384       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 385       break;
 386
 387     case 'm':
 388       match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
 389       match ("module", gfc_match_module, ST_MODULE);
 390       break;
 391
 392     case 'n':
 393       match ("nullify", gfc_match_nullify, ST_NULLIFY);
 394       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 395       break;
 396
 397     case 'o':
 398       match ("open", gfc_match_open, ST_OPEN);
 399       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 400       break;
 401
 402     case 'p':
 403       match ("print", gfc_match_print, ST_WRITE);
 404       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 405       match ("pause", gfc_match_pause, ST_PAUSE);
 406       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 407       if (gfc_match_private (&st) == MATCH_YES)
 408         return st;
 409       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 410       match ("program", gfc_match_program, ST_PROGRAM);
 411       if (gfc_match_public (&st) == MATCH_YES)
 412         return st;
 413       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 414       break;
 415
 416     case 'r':
 417       match ("read", gfc_match_read, ST_READ);
 418       match ("return", gfc_match_return, ST_RETURN);
 419       match ("rewind", gfc_match_rewind, ST_REWIND);
 420       break;
 421
 422     case 's':
 423       match ("sequence", gfc_match_eos, ST_SEQUENCE);
 424       match ("stop", gfc_match_stop, ST_STOP);
 425       match ("save", gfc_match_save, ST_ATTR_DECL);
 426       break;
 427
 428     case 't':
 429       match ("target", gfc_match_target, ST_ATTR_DECL);
 430       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 431       break;
 432
 433     case 'u':
 434       match ("use", gfc_match_use, ST_USE);
 435       break;
 436
 437     case 'v':
 438       match ("value", gfc_match_value, ST_ATTR_DECL);
 439       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 440       break;
 441
 442     case 'w':
 443       match ("wait", gfc_match_wait, ST_WAIT);
 444       match ("write", gfc_match_write, ST_WRITE);
 445       break;
 446     }
 447
 448   /* All else has failed, so give up.  See if any of the matchers has
 449      stored an error message of some sort.  */
 450
 451   if (gfc_error_check () == 0)
 452     gfc_error_now ("Unclassifiable statement at %C");
 453
 454   reject_statement ();
 455
 456   gfc_error_recovery ();
 457
 458   return ST_NONE;
 459 }
 460
 461 static gfc_statement
 462 decode_omp_directive (void)
 463 {
 464   locus old_locus;
 465   int c;
 466
 467 #ifdef GFC_DEBUG
 468   gfc_symbol_state ();
 469 #endif
 470
 471   gfc_clear_error ();   /* Clear any pending errors.  */
 472   gfc_clear_warning (); /* Clear any pending warnings.  */
 473
 474   if (gfc_pure (NULL))
 475     {
 476       gfc_error_now ("OpenMP directives at %C may not appear in PURE "
 477                      "or ELEMENTAL procedures");
 478       gfc_error_recovery ();
 479       return ST_NONE;
 480     }
 481
 482   old_locus = gfc_current_locus;
 483
 484   /* General OpenMP directive matching: Instead of testing every possible
 485      statement, we eliminate most possibilities by peeking at the
 486      first character.  */
 487
 488   c = gfc_peek_char ();
 489
 490   switch (c)
 491     {
 492     case 'a':
 493       match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
 494       break;
 495     case 'b':
 496       match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
 497       break;
 498     case 'c':
 499       match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
 500       break;
 501     case 'd':
 502       match ("do", gfc_match_omp_do, ST_OMP_DO);
 503       break;
 504     case 'e':
 505       match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
 506       match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
 507       match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
 508       match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
 509       match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
 510       match ("end parallel sections", gfc_match_omp_eos,
 511              ST_OMP_END_PARALLEL_SECTIONS);
 512       match ("end parallel workshare", gfc_match_omp_eos,
 513              ST_OMP_END_PARALLEL_WORKSHARE);
 514       match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
 515       match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
 516       match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
 517       match ("end workshare", gfc_match_omp_end_nowait,
 518              ST_OMP_END_WORKSHARE);
 519       break;
 520     case 'f':
 521       match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
 522       break;
 523     case 'm':
 524       match ("master", gfc_match_omp_master, ST_OMP_MASTER);
 525       break;
 526     case 'o':
 527       match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
 528       break;
 529     case 'p':
 530       match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
 531       match ("parallel sections", gfc_match_omp_parallel_sections,
 532              ST_OMP_PARALLEL_SECTIONS);
 533       match ("parallel workshare", gfc_match_omp_parallel_workshare,
 534              ST_OMP_PARALLEL_WORKSHARE);
 535       match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
 536       break;
 537     case 's':
 538       match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
 539       match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
 540       match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
 541       break;
 542     case 't':
 543       match ("threadprivate", gfc_match_omp_threadprivate,
 544              ST_OMP_THREADPRIVATE);
 545     case 'w':
 546       match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
 547       break;
 548     }
 549
 550   /* All else has failed, so give up.  See if any of the matchers has
 551      stored an error message of some sort.  */
 552
 553   if (gfc_error_check () == 0)
 554     gfc_error_now ("Unclassifiable OpenMP directive at %C");
 555
 556   reject_statement ();
 557
 558   gfc_error_recovery ();
 559
 560   return ST_NONE;
 561 }
 562
 563 #undef match
 564
 565
 566 /* Get the next statement in free form source.  */
 567
 568 static gfc_statement
 569 next_free (void)
 570 {
 571   match m;
 572   int c, d, cnt, at_bol;
 573
 574   at_bol = gfc_at_bol ();
 575   gfc_gobble_whitespace ();
 576
 577   c = gfc_peek_char ();
 578
 579   if (ISDIGIT (c))
 580     {
 581       /* Found a statement label?  */
 582       m = gfc_match_st_label (&gfc_statement_label);
 583
 584       d = gfc_peek_char ();
 585       if (m != MATCH_YES || !gfc_is_whitespace (d))
 586         {
 587           gfc_match_small_literal_int (&c, &cnt);
 588
 589           if (cnt > 5)
 590             gfc_error_now ("Too many digits in statement label at %C");
 591
 592           if (c == 0)
 593             gfc_error_now ("Zero is not a valid statement label at %C");
 594
 595           do
 596             c = gfc_next_char ();
 597           while (ISDIGIT(c));
 598
 599           if (!gfc_is_whitespace (c))
 600             gfc_error_now ("Non-numeric character in statement label at %C");
 601
 602           return ST_NONE;
 603         }
 604       else
 605         {
 606           label_locus = gfc_current_locus;
 607
 608           gfc_gobble_whitespace ();
 609
 610           if (at_bol && gfc_peek_char () == ';')
 611             {
 612               gfc_error_now ("Semicolon at %C needs to be preceded by "
 613                              "statement");
 614               gfc_next_char (); /* Eat up the semicolon.  */
 615               return ST_NONE;
 616             }
 617
 618           if (gfc_match_eos () == MATCH_YES)
 619             {
 620               gfc_warning_now ("Ignoring statement label in empty statement "
 621                                "at %C");
 622               gfc_free_st_label (gfc_statement_label);
 623               gfc_statement_label = NULL;
 624               return ST_NONE;
 625             }
 626         }
 627     }
 628   else if (c == '!')
 629     {
 630       /* Comments have already been skipped by the time we get here,
 631          except for OpenMP directives.  */
 632       if (gfc_option.flag_openmp)
 633         {
 634           int i;
 635
 636           c = gfc_next_char ();
 637           for (i = 0; i < 5; i++, c = gfc_next_char ())
 638             gcc_assert (c == "!$omp"[i]);
 639
 640           gcc_assert (c == ' ');
 641           gfc_gobble_whitespace ();
 642           return decode_omp_directive ();
 643         }
 644     }
 645
 646   if (at_bol && c == ';')
 647     {
 648       gfc_error_now ("Semicolon at %C needs to be preceded by statement");
 649       gfc_next_char (); /* Eat up the semicolon.  */
 650       return ST_NONE;
 651     }
 652
 653   return decode_statement ();
 654 }
 655
 656
 657 /* Get the next statement in fixed-form source.  */
 658
 659 static gfc_statement
 660 next_fixed (void)
 661 {
 662   int label, digit_flag, i;
 663   locus loc;
 664   char c;
 665
 666   if (!gfc_at_bol ())
 667     return decode_statement ();
 668
 669   /* Skip past the current label field, parsing a statement label if
 670      one is there.  This is a weird number parser, since the number is
 671      contained within five columns and can have any kind of embedded
 672      spaces.  We also check for characters that make the rest of the
 673      line a comment.  */
 674
 675   label = 0;
 676   digit_flag = 0;
 677
 678   for (i = 0; i < 5; i++)
 679     {
 680       c = gfc_next_char_literal (0);
 681
 682       switch (c)
 683         {
 684         case ' ':
 685           break;
 686
 687         case '0':
 688         case '1':
 689         case '2':
 690         case '3':
 691         case '4':
 692         case '5':
 693         case '6':
 694         case '7':
 695         case '8':
 696         case '9':
 697           label = label * 10 + c - '0';
 698           label_locus = gfc_current_locus;
 699           digit_flag = 1;
 700           break;
 701
 702           /* Comments have already been skipped by the time we get
 703              here, except for OpenMP directives.  */
 704         case '*':
 705           if (gfc_option.flag_openmp)
 706             {
 707               for (i = 0; i < 5; i++, c = gfc_next_char_literal (0))
 708                 gcc_assert (TOLOWER (c) == "*$omp"[i]);
 709
 710               if (c != ' ' && c != '0')
 711                 {
 712                   gfc_buffer_error (0);
 713                   gfc_error ("Bad continuation line at %C");
 714                   return ST_NONE;
 715                 }
 716
 717               return decode_omp_directive ();
 718             }
 719           /* FALLTHROUGH */
 720
 721           /* Comments have already been skipped by the time we get
 722              here so don't bother checking for them.  */
 723
 724         default:
 725           gfc_buffer_error (0);
 726           gfc_error ("Non-numeric character in statement label at %C");
 727           return ST_NONE;
 728         }
 729     }
 730
 731   if (digit_flag)
 732     {
 733       if (label == 0)
 734         gfc_warning_now ("Zero is not a valid statement label at %C");
 735       else
 736         {
 737           /* We've found a valid statement label.  */
 738           gfc_statement_label = gfc_get_st_label (label);
 739         }
 740     }
 741
 742   /* Since this line starts a statement, it cannot be a continuation
 743      of a previous statement.  If we see something here besides a
 744      space or zero, it must be a bad continuation line.  */
 745
 746   c = gfc_next_char_literal (0);
 747   if (c == '\n')
 748     goto blank_line;
 749
 750   if (c != ' ' && c != '0')
 751     {
 752       gfc_buffer_error (0);
 753       gfc_error ("Bad continuation line at %C");
 754       return ST_NONE;
 755     }
 756
 757   /* Now that we've taken care of the statement label columns, we have
 758      to make sure that the first nonblank character is not a '!'.  If
 759      it is, the rest of the line is a comment.  */
 760
 761   do
 762     {
 763       loc = gfc_current_locus;
 764       c = gfc_next_char_literal (0);
 765     }
 766   while (gfc_is_whitespace (c));
 767
 768   if (c == '!')
 769     goto blank_line;
 770   gfc_current_locus = loc;
 771
 772   if (c == ';')
 773     {
 774       gfc_error_now ("Semicolon at %C needs to be preceded by statement");
 775       return ST_NONE;
 776     }
 777
 778   if (gfc_match_eos () == MATCH_YES)
 779     goto blank_line;
 780
 781   /* At this point, we've got a nonblank statement to parse.  */
 782   return decode_statement ();
 783
 784 blank_line:
 785   if (digit_flag)
 786     gfc_warning ("Ignoring statement label in empty statement at %C");
 787   gfc_advance_line ();
 788   return ST_NONE;
 789 }
 790
 791
 792 /* Return the next non-ST_NONE statement to the caller.  We also worry
 793    about including files and the ends of include files at this stage.  */
 794
 795 static gfc_statement
 796 next_statement (void)
 797 {
 798   gfc_statement st;
 799   locus old_locus;
 800   gfc_new_block = NULL;
 801
 802   for (;;)
 803     {
 804       gfc_statement_label = NULL;
 805       gfc_buffer_error (1);
 806
 807       if (gfc_at_eol ())
 808         {
 809           if ((gfc_option.warn_line_truncation || gfc_current_form == FORM_FREE)
 810               && gfc_current_locus.lb
 811               && gfc_current_locus.lb->truncated)
 812             gfc_warning_now ("Line truncated at %C");
 813
 814           gfc_advance_line ();
 815         }
 816
 817       gfc_skip_comments ();
 818
 819       if (gfc_at_end ())
 820         {
 821           st = ST_NONE;
 822           break;
 823         }
 824
 825       if (gfc_define_undef_line ())
 826         continue;
 827
 828       old_locus = gfc_current_locus;
 829
 830       st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
 831
 832       if (st != ST_NONE)
 833         break;
 834     }
 835
 836   gfc_buffer_error (0);
 837
 838   if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
 839     {
 840       gfc_free_st_label (gfc_statement_label);
 841       gfc_statement_label = NULL;
 842       gfc_current_locus = old_locus;
 843     }
 844
 845   if (st != ST_NONE)
 846     check_statement_label (st);
 847
 848   return st;
 849 }
 850
 851
 852 /****************************** Parser ***********************************/
 853
 854 /* The parser subroutines are of type 'try' that fail if the file ends
 855    unexpectedly.  */
 856
 857 /* Macros that expand to case-labels for various classes of
 858    statements.  Start with executable statements that directly do
 859    things.  */
 860
 861 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
 862   case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
 863   case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
 864   case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
 865   case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
 866   case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
 867   case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
 868   case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
 869   case ST_OMP_BARRIER
 870
 871 /* Statements that mark other executable statements.  */
 872
 873 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: case ST_IF_BLOCK: \
 874   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_OMP_PARALLEL: \
 875   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
 876   case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
 877   case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
 878   case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE
 879
 880 /* Declaration statements */
 881
 882 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
 883   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
 884   case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
 885   case ST_PROCEDURE
 886
 887 /* Block end statements.  Errors associated with interchanging these
 888    are detected in gfc_match_end().  */
 889
 890 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
 891                  case ST_END_PROGRAM: case ST_END_SUBROUTINE
 892
 893
 894 /* Push a new state onto the stack.  */
 895
 896 static void
 897 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
 898 {
 899   p->state = new_state;
 900   p->previous = gfc_state_stack;
 901   p->sym = sym;
 902   p->head = p->tail = NULL;
 903   p->do_variable = NULL;
 904   gfc_state_stack = p;
 905 }
 906
 907
 908 /* Pop the current state.  */
 909 static void
 910 pop_state (void)
 911 {
 912   gfc_state_stack = gfc_state_stack->previous;
 913 }
 914
 915
 916 /* Try to find the given state in the state stack.  */
 917
 918 try
 919 gfc_find_state (gfc_compile_state state)
 920 {
 921   gfc_state_data *p;
 922
 923   for (p = gfc_state_stack; p; p = p->previous)
 924     if (p->state == state)
 925       break;
 926
 927   return (p == NULL) ? FAILURE : SUCCESS;
 928 }
 929
 930
 931 /* Starts a new level in the statement list.  */
 932
 933 static gfc_code *
 934 new_level (gfc_code *q)
 935 {
 936   gfc_code *p;
 937
 938   p = q->block = gfc_get_code ();
 939
 940   gfc_state_stack->head = gfc_state_stack->tail = p;
 941
 942   return p;
 943 }
 944
 945
 946 /* Add the current new_st code structure and adds it to the current
 947    program unit.  As a side-effect, it zeroes the new_st.  */
 948
 949 static gfc_code *
 950 add_statement (void)
 951 {
 952   gfc_code *p;
 953
 954   p = gfc_get_code ();
 955   *p = new_st;
 956
 957   p->loc = gfc_current_locus;
 958
 959   if (gfc_state_stack->head == NULL)
 960     gfc_state_stack->head = p;
 961   else
 962     gfc_state_stack->tail->next = p;
 963
 964   while (p->next != NULL)
 965     p = p->next;
 966
 967   gfc_state_stack->tail = p;
 968
 969   gfc_clear_new_st ();
 970
 971   return p;
 972 }
 973
 974
 975 /* Frees everything associated with the current statement.  */
 976
 977 static void
 978 undo_new_statement (void)
 979 {
 980   gfc_free_statements (new_st.block);
 981   gfc_free_statements (new_st.next);
 982   gfc_free_statement (&new_st);
 983   gfc_clear_new_st ();
 984 }
 985
 986
 987 /* If the current statement has a statement label, make sure that it
 988    is allowed to, or should have one.  */
 989
 990 static void
 991 check_statement_label (gfc_statement st)
 992 {
 993   gfc_sl_type type;
 994
 995   if (gfc_statement_label == NULL)
 996     {
 997       if (st == ST_FORMAT)
 998         gfc_error ("FORMAT statement at %L does not have a statement label",
 999                    &new_st.loc);
1000       return;
1001     }
1002
1003   switch (st)
1004     {
1005     case ST_END_PROGRAM:
1006     case ST_END_FUNCTION:
1007     case ST_END_SUBROUTINE:
1008     case ST_ENDDO:
1009     case ST_ENDIF:
1010     case ST_END_SELECT:
1011     case_executable:
1012     case_exec_markers:
1013       type = ST_LABEL_TARGET;
1014       break;
1015
1016     case ST_FORMAT:
1017       type = ST_LABEL_FORMAT;
1018       break;
1019
1020       /* Statement labels are not restricted from appearing on a
1021          particular line.  However, there are plenty of situations
1022          where the resulting label can't be referenced.  */
1023
1024     default:
1025       type = ST_LABEL_BAD_TARGET;
1026       break;
1027     }
1028
1029   gfc_define_st_label (gfc_statement_label, type, &label_locus);
1030
1031   new_st.here = gfc_statement_label;
1032 }
1033
1034
1035 /* Figures out what the enclosing program unit is.  This will be a
1036    function, subroutine, program, block data or module.  */
1037
1038 gfc_state_data *
1039 gfc_enclosing_unit (gfc_compile_state * result)
1040 {
1041   gfc_state_data *p;
1042
1043   for (p = gfc_state_stack; p; p = p->previous)
1044     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1045         || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
1046         || p->state == COMP_PROGRAM)
1047       {
1048
1049         if (result != NULL)
1050           *result = p->state;
1051         return p;
1052       }
1053
1054   if (result != NULL)
1055     *result = COMP_PROGRAM;
1056   return NULL;
1057 }
1058
1059
1060 /* Translate a statement enum to a string.  */
1061
1062 const char *
1063 gfc_ascii_statement (gfc_statement st)
1064 {
1065   const char *p;
1066
1067   switch (st)
1068     {
1069     case ST_ARITHMETIC_IF:
1070       p = _("arithmetic IF");
1071       break;
1072     case ST_ALLOCATE:
1073       p = "ALLOCATE";
1074       break;
1075     case ST_ATTR_DECL:
1076       p = _("attribute declaration");
1077       break;
1078     case ST_BACKSPACE:
1079       p = "BACKSPACE";
1080       break;
1081     case ST_BLOCK_DATA:
1082       p = "BLOCK DATA";
1083       break;
1084     case ST_CALL:
1085       p = "CALL";
1086       break;
1087     case ST_CASE:
1088       p = "CASE";
1089       break;
1090     case ST_CLOSE:
1091       p = "CLOSE";
1092       break;
1093     case ST_COMMON:
1094       p = "COMMON";
1095       break;
1096     case ST_CONTINUE:
1097       p = "CONTINUE";
1098       break;
1099     case ST_CONTAINS:
1100       p = "CONTAINS";
1101       break;
1102     case ST_CYCLE:
1103       p = "CYCLE";
1104       break;
1105     case ST_DATA_DECL:
1106       p = _("data declaration");
1107       break;
1108     case ST_DATA:
1109       p = "DATA";
1110       break;
1111     case ST_DEALLOCATE:
1112       p = "DEALLOCATE";
1113       break;
1114     case ST_DERIVED_DECL:
1115       p = _("derived type declaration");
1116       break;
1117     case ST_DO:
1118       p = "DO";
1119       break;
1120     case ST_ELSE:
1121       p = "ELSE";
1122       break;
1123     case ST_ELSEIF:
1124       p = "ELSE IF";
1125       break;
1126     case ST_ELSEWHERE:
1127       p = "ELSEWHERE";
1128       break;
1129     case ST_END_BLOCK_DATA:
1130       p = "END BLOCK DATA";
1131       break;
1132     case ST_ENDDO:
1133       p = "END DO";
1134       break;
1135     case ST_END_FILE:
1136       p = "END FILE";
1137       break;
1138     case ST_END_FORALL:
1139       p = "END FORALL";
1140       break;
1141     case ST_END_FUNCTION:
1142       p = "END FUNCTION";
1143       break;
1144     case ST_ENDIF:
1145       p = "END IF";
1146       break;
1147     case ST_END_INTERFACE:
1148       p = "END INTERFACE";
1149       break;
1150     case ST_END_MODULE:
1151       p = "END MODULE";
1152       break;
1153     case ST_END_PROGRAM:
1154       p = "END PROGRAM";
1155       break;
1156     case ST_END_SELECT:
1157       p = "END SELECT";
1158       break;
1159     case ST_END_SUBROUTINE:
1160       p = "END SUBROUTINE";
1161       break;
1162     case ST_END_WHERE:
1163       p = "END WHERE";
1164       break;
1165     case ST_END_TYPE:
1166       p = "END TYPE";
1167       break;
1168     case ST_ENTRY:
1169       p = "ENTRY";
1170       break;
1171     case ST_EQUIVALENCE:
1172       p = "EQUIVALENCE";
1173       break;
1174     case ST_EXIT:
1175       p = "EXIT";
1176       break;
1177     case ST_FLUSH:
1178       p = "FLUSH";
1179       break;
1180     case ST_FORALL_BLOCK:       /* Fall through */
1181     case ST_FORALL:
1182       p = "FORALL";
1183       break;
1184     case ST_FORMAT:
1185       p = "FORMAT";
1186       break;
1187     case ST_FUNCTION:
1188       p = "FUNCTION";
1189       break;
1190     case ST_GOTO:
1191       p = "GOTO";
1192       break;
1193     case ST_IF_BLOCK:
1194       p = _("block IF");
1195       break;
1196     case ST_IMPLICIT:
1197       p = "IMPLICIT";
1198       break;
1199     case ST_IMPLICIT_NONE:
1200       p = "IMPLICIT NONE";
1201       break;
1202     case ST_IMPLIED_ENDDO:
1203       p = _("implied END DO");
1204       break;
1205     case ST_IMPORT:
1206       p = "IMPORT";
1207       break;
1208     case ST_INQUIRE:
1209       p = "INQUIRE";
1210       break;
1211     case ST_INTERFACE:
1212       p = "INTERFACE";
1213       break;
1214     case ST_PARAMETER:
1215       p = "PARAMETER";
1216       break;
1217     case ST_PRIVATE:
1218       p = "PRIVATE";
1219       break;
1220     case ST_PUBLIC:
1221       p = "PUBLIC";
1222       break;
1223     case ST_MODULE:
1224       p = "MODULE";
1225       break;
1226     case ST_PAUSE:
1227       p = "PAUSE";
1228       break;
1229     case ST_MODULE_PROC:
1230       p = "MODULE PROCEDURE";
1231       break;
1232     case ST_NAMELIST:
1233       p = "NAMELIST";
1234       break;
1235     case ST_NULLIFY:
1236       p = "NULLIFY";
1237       break;
1238     case ST_OPEN:
1239       p = "OPEN";
1240       break;
1241     case ST_PROGRAM:
1242       p = "PROGRAM";
1243       break;
1244     case ST_PROCEDURE:
1245       p = "PROCEDURE";
1246       break;
1247     case ST_READ:
1248       p = "READ";
1249       break;
1250     case ST_RETURN:
1251       p = "RETURN";
1252       break;
1253     case ST_REWIND:
1254       p = "REWIND";
1255       break;
1256     case ST_STOP:
1257       p = "STOP";
1258       break;
1259     case ST_SUBROUTINE:
1260       p = "SUBROUTINE";
1261       break;
1262     case ST_TYPE:
1263       p = "TYPE";
1264       break;
1265     case ST_USE:
1266       p = "USE";
1267       break;
1268     case ST_WHERE_BLOCK:        /* Fall through */
1269     case ST_WHERE:
1270       p = "WHERE";
1271       break;
1272     case ST_WAIT:
1273       p = "WAIT";
1274       break;
1275     case ST_WRITE:
1276       p = "WRITE";
1277       break;
1278     case ST_ASSIGNMENT:
1279       p = _("assignment");
1280       break;
1281     case ST_POINTER_ASSIGNMENT:
1282       p = _("pointer assignment");
1283       break;
1284     case ST_SELECT_CASE:
1285       p = "SELECT CASE";
1286       break;
1287     case ST_SEQUENCE:
1288       p = "SEQUENCE";
1289       break;
1290     case ST_SIMPLE_IF:
1291       p = _("simple IF");
1292       break;
1293     case ST_STATEMENT_FUNCTION:
1294       p = "STATEMENT FUNCTION";
1295       break;
1296     case ST_LABEL_ASSIGNMENT:
1297       p = "LABEL ASSIGNMENT";
1298       break;
1299     case ST_ENUM:
1300       p = "ENUM DEFINITION";
1301       break;
1302     case ST_ENUMERATOR:
1303       p = "ENUMERATOR DEFINITION";
1304       break;
1305     case ST_END_ENUM:
1306       p = "END ENUM";
1307       break;
1308     case ST_OMP_ATOMIC:
1309       p = "!$OMP ATOMIC";
1310       break;
1311     case ST_OMP_BARRIER:
1312       p = "!$OMP BARRIER";
1313       break;
1314     case ST_OMP_CRITICAL:
1315       p = "!$OMP CRITICAL";
1316       break;
1317     case ST_OMP_DO:
1318       p = "!$OMP DO";
1319       break;
1320     case ST_OMP_END_CRITICAL:
1321       p = "!$OMP END CRITICAL";
1322       break;
1323     case ST_OMP_END_DO:
1324       p = "!$OMP END DO";
1325       break;
1326     case ST_OMP_END_MASTER:
1327       p = "!$OMP END MASTER";
1328       break;
1329     case ST_OMP_END_ORDERED:
1330       p = "!$OMP END ORDERED";
1331       break;
1332     case ST_OMP_END_PARALLEL:
1333       p = "!$OMP END PARALLEL";
1334       break;
1335     case ST_OMP_END_PARALLEL_DO:
1336       p = "!$OMP END PARALLEL DO";
1337       break;
1338     case ST_OMP_END_PARALLEL_SECTIONS:
1339       p = "!$OMP END PARALLEL SECTIONS";
1340       break;
1341     case ST_OMP_END_PARALLEL_WORKSHARE:
1342       p = "!$OMP END PARALLEL WORKSHARE";
1343       break;
1344     case ST_OMP_END_SECTIONS:
1345       p = "!$OMP END SECTIONS";
1346       break;
1347     case ST_OMP_END_SINGLE:
1348       p = "!$OMP END SINGLE";
1349       break;
1350     case ST_OMP_END_WORKSHARE:
1351       p = "!$OMP END WORKSHARE";
1352       break;
1353     case ST_OMP_FLUSH:
1354       p = "!$OMP FLUSH";
1355       break;
1356     case ST_OMP_MASTER:
1357       p = "!$OMP MASTER";
1358       break;
1359     case ST_OMP_ORDERED:
1360       p = "!$OMP ORDERED";
1361       break;
1362     case ST_OMP_PARALLEL:
1363       p = "!$OMP PARALLEL";
1364       break;
1365     case ST_OMP_PARALLEL_DO:
1366       p = "!$OMP PARALLEL DO";
1367       break;
1368     case ST_OMP_PARALLEL_SECTIONS:
1369       p = "!$OMP PARALLEL SECTIONS";
1370       break;
1371     case ST_OMP_PARALLEL_WORKSHARE:
1372       p = "!$OMP PARALLEL WORKSHARE";
1373       break;
1374     case ST_OMP_SECTIONS:
1375       p = "!$OMP SECTIONS";
1376       break;
1377     case ST_OMP_SECTION:
1378       p = "!$OMP SECTION";
1379       break;
1380     case ST_OMP_SINGLE:
1381       p = "!$OMP SINGLE";
1382       break;
1383     case ST_OMP_THREADPRIVATE:
1384       p = "!$OMP THREADPRIVATE";
1385       break;
1386     case ST_OMP_WORKSHARE:
1387       p = "!$OMP WORKSHARE";
1388       break;
1389     default:
1390       gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1391     }
1392
1393   return p;
1394 }
1395
1396
1397 /* Create a symbol for the main program and assign it to ns->proc_name.  */
1398
1399 static void
1400 main_program_symbol (gfc_namespace *ns, const char *name)
1401 {
1402   gfc_symbol *main_program;
1403   symbol_attribute attr;
1404
1405   gfc_get_symbol (name, ns, &main_program);
1406   gfc_clear_attr (&attr);
1407   attr.flavor = FL_PROGRAM;
1408   attr.proc = PROC_UNKNOWN;
1409   attr.subroutine = 1;
1410   attr.access = ACCESS_PUBLIC;
1411   attr.is_main_program = 1;
1412   main_program->attr = attr;
1413   main_program->declared_at = gfc_current_locus;
1414   ns->proc_name = main_program;
1415   gfc_commit_symbols ();
1416 }
1417
1418
1419 /* Do whatever is necessary to accept the last statement.  */
1420
1421 static void
1422 accept_statement (gfc_statement st)
1423 {
1424   switch (st)
1425     {
1426     case ST_USE:
1427       gfc_use_module ();
1428       break;
1429
1430     case ST_IMPLICIT_NONE:
1431       gfc_set_implicit_none ();
1432       break;
1433
1434     case ST_IMPLICIT:
1435       break;
1436
1437     case ST_FUNCTION:
1438     case ST_SUBROUTINE:
1439     case ST_MODULE:
1440       gfc_current_ns->proc_name = gfc_new_block;
1441       break;
1442
1443       /* If the statement is the end of a block, lay down a special code
1444          that allows a branch to the end of the block from within the
1445          construct.  */
1446
1447     case ST_ENDIF:
1448     case ST_END_SELECT:
1449       if (gfc_statement_label != NULL)
1450         {
1451           new_st.op = EXEC_NOP;
1452           add_statement ();
1453         }
1454
1455       break;
1456
1457       /* The end-of-program unit statements do not get the special
1458          marker and require a statement of some sort if they are a
1459          branch target.  */
1460
1461     case ST_END_PROGRAM:
1462     case ST_END_FUNCTION:
1463     case ST_END_SUBROUTINE:
1464       if (gfc_statement_label != NULL)
1465         {
1466           new_st.op = EXEC_RETURN;
1467           add_statement ();
1468         }
1469
1470       break;
1471
1472     case ST_ENTRY:
1473     case_executable:
1474     case_exec_markers:
1475       add_statement ();
1476       break;
1477
1478     default:
1479       break;
1480     }
1481
1482   gfc_commit_symbols ();
1483   gfc_warning_check ();
1484   gfc_clear_new_st ();
1485 }
1486
1487
1488 /* Undo anything tentative that has been built for the current
1489    statement.  */
1490
1491 static void
1492 reject_statement (void)
1493 {
1494   gfc_new_block = NULL;
1495   gfc_undo_symbols ();
1496   gfc_clear_warning ();
1497   undo_new_statement ();
1498 }
1499
1500
1501 /* Generic complaint about an out of order statement.  We also do
1502    whatever is necessary to clean up.  */
1503
1504 static void
1505 unexpected_statement (gfc_statement st)
1506 {
1507   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1508
1509   reject_statement ();
1510 }
1511
1512
1513 /* Given the next statement seen by the matcher, make sure that it is
1514    in proper order with the last.  This subroutine is initialized by
1515    calling it with an argument of ST_NONE.  If there is a problem, we
1516    issue an error and return FAILURE.  Otherwise we return SUCCESS.
1517
1518    Individual parsers need to verify that the statements seen are
1519    valid before calling here, ie ENTRY statements are not allowed in
1520    INTERFACE blocks.  The following diagram is taken from the standard:
1521
1522             +---------------------------------------+
1523             | program  subroutine  function  module |
1524             +---------------------------------------+
1525             |            use               |
1526             +---------------------------------------+
1527             |            import         |
1528             +---------------------------------------+
1529             |   |       implicit none    |
1530             |   +-----------+------------------+
1531             |   | parameter |  implicit |
1532             |   +-----------+------------------+
1533             | format |     |  derived type    |
1534             | entry  | parameter |  interface       |
1535             |   |   data    |  specification   |
1536             |   |          |  statement func  |
1537             |   +-----------+------------------+
1538             |   |   data    |    executable    |
1539             +--------+-----------+------------------+
1540             |           contains               |
1541             +---------------------------------------+
1542             |      internal module/subprogram       |
1543             +---------------------------------------+
1544             |              end           |
1545             +---------------------------------------+
1546
1547 */
1548
1549 typedef struct
1550 {
1551   enum
1552   { ORDER_START, ORDER_USE, ORDER_IMPORT, ORDER_IMPLICIT_NONE,
1553     ORDER_IMPLICIT, ORDER_SPEC, ORDER_EXEC
1554   }
1555   state;
1556   gfc_statement last_statement;
1557   locus where;
1558 }
1559 st_state;
1560
1561 static try
1562 verify_st_order (st_state *p, gfc_statement st)
1563 {
1564
1565   switch (st)
1566     {
1567     case ST_NONE:
1568       p->state = ORDER_START;
1569       break;
1570
1571     case ST_USE:
1572       if (p->state > ORDER_USE)
1573         goto order;
1574       p->state = ORDER_USE;
1575       break;
1576
1577     case ST_IMPORT:
1578       if (p->state > ORDER_IMPORT)
1579         goto order;
1580       p->state = ORDER_IMPORT;
1581       break;
1582
1583     case ST_IMPLICIT_NONE:
1584       if (p->state > ORDER_IMPLICIT_NONE)
1585         goto order;
1586
1587       /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1588          statement disqualifies a USE but not an IMPLICIT NONE.
1589          Duplicate IMPLICIT NONEs are caught when the implicit types
1590          are set.  */
1591
1592       p->state = ORDER_IMPLICIT_NONE;
1593       break;
1594
1595     case ST_IMPLICIT:
1596       if (p->state > ORDER_IMPLICIT)
1597         goto order;
1598       p->state = ORDER_IMPLICIT;
1599       break;
1600
1601     case ST_FORMAT:
1602     case ST_ENTRY:
1603       if (p->state < ORDER_IMPLICIT_NONE)
1604         p->state = ORDER_IMPLICIT_NONE;
1605       break;
1606
1607     case ST_PARAMETER:
1608       if (p->state >= ORDER_EXEC)
1609         goto order;
1610       if (p->state < ORDER_IMPLICIT)
1611         p->state = ORDER_IMPLICIT;
1612       break;
1613
1614     case ST_DATA:
1615       if (p->state < ORDER_SPEC)
1616         p->state = ORDER_SPEC;
1617       break;
1618
1619     case ST_PUBLIC:
1620     case ST_PRIVATE:
1621     case ST_DERIVED_DECL:
1622     case_decl:
1623       if (p->state >= ORDER_EXEC)
1624         goto order;
1625       if (p->state < ORDER_SPEC)
1626         p->state = ORDER_SPEC;
1627       break;
1628
1629     case_executable:
1630     case_exec_markers:
1631       if (p->state < ORDER_EXEC)
1632         p->state = ORDER_EXEC;
1633       break;
1634
1635     default:
1636       gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1637                           gfc_ascii_statement (st));
1638     }
1639
1640   /* All is well, record the statement in case we need it next time.  */
1641   p->where = gfc_current_locus;
1642   p->last_statement = st;
1643   return SUCCESS;
1644
1645 order:
1646   gfc_error ("%s statement at %C cannot follow %s statement at %L",
1647              gfc_ascii_statement (st),
1648              gfc_ascii_statement (p->last_statement), &p->where);
1649
1650   return FAILURE;
1651 }
1652
1653
1654 /* Handle an unexpected end of file.  This is a show-stopper...  */
1655
1656 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1657
1658 static void
1659 unexpected_eof (void)
1660 {
1661   gfc_state_data *p;
1662
1663   gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1664
1665   /* Memory cleanup.  Move to "second to last".  */
1666   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1667        p = p->previous);
1668
1669   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1670   gfc_done_2 ();
1671
1672   longjmp (eof_buf, 1);
1673 }
1674
1675
1676 /* Parse a derived type.  */
1677
1678 static void
1679 parse_derived (void)
1680 {
1681   int compiling_type, seen_private, seen_sequence, seen_component, error_flag;
1682   gfc_statement st;
1683   gfc_state_data s;
1684   gfc_symbol *derived_sym = NULL;
1685   gfc_symbol *sym;
1686   gfc_component *c;
1687
1688   error_flag = 0;
1689
1690   accept_statement (ST_DERIVED_DECL);
1691   push_state (&s, COMP_DERIVED, gfc_new_block);
1692
1693   gfc_new_block->component_access = ACCESS_PUBLIC;
1694   seen_private = 0;
1695   seen_sequence = 0;
1696   seen_component = 0;
1697
1698   compiling_type = 1;
1699
1700   while (compiling_type)
1701     {
1702       st = next_statement ();
1703       switch (st)
1704         {
1705         case ST_NONE:
1706           unexpected_eof ();
1707
1708         case ST_DATA_DECL:
1709         case ST_PROCEDURE:
1710           accept_statement (st);
1711           seen_component = 1;
1712           break;
1713
1714         case ST_END_TYPE:
1715           compiling_type = 0;
1716
1717           if (!seen_component
1718               && (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
1719                                  "definition at %C without components")
1720                   == FAILURE))
1721             error_flag = 1;
1722
1723           accept_statement (ST_END_TYPE);
1724           break;
1725
1726         case ST_PRIVATE:
1727           if (gfc_find_state (COMP_MODULE) == FAILURE)
1728             {
1729               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1730                          "a MODULE");
1731               error_flag = 1;
1732               break;
1733             }
1734
1735           if (seen_component)
1736             {
1737               gfc_error ("PRIVATE statement at %C must precede "
1738                          "structure components");
1739               error_flag = 1;
1740               break;
1741             }
1742
1743           if (seen_private)
1744             {
1745               gfc_error ("Duplicate PRIVATE statement at %C");
1746               error_flag = 1;
1747             }
1748
1749           s.sym->component_access = ACCESS_PRIVATE;
1750           accept_statement (ST_PRIVATE);
1751           seen_private = 1;
1752           break;
1753
1754         case ST_SEQUENCE:
1755           if (seen_component)
1756             {
1757               gfc_error ("SEQUENCE statement at %C must precede "
1758                          "structure components");
1759               error_flag = 1;
1760               break;
1761             }
1762
1763           if (gfc_current_block ()->attr.sequence)
1764             gfc_warning ("SEQUENCE attribute at %C already specified in "
1765                          "TYPE statement");
1766
1767           if (seen_sequence)
1768             {
1769               gfc_error ("Duplicate SEQUENCE statement at %C");
1770               error_flag = 1;
1771             }
1772
1773           seen_sequence = 1;
1774           gfc_add_sequence (&gfc_current_block ()->attr,
1775                             gfc_current_block ()->name, NULL);
1776           break;
1777
1778         default:
1779           unexpected_statement (st);
1780           break;
1781         }
1782     }
1783
1784   /* need to verify that all fields of the derived type are
1785    * interoperable with C if the type is declared to be bind(c)
1786    */
1787   derived_sym = gfc_current_block();
1788
1789   sym = gfc_current_block ();
1790   for (c = sym->components; c; c = c->next)
1791     {
1792       /* Look for allocatable components.  */
1793       if (c->allocatable
1794           || (c->ts.type == BT_DERIVED && c->ts.derived->attr.alloc_comp))
1795         {
1796           sym->attr.alloc_comp = 1;
1797           break;
1798         }
1799
1800       /* Look for pointer components.  */
1801       if (c->pointer
1802           || (c->ts.type == BT_DERIVED && c->ts.derived->attr.pointer_comp))
1803         {
1804           sym->attr.pointer_comp = 1;
1805           break;
1806         }
1807
1808       /* Look for private components.  */
1809       if (sym->component_access == ACCESS_PRIVATE
1810           || c->access == ACCESS_PRIVATE
1811           || (c->ts.type == BT_DERIVED && c->ts.derived->attr.private_comp))
1812         {
1813           sym->attr.private_comp = 1;
1814           break;
1815         }
1816     }
1817
1818   if (!seen_component)
1819     sym->attr.zero_comp = 1;
1820
1821   pop_state ();
1822 }
1823
1824
1825 /* Parse an ENUM.  */
1826
1827 static void
1828 parse_enum (void)
1829 {
1830   int error_flag;
1831   gfc_statement st;
1832   int compiling_enum;
1833   gfc_state_data s;
1834   int seen_enumerator = 0;
1835
1836   error_flag = 0;
1837
1838   push_state (&s, COMP_ENUM, gfc_new_block);
1839
1840   compiling_enum = 1;
1841
1842   while (compiling_enum)
1843     {
1844       st = next_statement ();
1845       switch (st)
1846         {
1847         case ST_NONE:
1848           unexpected_eof ();
1849           break;
1850
1851         case ST_ENUMERATOR:
1852           seen_enumerator = 1;
1853           accept_statement (st);
1854           break;
1855
1856         case ST_END_ENUM:
1857           compiling_enum = 0;
1858           if (!seen_enumerator)
1859             {
1860               gfc_error ("ENUM declaration at %C has no ENUMERATORS");
1861               error_flag = 1;
1862             }
1863           accept_statement (st);
1864           break;
1865
1866         default:
1867           gfc_free_enum_history ();
1868           unexpected_statement (st);
1869           break;
1870         }
1871     }
1872   pop_state ();
1873 }
1874
1875
1876 /* Parse an interface.  We must be able to deal with the possibility
1877    of recursive interfaces.  The parse_spec() subroutine is mutually
1878    recursive with parse_interface().  */
1879
1880 static gfc_statement parse_spec (gfc_statement);
1881
1882 static void
1883 parse_interface (void)
1884 {
1885   gfc_compile_state new_state, current_state;
1886   gfc_symbol *prog_unit, *sym;
1887   gfc_interface_info save;
1888   gfc_state_data s1, s2;
1889   gfc_statement st;
1890   locus proc_locus;
1891
1892   accept_statement (ST_INTERFACE);
1893
1894   current_interface.ns = gfc_current_ns;
1895   save = current_interface;
1896
1897   sym = (current_interface.type == INTERFACE_GENERIC
1898          || current_interface.type == INTERFACE_USER_OP)
1899         ? gfc_new_block : NULL;
1900
1901   push_state (&s1, COMP_INTERFACE, sym);
1902   current_state = COMP_NONE;
1903
1904 loop:
1905   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
1906
1907   st = next_statement ();
1908   switch (st)
1909     {
1910     case ST_NONE:
1911       unexpected_eof ();
1912
1913     case ST_SUBROUTINE:
1914       new_state = COMP_SUBROUTINE;
1915       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1916                                   gfc_new_block->formal, NULL);
1917       break;
1918
1919     case ST_FUNCTION:
1920       new_state = COMP_FUNCTION;
1921       gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
1922                                   gfc_new_block->formal, NULL);
1923       break;
1924
1925     case ST_PROCEDURE:
1926     case ST_MODULE_PROC:        /* The module procedure matcher makes
1927                                    sure the context is correct.  */
1928       accept_statement (st);
1929       gfc_free_namespace (gfc_current_ns);
1930       goto loop;
1931
1932     case ST_END_INTERFACE:
1933       gfc_free_namespace (gfc_current_ns);
1934       gfc_current_ns = current_interface.ns;
1935       goto done;
1936
1937     default:
1938       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
1939                  gfc_ascii_statement (st));
1940       reject_statement ();
1941       gfc_free_namespace (gfc_current_ns);
1942       goto loop;
1943     }
1944
1945
1946   /* Make sure that a generic interface has only subroutines or
1947      functions and that the generic name has the right attribute.  */
1948   if (current_interface.type == INTERFACE_GENERIC)
1949     {
1950       if (current_state == COMP_NONE)
1951         {
1952           if (new_state == COMP_FUNCTION)
1953             gfc_add_function (&sym->attr, sym->name, NULL);
1954           else if (new_state == COMP_SUBROUTINE)
1955             gfc_add_subroutine (&sym->attr, sym->name, NULL);
1956
1957           current_state = new_state;
1958         }
1959       else
1960         {
1961           if (new_state != current_state)
1962             {
1963               if (new_state == COMP_SUBROUTINE)
1964                 gfc_error ("SUBROUTINE at %C does not belong in a "
1965                            "generic function interface");
1966
1967               if (new_state == COMP_FUNCTION)
1968                 gfc_error ("FUNCTION at %C does not belong in a "
1969                            "generic subroutine interface");
1970             }
1971         }
1972     }
1973
1974   if (current_interface.type == INTERFACE_ABSTRACT)
1975     {
1976       gfc_new_block->attr.abstract = 1;
1977       if (gfc_is_intrinsic_typename (gfc_new_block->name))
1978         gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
1979                    "cannot be the same as an intrinsic type",
1980                    gfc_new_block->name);
1981     }
1982
1983   push_state (&s2, new_state, gfc_new_block);
1984   accept_statement (st);
1985   prog_unit = gfc_new_block;
1986   prog_unit->formal_ns = gfc_current_ns;
1987   proc_locus = gfc_current_locus;
1988
1989 decl:
1990   /* Read data declaration statements.  */
1991   st = parse_spec (ST_NONE);
1992
1993   /* Since the interface block does not permit an IMPLICIT statement,
1994      the default type for the function or the result must be taken
1995      from the formal namespace.  */
1996   if (new_state == COMP_FUNCTION)
1997     {
1998         if (prog_unit->result == prog_unit
1999               && prog_unit->ts.type == BT_UNKNOWN)
2000           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2001         else if (prog_unit->result != prog_unit
2002                    && prog_unit->result->ts.type == BT_UNKNOWN)
2003           gfc_set_default_type (prog_unit->result, 1,
2004                                 prog_unit->formal_ns);
2005     }
2006
2007   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2008     {
2009       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2010                  gfc_ascii_statement (st));
2011       reject_statement ();
2012       goto decl;
2013     }
2014
2015   current_interface = save;
2016   gfc_add_interface (prog_unit);
2017   pop_state ();
2018
2019   if (current_interface.ns
2020         && current_interface.ns->proc_name
2021         && strcmp (current_interface.ns->proc_name->name,
2022                    prog_unit->name) == 0)
2023     gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2024                "enclosing procedure", prog_unit->name, &proc_locus);
2025
2026   goto loop;
2027
2028 done:
2029   pop_state ();
2030 }
2031
2032
2033 /* Associate function characteristics by going back to the function
2034    declaration and rematching the prefix.  */
2035
2036 static match
2037 match_deferred_characteristics (gfc_typespec * ts)
2038 {
2039   locus loc;
2040   match m = MATCH_ERROR;
2041   char name[GFC_MAX_SYMBOL_LEN + 1];
2042
2043   loc = gfc_current_locus;
2044
2045   gfc_current_locus = gfc_current_block ()->declared_at;
2046
2047   gfc_clear_error ();
2048   gfc_buffer_error (1);
2049   m = gfc_match_prefix (ts);
2050   gfc_buffer_error (0);
2051
2052   if (ts->type == BT_DERIVED)
2053     {
2054       ts->kind = 0;
2055
2056       if (!ts->derived || !ts->derived->components)
2057         m = MATCH_ERROR;
2058     }
2059
2060   /* Only permit one go at the characteristic association.  */
2061   if (ts->kind == -1)
2062     ts->kind = 0;
2063
2064   /* Set the function locus correctly.  If we have not found the
2065      function name, there is an error.  */
2066   gfc_match ("function% %n", name);
2067   if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
2068     {
2069       gfc_current_block ()->declared_at = gfc_current_locus;
2070       gfc_commit_symbols ();
2071     }
2072   else
2073     gfc_error_check ();
2074
2075   gfc_current_locus =loc;
2076   return m;
2077 }
2078
2079
2080 /* Parse a set of specification statements.  Returns the statement
2081    that doesn't fit.  */
2082
2083 static gfc_statement
2084 parse_spec (gfc_statement st)
2085 {
2086   st_state ss;
2087   bool bad_characteristic = false;
2088   gfc_typespec *ts;
2089
2090   verify_st_order (&ss, ST_NONE);
2091   if (st == ST_NONE)
2092     st = next_statement ();
2093
2094 loop:
2095   switch (st)
2096     {
2097     case ST_NONE:
2098       unexpected_eof ();
2099
2100     case ST_FORMAT:
2101     case ST_ENTRY:
2102     case ST_DATA:       /* Not allowed in interfaces */
2103       if (gfc_current_state () == COMP_INTERFACE)
2104         break;
2105
2106       /* Fall through */
2107
2108     case ST_USE:
2109     case ST_IMPORT:
2110     case ST_IMPLICIT_NONE:
2111     case ST_IMPLICIT:
2112     case ST_PARAMETER:
2113     case ST_PUBLIC:
2114     case ST_PRIVATE:
2115     case ST_DERIVED_DECL:
2116     case_decl:
2117       if (verify_st_order (&ss, st) == FAILURE)
2118         {
2119           reject_statement ();
2120           st = next_statement ();
2121           goto loop;
2122         }
2123
2124       switch (st)
2125         {
2126         case ST_INTERFACE:
2127           parse_interface ();
2128           break;
2129
2130         case ST_DERIVED_DECL:
2131           parse_derived ();
2132           break;
2133
2134         case ST_PUBLIC:
2135         case ST_PRIVATE:
2136           if (gfc_current_state () != COMP_MODULE)
2137             {
2138               gfc_error ("%s statement must appear in a MODULE",
2139                          gfc_ascii_statement (st));
2140               break;
2141             }
2142
2143           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2144             {
2145               gfc_error ("%s statement at %C follows another accessibility "
2146                          "specification", gfc_ascii_statement (st));
2147               break;
2148             }
2149
2150           gfc_current_ns->default_access = (st == ST_PUBLIC)
2151             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2152
2153           break;
2154
2155         case ST_STATEMENT_FUNCTION:
2156           if (gfc_current_state () == COMP_MODULE)
2157             {
2158               unexpected_statement (st);
2159               break;
2160             }
2161
2162         default:
2163           break;
2164         }
2165
2166       accept_statement (st);
2167       st = next_statement ();
2168       goto loop;
2169
2170     case ST_ENUM:
2171       accept_statement (st);
2172       parse_enum();
2173       st = next_statement ();
2174       goto loop;
2175
2176     case ST_GET_FCN_CHARACTERISTICS:
2177       /* This statement triggers the association of a function's result
2178          characteristics.  */
2179       ts = &gfc_current_block ()->result->ts;
2180       if (match_deferred_characteristics (ts) != MATCH_YES)
2181         bad_characteristic = true;
2182
2183       st = next_statement ();
2184       goto loop;
2185
2186     default:
2187       break;
2188     }
2189
2190   /* If match_deferred_characteristics failed, then there is an error. */
2191   if (bad_characteristic)
2192     {
2193       ts = &gfc_current_block ()->result->ts;
2194       if (ts->type != BT_DERIVED)
2195         gfc_error ("Bad kind expression for function '%s' at %L",
2196                    gfc_current_block ()->name,
2197                    &gfc_current_block ()->declared_at);
2198       else
2199         gfc_error ("The type for function '%s' at %L is not accessible",
2200                    gfc_current_block ()->name,
2201                    &gfc_current_block ()->declared_at);
2202
2203       gfc_current_block ()->ts.kind = 0;
2204       /* Keep the derived type; if it's bad, it will be discovered later.  */
2205       if (!(ts->type == BT_DERIVED && ts->derived))
2206         ts->type = BT_UNKNOWN;
2207     }
2208
2209   return st;
2210 }
2211
2212
2213 /* Parse a WHERE block, (not a simple WHERE statement).  */
2214
2215 static void
2216 parse_where_block (void)
2217 {
2218   int seen_empty_else;
2219   gfc_code *top, *d;
2220   gfc_state_data s;
2221   gfc_statement st;
2222
2223   accept_statement (ST_WHERE_BLOCK);
2224   top = gfc_state_stack->tail;
2225
2226   push_state (&s, COMP_WHERE, gfc_new_block);
2227
2228   d = add_statement ();
2229   d->expr = top->expr;
2230   d->op = EXEC_WHERE;
2231
2232   top->expr = NULL;
2233   top->block = d;
2234
2235   seen_empty_else = 0;
2236
2237   do
2238     {
2239       st = next_statement ();
2240       switch (st)
2241         {
2242         case ST_NONE:
2243           unexpected_eof ();
2244
2245         case ST_WHERE_BLOCK:
2246           parse_where_block ();
2247           break;
2248
2249         case ST_ASSIGNMENT:
2250         case ST_WHERE:
2251           accept_statement (st);
2252           break;
2253
2254         case ST_ELSEWHERE:
2255           if (seen_empty_else)
2256             {
2257               gfc_error ("ELSEWHERE statement at %C follows previous "
2258                          "unmasked ELSEWHERE");
2259               break;
2260             }
2261
2262           if (new_st.expr == NULL)
2263             seen_empty_else = 1;
2264
2265           d = new_level (gfc_state_stack->head);
2266           d->op = EXEC_WHERE;
2267           d->expr = new_st.expr;
2268
2269           accept_statement (st);
2270
2271           break;
2272
2273         case ST_END_WHERE:
2274           accept_statement (st);
2275           break;
2276
2277         default:
2278           gfc_error ("Unexpected %s statement in WHERE block at %C",
2279                      gfc_ascii_statement (st));
2280           reject_statement ();
2281           break;
2282         }
2283     }
2284   while (st != ST_END_WHERE);
2285
2286   pop_state ();
2287 }
2288
2289
2290 /* Parse a FORALL block (not a simple FORALL statement).  */
2291
2292 static void
2293 parse_forall_block (void)
2294 {
2295   gfc_code *top, *d;
2296   gfc_state_data s;
2297   gfc_statement st;
2298
2299   accept_statement (ST_FORALL_BLOCK);
2300   top = gfc_state_stack->tail;
2301
2302   push_state (&s, COMP_FORALL, gfc_new_block);
2303
2304   d = add_statement ();
2305   d->op = EXEC_FORALL;
2306   top->block = d;
2307
2308   do
2309     {
2310       st = next_statement ();
2311       switch (st)
2312         {
2313
2314         case ST_ASSIGNMENT:
2315         case ST_POINTER_ASSIGNMENT:
2316         case ST_WHERE:
2317         case ST_FORALL:
2318           accept_statement (st);
2319           break;
2320
2321         case ST_WHERE_BLOCK:
2322           parse_where_block ();
2323           break;
2324
2325         case ST_FORALL_BLOCK:
2326           parse_forall_block ();
2327           break;
2328
2329         case ST_END_FORALL:
2330           accept_statement (st);
2331           break;
2332
2333         case ST_NONE:
2334           unexpected_eof ();
2335
2336         default:
2337           gfc_error ("Unexpected %s statement in FORALL block at %C",
2338                      gfc_ascii_statement (st));
2339
2340           reject_statement ();
2341           break;
2342         }
2343     }
2344   while (st != ST_END_FORALL);
2345
2346   pop_state ();
2347 }
2348
2349
2350 static gfc_statement parse_executable (gfc_statement);
2351
2352 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2353
2354 static void
2355 parse_if_block (void)
2356 {
2357   gfc_code *top, *d;
2358   gfc_statement st;
2359   locus else_locus;
2360   gfc_state_data s;
2361   int seen_else;
2362
2363   seen_else = 0;
2364   accept_statement (ST_IF_BLOCK);
2365
2366   top = gfc_state_stack->tail;
2367   push_state (&s, COMP_IF, gfc_new_block);
2368
2369   new_st.op = EXEC_IF;
2370   d = add_statement ();
2371
2372   d->expr = top->expr;
2373   top->expr = NULL;
2374   top->block = d;
2375
2376   do
2377     {
2378       st = parse_executable (ST_NONE);
2379
2380       switch (st)
2381         {
2382         case ST_NONE:
2383           unexpected_eof ();
2384
2385         case ST_ELSEIF:
2386           if (seen_else)
2387             {
2388               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2389                          "statement at %L", &else_locus);
2390
2391               reject_statement ();
2392               break;
2393             }
2394
2395           d = new_level (gfc_state_stack->head);
2396           d->op = EXEC_IF;
2397           d->expr = new_st.expr;
2398
2399           accept_statement (st);
2400
2401           break;
2402
2403         case ST_ELSE:
2404           if (seen_else)
2405             {
2406               gfc_error ("Duplicate ELSE statements at %L and %C",
2407                          &else_locus);
2408               reject_statement ();
2409               break;
2410             }
2411
2412           seen_else = 1;
2413           else_locus = gfc_current_locus;
2414
2415           d = new_level (gfc_state_stack->head);
2416           d->op = EXEC_IF;
2417
2418           accept_statement (st);
2419
2420           break;
2421
2422         case ST_ENDIF:
2423           break;
2424
2425         default:
2426           unexpected_statement (st);
2427           break;
2428         }
2429     }
2430   while (st != ST_ENDIF);
2431
2432   pop_state ();
2433   accept_statement (st);
2434 }
2435
2436
2437 /* Parse a SELECT block.  */
2438
2439 static void
2440 parse_select_block (void)
2441 {
2442   gfc_statement st;
2443   gfc_code *cp;
2444   gfc_state_data s;
2445
2446   accept_statement (ST_SELECT_CASE);
2447
2448   cp = gfc_state_stack->tail;
2449   push_state (&s, COMP_SELECT, gfc_new_block);
2450
2451   /* Make sure that the next statement is a CASE or END SELECT.  */
2452   for (;;)
2453     {
2454       st = next_statement ();
2455       if (st == ST_NONE)
2456         unexpected_eof ();
2457       if (st == ST_END_SELECT)
2458         {
2459           /* Empty SELECT CASE is OK.  */
2460           accept_statement (st);
2461           pop_state ();
2462           return;
2463         }
2464       if (st == ST_CASE)
2465         break;
2466
2467       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2468                  "CASE at %C");
2469
2470       reject_statement ();
2471     }
2472
2473   /* At this point, we're got a nonempty select block.  */
2474   cp = new_level (cp);
2475   *cp = new_st;
2476
2477   accept_statement (st);
2478
2479   do
2480     {
2481       st = parse_executable (ST_NONE);
2482       switch (st)
2483         {
2484         case ST_NONE:
2485           unexpected_eof ();
2486
2487         case ST_CASE:
2488           cp = new_level (gfc_state_stack->head);
2489           *cp = new_st;
2490           gfc_clear_new_st ();
2491
2492           accept_statement (st);
2493           /* Fall through */
2494
2495         case ST_END_SELECT:
2496           break;
2497
2498         /* Can't have an executable statement because of
2499            parse_executable().  */
2500         default:
2501           unexpected_statement (st);
2502           break;
2503         }
2504     }
2505   while (st != ST_END_SELECT);
2506
2507   pop_state ();
2508   accept_statement (st);
2509 }
2510
2511
2512 /* Given a symbol, make sure it is not an iteration variable for a DO
2513    statement.  This subroutine is called when the symbol is seen in a
2514    context that causes it to become redefined.  If the symbol is an
2515    iterator, we generate an error message and return nonzero.  */
2516
2517 int
2518 gfc_check_do_variable (gfc_symtree *st)
2519 {
2520   gfc_state_data *s;
2521
2522   for (s=gfc_state_stack; s; s = s->previous)
2523     if (s->do_variable == st)
2524       {
2525         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2526                       "loop beginning at %L", st->name, &s->head->loc);
2527         return 1;
2528       }
2529
2530   return 0;
2531 }
2532
2533
2534 /* Checks to see if the current statement label closes an enddo.
2535    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2536    an error) if it incorrectly closes an ENDDO.  */
2537
2538 static int
2539 check_do_closure (void)
2540 {
2541   gfc_state_data *p;
2542
2543   if (gfc_statement_label == NULL)
2544     return 0;
2545
2546   for (p = gfc_state_stack; p; p = p->previous)
2547     if (p->state == COMP_DO)
2548       break;
2549
2550   if (p == NULL)
2551     return 0;           /* No loops to close */
2552
2553   if (p->ext.end_do_label == gfc_statement_label)
2554     {
2555
2556       if (p == gfc_state_stack)
2557         return 1;
2558
2559       gfc_error ("End of nonblock DO statement at %C is within another block");
2560       return 2;
2561     }
2562
2563   /* At this point, the label doesn't terminate the innermost loop.
2564      Make sure it doesn't terminate another one.  */
2565   for (; p; p = p->previous)
2566     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2567       {
2568         gfc_error ("End of nonblock DO statement at %C is interwoven "
2569                    "with another DO loop");
2570         return 2;
2571       }
2572
2573   return 0;
2574 }
2575
2576
2577 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
2578    handled inside of parse_executable(), because they aren't really
2579    loop statements.  */
2580
2581 static void
2582 parse_do_block (void)
2583 {
2584   gfc_statement st;
2585   gfc_code *top;
2586   gfc_state_data s;
2587   gfc_symtree *stree;
2588
2589   s.ext.end_do_label = new_st.label;
2590
2591   if (new_st.ext.iterator != NULL)
2592     stree = new_st.ext.iterator->var->symtree;
2593   else
2594     stree = NULL;
2595
2596   accept_statement (ST_DO);
2597
2598   top = gfc_state_stack->tail;
2599   push_state (&s, COMP_DO, gfc_new_block);
2600
2601   s.do_variable = stree;
2602
2603   top->block = new_level (top);
2604   top->block->op = EXEC_DO;
2605
2606 loop:
2607   st = parse_executable (ST_NONE);
2608
2609   switch (st)
2610     {
2611     case ST_NONE:
2612       unexpected_eof ();
2613
2614     case ST_ENDDO:
2615       if (s.ext.end_do_label != NULL
2616           && s.ext.end_do_label != gfc_statement_label)
2617         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2618                        "DO label");
2619
2620       if (gfc_statement_label != NULL)
2621         {
2622           new_st.op = EXEC_NOP;
2623           add_statement ();
2624         }
2625       break;
2626
2627     case ST_IMPLIED_ENDDO:
2628      /* If the do-stmt of this DO construct has a do-construct-name,
2629         the corresponding end-do must be an end-do-stmt (with a matching
2630         name, but in that case we must have seen ST_ENDDO first).
2631         We only complain about this in pedantic mode.  */
2632      if (gfc_current_block () != NULL)
2633         gfc_error_now ("named block DO at %L requires matching ENDDO name",
2634                        &gfc_current_block()->declared_at);
2635
2636       break;
2637
2638     default:
2639       unexpected_statement (st);
2640       goto loop;
2641     }
2642
2643   pop_state ();
2644   accept_statement (st);
2645 }
2646
2647
2648 /* Parse the statements of OpenMP do/parallel do.  */
2649
2650 static gfc_statement
2651 parse_omp_do (gfc_statement omp_st)
2652 {
2653   gfc_statement st;
2654   gfc_code *cp, *np;
2655   gfc_state_data s;
2656
2657   accept_statement (omp_st);
2658
2659   cp = gfc_state_stack->tail;
2660   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2661   np = new_level (cp);
2662   np->op = cp->op;
2663   np->block = NULL;
2664
2665   for (;;)
2666     {
2667       st = next_statement ();
2668       if (st == ST_NONE)
2669         unexpected_eof ();
2670       else if (st == ST_DO)
2671         break;
2672       else
2673         unexpected_statement (st);
2674     }
2675
2676   parse_do_block ();
2677   if (gfc_statement_label != NULL
2678       && gfc_state_stack->previous != NULL
2679       && gfc_state_stack->previous->state == COMP_DO
2680       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2681     {
2682       /* In
2683          DO 100 I=1,10
2684            !$OMP DO
2685              DO J=1,10
2686              ...
2687              100 CONTINUE
2688          there should be no !$OMP END DO.  */
2689       pop_state ();
2690       return ST_IMPLIED_ENDDO;
2691     }
2692
2693   check_do_closure ();
2694   pop_state ();
2695
2696   st = next_statement ();
2697   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2698     {
2699       if (new_st.op == EXEC_OMP_END_NOWAIT)
2700         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2701       else
2702         gcc_assert (new_st.op == EXEC_NOP);
2703       gfc_clear_new_st ();
2704       gfc_commit_symbols ();
2705       gfc_warning_check ();
2706       st = next_statement ();
2707     }
2708   return st;
2709 }
2710
2711
2712 /* Parse the statements of OpenMP atomic directive.  */
2713
2714 static void
2715 parse_omp_atomic (void)
2716 {
2717   gfc_statement st;
2718   gfc_code *cp, *np;
2719   gfc_state_data s;
2720
2721   accept_statement (ST_OMP_ATOMIC);
2722
2723   cp = gfc_state_stack->tail;
2724   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2725   np = new_level (cp);
2726   np->op = cp->op;
2727   np->block = NULL;
2728
2729   for (;;)
2730     {
2731       st = next_statement ();
2732       if (st == ST_NONE)
2733         unexpected_eof ();
2734       else if (st == ST_ASSIGNMENT)
2735         break;
2736       else
2737         unexpected_statement (st);
2738     }
2739
2740   accept_statement (st);
2741
2742   pop_state ();
2743 }
2744
2745
2746 /* Parse the statements of an OpenMP structured block.  */
2747
2748 static void
2749 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2750 {
2751   gfc_statement st, omp_end_st;
2752   gfc_code *cp, *np;
2753   gfc_state_data s;
2754
2755   accept_statement (omp_st);
2756
2757   cp = gfc_state_stack->tail;
2758   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2759   np = new_level (cp);
2760   np->op = cp->op;
2761   np->block = NULL;
2762
2763   switch (omp_st)
2764     {
2765     case ST_OMP_PARALLEL:
2766       omp_end_st = ST_OMP_END_PARALLEL;
2767       break;
2768     case ST_OMP_PARALLEL_SECTIONS:
2769       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2770       break;
2771     case ST_OMP_SECTIONS:
2772       omp_end_st = ST_OMP_END_SECTIONS;
2773       break;
2774     case ST_OMP_ORDERED:
2775       omp_end_st = ST_OMP_END_ORDERED;
2776       break;
2777     case ST_OMP_CRITICAL:
2778       omp_end_st = ST_OMP_END_CRITICAL;
2779       break;
2780     case ST_OMP_MASTER:
2781       omp_end_st = ST_OMP_END_MASTER;
2782       break;
2783     case ST_OMP_SINGLE:
2784       omp_end_st = ST_OMP_END_SINGLE;
2785       break;
2786     case ST_OMP_WORKSHARE:
2787       omp_end_st = ST_OMP_END_WORKSHARE;
2788       break;
2789     case ST_OMP_PARALLEL_WORKSHARE:
2790       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2791       break;
2792     default:
2793       gcc_unreachable ();
2794     }
2795
2796   do
2797     {
2798       if (workshare_stmts_only)
2799         {
2800           /* Inside of !$omp workshare, only
2801              scalar assignments
2802              array assignments
2803              where statements and constructs
2804              forall statements and constructs
2805              !$omp atomic
2806              !$omp critical
2807              !$omp parallel
2808              are allowed.  For !$omp critical these
2809              restrictions apply recursively.  */
2810           bool cycle = true;
2811
2812           st = next_statement ();
2813           for (;;)
2814             {
2815               switch (st)
2816                 {
2817                 case ST_NONE:
2818                   unexpected_eof ();
2819
2820                 case ST_ASSIGNMENT:
2821                 case ST_WHERE:
2822                 case ST_FORALL:
2823                   accept_statement (st);
2824                   break;
2825
2826                 case ST_WHERE_BLOCK:
2827                   parse_where_block ();
2828                   break;
2829
2830                 case ST_FORALL_BLOCK:
2831                   parse_forall_block ();
2832                   break;
2833
2834                 case ST_OMP_PARALLEL:
2835                 case ST_OMP_PARALLEL_SECTIONS:
2836                   parse_omp_structured_block (st, false);
2837                   break;
2838
2839                 case ST_OMP_PARALLEL_WORKSHARE:
2840                 case ST_OMP_CRITICAL:
2841                   parse_omp_structured_block (st, true);
2842                   break;
2843
2844                 case ST_OMP_PARALLEL_DO:
2845                   st = parse_omp_do (st);
2846                   continue;
2847
2848                 case ST_OMP_ATOMIC:
2849                   parse_omp_atomic ();
2850                   break;
2851
2852                 default:
2853                   cycle = false;
2854                   break;
2855                 }
2856
2857               if (!cycle)
2858                 break;
2859
2860               st = next_statement ();
2861             }
2862         }
2863       else
2864         st = parse_executable (ST_NONE);
2865       if (st == ST_NONE)
2866         unexpected_eof ();
2867       else if (st == ST_OMP_SECTION
2868                && (omp_st == ST_OMP_SECTIONS
2869                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
2870         {
2871           np = new_level (np);
2872           np->op = cp->op;
2873           np->block = NULL;
2874         }
2875       else if (st != omp_end_st)
2876         unexpected_statement (st);
2877     }
2878   while (st != omp_end_st);
2879
2880   switch (new_st.op)
2881     {
2882     case EXEC_OMP_END_NOWAIT:
2883       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2884       break;
2885     case EXEC_OMP_CRITICAL:
2886       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2887           || (new_st.ext.omp_name != NULL
2888               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2889         gfc_error ("Name after !$omp critical and !$omp end critical does "
2890                    "not match at %C");
2891       gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
2892       break;
2893     case EXEC_OMP_END_SINGLE:
2894       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2895         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2896       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2897       gfc_free_omp_clauses (new_st.ext.omp_clauses);
2898       break;
2899     case EXEC_NOP:
2900       break;
2901     default:
2902       gcc_unreachable ();
2903     }
2904
2905   gfc_clear_new_st ();
2906   gfc_commit_symbols ();
2907   gfc_warning_check ();
2908   pop_state ();
2909 }
2910
2911
2912 /* Accept a series of executable statements.  We return the first
2913    statement that doesn't fit to the caller.  Any block statements are
2914    passed on to the correct handler, which usually passes the buck
2915    right back here.  */
2916
2917 static gfc_statement
2918 parse_executable (gfc_statement st)
2919 {
2920   int close_flag;
2921
2922   if (st == ST_NONE)
2923     st = next_statement ();
2924
2925   for (;;)
2926     {
2927       close_flag = check_do_closure ();
2928       if (close_flag)
2929         switch (st)
2930           {
2931           case ST_GOTO:
2932           case ST_END_PROGRAM:
2933           case ST_RETURN:
2934           case ST_EXIT:
2935           case ST_END_FUNCTION:
2936           case ST_CYCLE:
2937           case ST_PAUSE:
2938           case ST_STOP:
2939           case ST_END_SUBROUTINE:
2940
2941           case ST_DO:
2942           case ST_FORALL:
2943           case ST_WHERE:
2944           case ST_SELECT_CASE:
2945             gfc_error ("%s statement at %C cannot terminate a non-block "
2946                        "DO loop", gfc_ascii_statement (st));
2947             break;
2948
2949           default:
2950             break;
2951           }
2952
2953       switch (st)
2954         {
2955         case ST_NONE:
2956           unexpected_eof ();
2957
2958         case ST_FORMAT:
2959         case ST_DATA:
2960         case ST_ENTRY:
2961         case_executable:
2962           accept_statement (st);
2963           if (close_flag == 1)
2964             return ST_IMPLIED_ENDDO;
2965           break;
2966
2967         case ST_IF_BLOCK:
2968           parse_if_block ();
2969           break;
2970
2971         case ST_SELECT_CASE:
2972           parse_select_block ();
2973           break;
2974
2975         case ST_DO:
2976           parse_do_block ();
2977           if (check_do_closure () == 1)
2978             return ST_IMPLIED_ENDDO;
2979           break;
2980
2981         case ST_WHERE_BLOCK:
2982           parse_where_block ();
2983           break;
2984
2985         case ST_FORALL_BLOCK:
2986           parse_forall_block ();
2987           break;
2988
2989         case ST_OMP_PARALLEL:
2990         case ST_OMP_PARALLEL_SECTIONS:
2991         case ST_OMP_SECTIONS:
2992         case ST_OMP_ORDERED:
2993         case ST_OMP_CRITICAL:
2994         case ST_OMP_MASTER:
2995         case ST_OMP_SINGLE:
2996           parse_omp_structured_block (st, false);
2997           break;
2998
2999         case ST_OMP_WORKSHARE:
3000         case ST_OMP_PARALLEL_WORKSHARE:
3001           parse_omp_structured_block (st, true);
3002           break;
3003
3004         case ST_OMP_DO:
3005         case ST_OMP_PARALLEL_DO:
3006           st = parse_omp_do (st);
3007           if (st == ST_IMPLIED_ENDDO)
3008             return st;
3009           continue;
3010
3011         case ST_OMP_ATOMIC:
3012           parse_omp_atomic ();
3013           break;
3014
3015         default:
3016           return st;
3017         }
3018
3019       st = next_statement ();
3020     }
3021 }
3022
3023
3024 /* Parse a series of contained program units.  */
3025
3026 static void parse_progunit (gfc_statement);
3027
3028
3029 /* Fix the symbols for sibling functions.  These are incorrectly added to
3030    the child namespace as the parser didn't know about this procedure.  */
3031
3032 static void
3033 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3034 {
3035   gfc_namespace *ns;
3036   gfc_symtree *st;
3037   gfc_symbol *old_sym;
3038
3039   sym->attr.referenced = 1;
3040   for (ns = siblings; ns; ns = ns->sibling)
3041     {
3042       gfc_find_sym_tree (sym->name, ns, 0, &st);
3043
3044       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3045         continue;
3046
3047       old_sym = st->n.sym;
3048       if (old_sym->ns == ns
3049             && !old_sym->attr.contained
3050
3051             /* By 14.6.1.3, host association should be excluded
3052                for the following.  */
3053             && !(old_sym->attr.external
3054                   || (old_sym->ts.type != BT_UNKNOWN
3055                         && !old_sym->attr.implicit_type)
3056                   || old_sym->attr.flavor == FL_PARAMETER
3057                   || old_sym->attr.in_common
3058                   || old_sym->attr.in_equivalence
3059                   || old_sym->attr.data
3060                   || old_sym->attr.dummy
3061                   || old_sym->attr.result
3062                   || old_sym->attr.dimension
3063                   || old_sym->attr.allocatable
3064                   || old_sym->attr.intrinsic
3065                   || old_sym->attr.generic
3066                   || old_sym->attr.flavor == FL_NAMELIST
3067                   || old_sym->attr.proc == PROC_ST_FUNCTION))
3068         {
3069           /* Replace it with the symbol from the parent namespace.  */
3070           st->n.sym = sym;
3071           sym->refs++;
3072
3073           /* Free the old (local) symbol.  */
3074           old_sym->refs--;
3075           if (old_sym->refs == 0)
3076             gfc_free_symbol (old_sym);
3077         }
3078
3079       /* Do the same for any contained procedures.  */
3080       gfc_fixup_sibling_symbols (sym, ns->contained);
3081     }
3082 }
3083
3084 static void
3085 parse_contained (int module)
3086 {
3087   gfc_namespace *ns, *parent_ns, *tmp;
3088   gfc_state_data s1, s2;
3089   gfc_statement st;
3090   gfc_symbol *sym;
3091   gfc_entry_list *el;
3092   int contains_statements = 0;
3093   int seen_error = 0;
3094
3095   push_state (&s1, COMP_CONTAINS, NULL);
3096   parent_ns = gfc_current_ns;
3097
3098   do
3099     {
3100       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3101
3102       gfc_current_ns->sibling = parent_ns->contained;
3103       parent_ns->contained = gfc_current_ns;
3104
3105  next:
3106       /* Process the next available statement.  We come here if we got an error
3107          and rejected the last statement.  */
3108       st = next_statement ();
3109
3110       switch (st)
3111         {
3112         case ST_NONE:
3113           unexpected_eof ();
3114
3115         case ST_FUNCTION:
3116         case ST_SUBROUTINE:
3117           contains_statements = 1;
3118           accept_statement (st);
3119
3120           push_state (&s2,
3121                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3122                       gfc_new_block);
3123
3124           /* For internal procedures, create/update the symbol in the
3125              parent namespace.  */
3126
3127           if (!module)
3128             {
3129               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3130                 gfc_error ("Contained procedure '%s' at %C is already "
3131                            "ambiguous", gfc_new_block->name);
3132               else
3133                 {
3134                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3135                                          &gfc_new_block->declared_at) ==
3136                       SUCCESS)
3137                     {
3138                       if (st == ST_FUNCTION)
3139                         gfc_add_function (&sym->attr, sym->name,
3140                                           &gfc_new_block->declared_at);
3141                       else
3142                         gfc_add_subroutine (&sym->attr, sym->name,
3143                                             &gfc_new_block->declared_at);
3144                     }
3145                 }
3146
3147               gfc_commit_symbols ();
3148             }
3149           else
3150             sym = gfc_new_block;
3151
3152           /* Mark this as a contained function, so it isn't replaced
3153              by other module functions.  */
3154           sym->attr.contained = 1;
3155           sym->attr.referenced = 1;
3156
3157           parse_progunit (ST_NONE);
3158
3159           /* Fix up any sibling functions that refer to this one.  */
3160           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3161           /* Or refer to any of its alternate entry points.  */
3162           for (el = gfc_current_ns->entries; el; el = el->next)
3163             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3164
3165           gfc_current_ns->code = s2.head;
3166           gfc_current_ns = parent_ns;
3167
3168           pop_state ();
3169           break;
3170
3171         /* These statements are associated with the end of the host unit.  */
3172         case ST_END_FUNCTION:
3173         case ST_END_MODULE:
3174         case ST_END_PROGRAM:
3175         case ST_END_SUBROUTINE:
3176           accept_statement (st);
3177           break;
3178
3179         default:
3180           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3181                      gfc_ascii_statement (st));
3182           reject_statement ();
3183           seen_error = 1;
3184           goto next;
3185           break;
3186         }
3187     }
3188   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3189          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3190
3191   /* The first namespace in the list is guaranteed to not have
3192      anything (worthwhile) in it.  */
3193   tmp = gfc_current_ns;
3194   gfc_current_ns = parent_ns;
3195   if (seen_error && tmp->refs > 1)
3196     gfc_free_namespace (tmp);
3197
3198   ns = gfc_current_ns->contained;
3199   gfc_current_ns->contained = ns->sibling;
3200   gfc_free_namespace (ns);
3201
3202   pop_state ();
3203   if (!contains_statements)
3204     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3205                     "FUNCTION or SUBROUTINE statement at %C");
3206 }
3207
3208
3209 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
3210
3211 static void
3212 parse_progunit (gfc_statement st)
3213 {
3214   gfc_state_data *p;
3215   int n;
3216
3217   st = parse_spec (st);
3218   switch (st)
3219     {
3220     case ST_NONE:
3221       unexpected_eof ();
3222
3223     case ST_CONTAINS:
3224       goto contains;
3225
3226     case_end:
3227       accept_statement (st);
3228       goto done;
3229
3230     default:
3231       break;
3232     }
3233
3234   if (gfc_current_state () == COMP_FUNCTION)
3235     gfc_check_function_type (gfc_current_ns);
3236
3237 loop:
3238   for (;;)
3239     {
3240       st = parse_executable (st);
3241
3242       switch (st)
3243         {
3244         case ST_NONE:
3245           unexpected_eof ();
3246
3247         case ST_CONTAINS:
3248           goto contains;
3249
3250         case_end:
3251           accept_statement (st);
3252           goto done;
3253
3254         default:
3255           break;
3256         }
3257
3258       unexpected_statement (st);
3259       reject_statement ();
3260       st = next_statement ();
3261     }
3262
3263 contains:
3264   n = 0;
3265
3266   for (p = gfc_state_stack; p; p = p->previous)
3267     if (p->state == COMP_CONTAINS)
3268       n++;
3269
3270   if (gfc_find_state (COMP_MODULE) == SUCCESS)
3271     n--;
3272
3273   if (n > 0)
3274     {
3275       gfc_error ("CONTAINS statement at %C is already in a contained "
3276                  "program unit");
3277       st = next_statement ();
3278       goto loop;
3279     }
3280
3281   parse_contained (0);
3282
3283 done:
3284   gfc_current_ns->code = gfc_state_stack->head;
3285 }
3286
3287
3288 /* Come here to complain about a global symbol already in use as
3289    something else.  */
3290
3291 void
3292 gfc_global_used (gfc_gsymbol *sym, locus *where)
3293 {
3294   const char *name;
3295
3296   if (where == NULL)
3297     where = &gfc_current_locus;
3298
3299   switch(sym->type)
3300     {
3301     case GSYM_PROGRAM:
3302       name = "PROGRAM";
3303       break;
3304     case GSYM_FUNCTION:
3305       name = "FUNCTION";
3306       break;
3307     case GSYM_SUBROUTINE:
3308       name = "SUBROUTINE";
3309       break;
3310     case GSYM_COMMON:
3311       name = "COMMON";
3312       break;
3313     case GSYM_BLOCK_DATA:
3314       name = "BLOCK DATA";
3315       break;
3316     case GSYM_MODULE:
3317       name = "MODULE";
3318       break;
3319     default:
3320       gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3321       name = NULL;
3322     }
3323
3324   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3325               sym->name, where, name, &sym->where);
3326 }
3327
3328
3329 /* Parse a block data program unit.  */
3330
3331 static void
3332 parse_block_data (void)
3333 {
3334   gfc_statement st;
3335   static locus blank_locus;
3336   static int blank_block=0;
3337   gfc_gsymbol *s;
3338
3339   gfc_current_ns->proc_name = gfc_new_block;
3340   gfc_current_ns->is_block_data = 1;
3341
3342   if (gfc_new_block == NULL)
3343     {
3344       if (blank_block)
3345        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3346                   "prior BLOCK DATA at %L", &blank_locus);
3347       else
3348        {
3349          blank_block = 1;
3350          blank_locus = gfc_current_locus;
3351        }
3352     }
3353   else
3354     {
3355       s = gfc_get_gsymbol (gfc_new_block->name);
3356       if (s->defined
3357           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3358        gfc_global_used(s, NULL);
3359       else
3360        {
3361          s->type = GSYM_BLOCK_DATA;
3362          s->where = gfc_current_locus;
3363          s->defined = 1;
3364        }
3365     }
3366
3367   st = parse_spec (ST_NONE);
3368
3369   while (st != ST_END_BLOCK_DATA)
3370     {
3371       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3372                  gfc_ascii_statement (st));
3373       reject_statement ();
3374       st = next_statement ();
3375     }
3376 }
3377
3378
3379 /* Parse a module subprogram.  */
3380
3381 static void
3382 parse_module (void)
3383 {
3384   gfc_statement st;
3385   gfc_gsymbol *s;
3386
3387   s = gfc_get_gsymbol (gfc_new_block->name);
3388   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3389     gfc_global_used(s, NULL);
3390   else
3391     {
3392       s->type = GSYM_MODULE;
3393       s->where = gfc_current_locus;
3394       s->defined = 1;
3395     }
3396
3397   st = parse_spec (ST_NONE);
3398
3399 loop:
3400   switch (st)
3401     {
3402     case ST_NONE:
3403       unexpected_eof ();
3404
3405     case ST_CONTAINS:
3406       parse_contained (1);
3407       break;
3408
3409     case ST_END_MODULE:
3410       accept_statement (st);
3411       break;
3412
3413     default:
3414       gfc_error ("Unexpected %s statement in MODULE at %C",
3415                  gfc_ascii_statement (st));
3416
3417       reject_statement ();
3418       st = next_statement ();
3419       goto loop;
3420     }
3421 }
3422
3423
3424 /* Add a procedure name to the global symbol table.  */
3425
3426 static void
3427 add_global_procedure (int sub)
3428 {
3429   gfc_gsymbol *s;
3430
3431   s = gfc_get_gsymbol(gfc_new_block->name);
3432
3433   if (s->defined
3434       || (s->type != GSYM_UNKNOWN
3435           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3436     gfc_global_used(s, NULL);
3437   else
3438     {
3439       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3440       s->where = gfc_current_locus;
3441       s->defined = 1;
3442     }
3443 }
3444
3445
3446 /* Add a program to the global symbol table.  */
3447
3448 static void
3449 add_global_program (void)
3450 {
3451   gfc_gsymbol *s;
3452
3453   if (gfc_new_block == NULL)
3454     return;
3455   s = gfc_get_gsymbol (gfc_new_block->name);
3456
3457   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3458     gfc_global_used(s, NULL);
3459   else
3460     {
3461       s->type = GSYM_PROGRAM;
3462       s->where = gfc_current_locus;
3463       s->defined = 1;
3464     }
3465 }
3466
3467
3468 /* Top level parser.  */
3469
3470 try
3471 gfc_parse_file (void)
3472 {
3473   int seen_program, errors_before, errors;
3474   gfc_state_data top, s;
3475   gfc_statement st;
3476   locus prog_locus;
3477
3478   gfc_start_source_files ();
3479
3480   top.state = COMP_NONE;
3481   top.sym = NULL;
3482   top.previous = NULL;
3483   top.head = top.tail = NULL;
3484   top.do_variable = NULL;
3485
3486   gfc_state_stack = &top;
3487
3488   gfc_clear_new_st ();
3489
3490   gfc_statement_label = NULL;
3491
3492   if (setjmp (eof_buf))
3493     return FAILURE;     /* Come here on unexpected EOF */
3494
3495   seen_program = 0;
3496
3497   /* Exit early for empty files.  */
3498   if (gfc_at_eof ())
3499     goto done;
3500
3501 loop:
3502   gfc_init_2 ();
3503   st = next_statement ();
3504   switch (st)
3505     {
3506     case ST_NONE:
3507       gfc_done_2 ();
3508       goto done;
3509
3510     case ST_PROGRAM:
3511       if (seen_program)
3512         goto duplicate_main;
3513       seen_program = 1;
3514       prog_locus = gfc_current_locus;
3515
3516       push_state (&s, COMP_PROGRAM, gfc_new_block);
3517       main_program_symbol(gfc_current_ns, gfc_new_block->name);
3518       accept_statement (st);
3519       add_global_program ();
3520       parse_progunit (ST_NONE);
3521       break;
3522
3523     case ST_SUBROUTINE:
3524       add_global_procedure (1);
3525       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3526       accept_statement (st);
3527       parse_progunit (ST_NONE);
3528       break;
3529
3530     case ST_FUNCTION:
3531       add_global_procedure (0);
3532       push_state (&s, COMP_FUNCTION, gfc_new_block);
3533       accept_statement (st);
3534       parse_progunit (ST_NONE);
3535       break;
3536
3537     case ST_BLOCK_DATA:
3538       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3539       accept_statement (st);
3540       parse_block_data ();
3541       break;
3542
3543     case ST_MODULE:
3544       push_state (&s, COMP_MODULE, gfc_new_block);
3545       accept_statement (st);
3546
3547       gfc_get_errors (NULL, &errors_before);
3548       parse_module ();
3549       break;
3550
3551     /* Anything else starts a nameless main program block.  */
3552     default:
3553       if (seen_program)
3554         goto duplicate_main;
3555       seen_program = 1;
3556       prog_locus = gfc_current_locus;
3557
3558       push_state (&s, COMP_PROGRAM, gfc_new_block);
3559       main_program_symbol (gfc_current_ns, "MAIN__");
3560       parse_progunit (st);
3561       break;
3562     }
3563
3564   gfc_current_ns->code = s.head;
3565
3566   gfc_resolve (gfc_current_ns);
3567
3568   /* Dump the parse tree if requested.  */
3569   if (gfc_option.dump_parse_tree)
3570     gfc_dump_parse_tree (gfc_current_ns, stdout);
3571
3572   gfc_get_errors (NULL, &errors);
3573   if (s.state == COMP_MODULE)
3574     {
3575       gfc_dump_module (s.sym->name, errors_before == errors);
3576       if (errors == 0)
3577         gfc_generate_module_code (gfc_current_ns);
3578     }
3579   else
3580     {
3581       if (errors == 0)
3582         gfc_generate_code (gfc_current_ns);
3583     }
3584
3585   pop_state ();
3586   gfc_done_2 ();
3587   goto loop;
3588
3589 done:
3590   gfc_end_source_files ();
3591   return SUCCESS;
3592
3593 duplicate_main:
3594   /* If we see a duplicate main program, shut down.  If the second
3595      instance is an implied main program, ie data decls or executable
3596      statements, we're in for lots of errors.  */
3597   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3598   reject_statement ();
3599   gfc_done_2 ();
3600   return SUCCESS;
3601 }