gcc/fortran/parse.c

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