gcc/fortran/parse.c

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