gcc/fortran/parse.c

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