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