gcc/fortran/parse.c

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