gcc/fortran/parse.c

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