gcc/fortran/parse.c

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