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