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