gcc/fortran/parse.c

   1 /* Main parser.
   2    Copyright (C) 2000-2022 Free Software Foundation, Inc.
   3    Contributed by Andy Vaught
   4
   5 This file is part of GCC.
   6
   7 GCC is free software; you can redistribute it and/or modify it under
   8 the terms of the GNU General Public License as published by the Free
   9 Software Foundation; either version 3, or (at your option) any later
  10 version.
  11
  12 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  13 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  14 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  15 for more details.
  16
  17 You should have received a copy of the GNU General Public License
  18 along with GCC; see the file COPYING3.  If not see
  19 <http://www.gnu.org/licenses/>.  */
  20
  21 #include "config.h"
  22 #include "system.h"
  23 #include "coretypes.h"
  24 #include "options.h"
  25 #include "gfortran.h"
  26 #include <setjmp.h>
  27 #include "match.h"
  28 #include "parse.h"
  29 #include "tree-core.h"
  30 #include "omp-general.h"
  31
  32 /* Current statement label.  Zero means no statement label.  Because new_st
  33    can get wiped during statement matching, we have to keep it separate.  */
  34
  35 gfc_st_label *gfc_statement_label;
  36
  37 static locus label_locus;
  38 static jmp_buf eof_buf;
  39
  40 gfc_state_data *gfc_state_stack;
  41 static bool last_was_use_stmt = false;
  42
  43 /* TODO: Re-order functions to kill these forward decls.  */
  44 static void check_statement_label (gfc_statement);
  45 static void undo_new_statement (void);
  46 static void reject_statement (void);
  47
  48
  49 /* A sort of half-matching function.  We try to match the word on the
  50    input with the passed string.  If this succeeds, we call the
  51    keyword-dependent matching function that will match the rest of the
  52    statement.  For single keywords, the matching subroutine is
  53    gfc_match_eos().  */
  54
  55 static match
  56 match_word (const char *str, match (*subr) (void), locus *old_locus)
  57 {
  58   match m;
  59
  60   if (str != NULL)
  61     {
  62       m = gfc_match (str);
  63       if (m != MATCH_YES)
  64         return m;
  65     }
  66
  67   m = (*subr) ();
  68
  69   if (m != MATCH_YES)
  70     {
  71       gfc_current_locus = *old_locus;
  72       reject_statement ();
  73     }
  74
  75   return m;
  76 }
  77
  78
  79 /* Like match_word, but if str is matched, set a flag that it
  80    was matched.  */
  81 static match
  82 match_word_omp_simd (const char *str, match (*subr) (void), locus *old_locus,
  83                      bool *simd_matched)
  84 {
  85   match m;
  86
  87   if (str != NULL)
  88     {
  89       m = gfc_match (str);
  90       if (m != MATCH_YES)
  91         return m;
  92       *simd_matched = true;
  93     }
  94
  95   m = (*subr) ();
  96
  97   if (m != MATCH_YES)
  98     {
  99       gfc_current_locus = *old_locus;
 100       reject_statement ();
 101     }
 102
 103   return m;
 104 }
 105
 106
 107 /* Load symbols from all USE statements encountered in this scoping unit.  */
 108
 109 static void
 110 use_modules (void)
 111 {
 112   gfc_error_buffer old_error;
 113
 114   gfc_push_error (&old_error);
 115   gfc_buffer_error (false);
 116   gfc_use_modules ();
 117   gfc_buffer_error (true);
 118   gfc_pop_error (&old_error);
 119   gfc_commit_symbols ();
 120   gfc_warning_check ();
 121   gfc_current_ns->old_equiv = gfc_current_ns->equiv;
 122   gfc_current_ns->old_data = gfc_current_ns->data;
 123   last_was_use_stmt = false;
 124 }
 125
 126
 127 /* Figure out what the next statement is, (mostly) regardless of
 128    proper ordering.  The do...while(0) is there to prevent if/else
 129    ambiguity.  */
 130
 131 #define match(keyword, subr, st)                                \
 132     do {                                                        \
 133       if (match_word (keyword, subr, &old_locus) == MATCH_YES)  \
 134         return st;                                              \
 135       else                                                      \
 136         undo_new_statement ();                                  \
 137     } while (0)
 138
 139
 140 /* This is a specialist version of decode_statement that is used
 141    for the specification statements in a function, whose
 142    characteristics are deferred into the specification statements.
 143    eg.:  INTEGER (king = mykind) foo ()
 144          USE mymodule, ONLY mykind.....
 145    The KIND parameter needs a return after USE or IMPORT, whereas
 146    derived type declarations can occur anywhere, up the executable
 147    block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
 148    out of the correct kind of specification statements.  */
 149 static gfc_statement
 150 decode_specification_statement (void)
 151 {
 152   gfc_statement st;
 153   locus old_locus;
 154   char c;
 155
 156   if (gfc_match_eos () == MATCH_YES)
 157     return ST_NONE;
 158
 159   old_locus = gfc_current_locus;
 160
 161   if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
 162     {
 163       last_was_use_stmt = true;
 164       return ST_USE;
 165     }
 166   else
 167     {
 168       undo_new_statement ();
 169       if (last_was_use_stmt)
 170         use_modules ();
 171     }
 172
 173   match ("import", gfc_match_import, ST_IMPORT);
 174
 175   if (gfc_current_block ()->result->ts.type != BT_DERIVED)
 176     goto end_of_block;
 177
 178   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 179   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 180   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 181
 182   /* General statement matching: Instead of testing every possible
 183      statement, we eliminate most possibilities by peeking at the
 184      first character.  */
 185
 186   c = gfc_peek_ascii_char ();
 187
 188   switch (c)
 189     {
 190     case 'a':
 191       match ("abstract% interface", gfc_match_abstract_interface,
 192              ST_INTERFACE);
 193       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
 194       match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
 195       match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
 196       break;
 197
 198     case 'b':
 199       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 200       break;
 201
 202     case 'c':
 203       match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
 204       match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
 205       break;
 206
 207     case 'd':
 208       match ("data", gfc_match_data, ST_DATA);
 209       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 210       break;
 211
 212     case 'e':
 213       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 214       match ("entry% ", gfc_match_entry, ST_ENTRY);
 215       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 216       match ("external", gfc_match_external, ST_ATTR_DECL);
 217       break;
 218
 219     case 'f':
 220       match ("format", gfc_match_format, ST_FORMAT);
 221       break;
 222
 223     case 'g':
 224       break;
 225
 226     case 'i':
 227       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 228       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 229       match ("interface", gfc_match_interface, ST_INTERFACE);
 230       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 231       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 232       break;
 233
 234     case 'm':
 235       break;
 236
 237     case 'n':
 238       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 239       break;
 240
 241     case 'o':
 242       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 243       break;
 244
 245     case 'p':
 246       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 247       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 248       if (gfc_match_private (&st) == MATCH_YES)
 249         return st;
 250       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 251       if (gfc_match_public (&st) == MATCH_YES)
 252         return st;
 253       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 254       break;
 255
 256     case 'r':
 257       break;
 258
 259     case 's':
 260       match ("save", gfc_match_save, ST_ATTR_DECL);
 261       match ("static", gfc_match_static, ST_ATTR_DECL);
 262       match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
 263       break;
 264
 265     case 't':
 266       match ("target", gfc_match_target, ST_ATTR_DECL);
 267       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 268       break;
 269
 270     case 'u':
 271       break;
 272
 273     case 'v':
 274       match ("value", gfc_match_value, ST_ATTR_DECL);
 275       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 276       break;
 277
 278     case 'w':
 279       break;
 280     }
 281
 282   /* This is not a specification statement.  See if any of the matchers
 283      has stored an error message of some sort.  */
 284
 285 end_of_block:
 286   gfc_clear_error ();
 287   gfc_buffer_error (false);
 288   gfc_current_locus = old_locus;
 289
 290   return ST_GET_FCN_CHARACTERISTICS;
 291 }
 292
 293 static bool in_specification_block;
 294
 295 /* This is the primary 'decode_statement'.  */
 296 static gfc_statement
 297 decode_statement (void)
 298 {
 299   gfc_statement st;
 300   locus old_locus;
 301   match m = MATCH_NO;
 302   char c;
 303
 304   gfc_enforce_clean_symbol_state ();
 305
 306   gfc_clear_error ();   /* Clear any pending errors.  */
 307   gfc_clear_warning (); /* Clear any pending warnings.  */
 308
 309   gfc_matching_function = false;
 310
 311   if (gfc_match_eos () == MATCH_YES)
 312     return ST_NONE;
 313
 314   if (gfc_current_state () == COMP_FUNCTION
 315         && gfc_current_block ()->result->ts.kind == -1)
 316     return decode_specification_statement ();
 317
 318   old_locus = gfc_current_locus;
 319
 320   c = gfc_peek_ascii_char ();
 321
 322   if (c == 'u')
 323     {
 324       if (match_word ("use", gfc_match_use, &old_locus) == MATCH_YES)
 325         {
 326           last_was_use_stmt = true;
 327           return ST_USE;
 328         }
 329       else
 330         undo_new_statement ();
 331     }
 332
 333   if (last_was_use_stmt)
 334     use_modules ();
 335
 336   /* Try matching a data declaration or function declaration. The
 337       input "REALFUNCTIONA(N)" can mean several things in different
 338       contexts, so it (and its relatives) get special treatment.  */
 339
 340   if (gfc_current_state () == COMP_NONE
 341       || gfc_current_state () == COMP_INTERFACE
 342       || gfc_current_state () == COMP_CONTAINS)
 343     {
 344       gfc_matching_function = true;
 345       m = gfc_match_function_decl ();
 346       if (m == MATCH_YES)
 347         return ST_FUNCTION;
 348       else if (m == MATCH_ERROR)
 349         reject_statement ();
 350       else
 351         gfc_undo_symbols ();
 352       gfc_current_locus = old_locus;
 353     }
 354   gfc_matching_function = false;
 355
 356   /* Legacy parameter statements are ambiguous with assignments so try parameter
 357      first.  */
 358   match ("parameter", gfc_match_parameter, ST_PARAMETER);
 359
 360   /* Match statements whose error messages are meant to be overwritten
 361      by something better.  */
 362
 363   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
 364   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
 365
 366   if (in_specification_block)
 367     {
 368       m = match_word (NULL, gfc_match_st_function, &old_locus);
 369       if (m == MATCH_YES)
 370         return ST_STATEMENT_FUNCTION;
 371     }
 372
 373   if (!(in_specification_block && m == MATCH_ERROR))
 374     {
 375       match (NULL, gfc_match_ptr_fcn_assign, ST_ASSIGNMENT);
 376     }
 377
 378   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 379   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 380
 381   /* Try to match a subroutine statement, which has the same optional
 382      prefixes that functions can have.  */
 383
 384   if (gfc_match_subroutine () == MATCH_YES)
 385     return ST_SUBROUTINE;
 386   gfc_undo_symbols ();
 387   gfc_current_locus = old_locus;
 388
 389   if (gfc_match_submod_proc () == MATCH_YES)
 390     {
 391       if (gfc_new_block->attr.subroutine)
 392         return ST_SUBROUTINE;
 393       else if (gfc_new_block->attr.function)
 394         return ST_FUNCTION;
 395     }
 396   gfc_undo_symbols ();
 397   gfc_current_locus = old_locus;
 398
 399   /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
 400      statements, which might begin with a block label.  The match functions for
 401      these statements are unusual in that their keyword is not seen before
 402      the matcher is called.  */
 403
 404   if (gfc_match_if (&st) == MATCH_YES)
 405     return st;
 406   gfc_undo_symbols ();
 407   gfc_current_locus = old_locus;
 408
 409   if (gfc_match_where (&st) == MATCH_YES)
 410     return st;
 411   gfc_undo_symbols ();
 412   gfc_current_locus = old_locus;
 413
 414   if (gfc_match_forall (&st) == MATCH_YES)
 415     return st;
 416   gfc_undo_symbols ();
 417   gfc_current_locus = old_locus;
 418
 419   /* Try to match TYPE as an alias for PRINT.  */
 420   if (gfc_match_type (&st) == MATCH_YES)
 421     return st;
 422   gfc_undo_symbols ();
 423   gfc_current_locus = old_locus;
 424
 425   match (NULL, gfc_match_do, ST_DO);
 426   match (NULL, gfc_match_block, ST_BLOCK);
 427   match (NULL, gfc_match_associate, ST_ASSOCIATE);
 428   match (NULL, gfc_match_critical, ST_CRITICAL);
 429   match (NULL, gfc_match_select, ST_SELECT_CASE);
 430   match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
 431   match (NULL, gfc_match_select_rank, ST_SELECT_RANK);
 432
 433   /* General statement matching: Instead of testing every possible
 434      statement, we eliminate most possibilities by peeking at the
 435      first character.  */
 436
 437   switch (c)
 438     {
 439     case 'a':
 440       match ("abstract% interface", gfc_match_abstract_interface,
 441              ST_INTERFACE);
 442       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
 443       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
 444       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
 445       match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
 446       match ("automatic", gfc_match_automatic, ST_ATTR_DECL);
 447       break;
 448
 449     case 'b':
 450       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
 451       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
 452       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 453       break;
 454
 455     case 'c':
 456       match ("call", gfc_match_call, ST_CALL);
 457       match ("change team", gfc_match_change_team, ST_CHANGE_TEAM);
 458       match ("close", gfc_match_close, ST_CLOSE);
 459       match ("continue", gfc_match_continue, ST_CONTINUE);
 460       match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
 461       match ("cycle", gfc_match_cycle, ST_CYCLE);
 462       match ("case", gfc_match_case, ST_CASE);
 463       match ("common", gfc_match_common, ST_COMMON);
 464       match ("contains", gfc_match_eos, ST_CONTAINS);
 465       match ("class", gfc_match_class_is, ST_CLASS_IS);
 466       match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
 467       break;
 468
 469     case 'd':
 470       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
 471       match ("data", gfc_match_data, ST_DATA);
 472       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 473       break;
 474
 475     case 'e':
 476       match ("end file", gfc_match_endfile, ST_END_FILE);
 477       match ("end team", gfc_match_end_team, ST_END_TEAM);
 478       match ("exit", gfc_match_exit, ST_EXIT);
 479       match ("else", gfc_match_else, ST_ELSE);
 480       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
 481       match ("else if", gfc_match_elseif, ST_ELSEIF);
 482       match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
 483       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 484
 485       if (gfc_match_end (&st) == MATCH_YES)
 486         return st;
 487
 488       match ("entry% ", gfc_match_entry, ST_ENTRY);
 489       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 490       match ("external", gfc_match_external, ST_ATTR_DECL);
 491       match ("event post", gfc_match_event_post, ST_EVENT_POST);
 492       match ("event wait", gfc_match_event_wait, ST_EVENT_WAIT);
 493       break;
 494
 495     case 'f':
 496       match ("fail image", gfc_match_fail_image, ST_FAIL_IMAGE);
 497       match ("final", gfc_match_final_decl, ST_FINAL);
 498       match ("flush", gfc_match_flush, ST_FLUSH);
 499       match ("form team", gfc_match_form_team, ST_FORM_TEAM);
 500       match ("format", gfc_match_format, ST_FORMAT);
 501       break;
 502
 503     case 'g':
 504       match ("generic", gfc_match_generic, ST_GENERIC);
 505       match ("go to", gfc_match_goto, ST_GOTO);
 506       break;
 507
 508     case 'i':
 509       match ("inquire", gfc_match_inquire, ST_INQUIRE);
 510       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 511       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 512       match ("import", gfc_match_import, ST_IMPORT);
 513       match ("interface", gfc_match_interface, ST_INTERFACE);
 514       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 515       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 516       break;
 517
 518     case 'l':
 519       match ("lock", gfc_match_lock, ST_LOCK);
 520       break;
 521
 522     case 'm':
 523       match ("map", gfc_match_map, ST_MAP);
 524       match ("module% procedure", gfc_match_modproc, ST_MODULE_PROC);
 525       match ("module", gfc_match_module, ST_MODULE);
 526       break;
 527
 528     case 'n':
 529       match ("nullify", gfc_match_nullify, ST_NULLIFY);
 530       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 531       break;
 532
 533     case 'o':
 534       match ("open", gfc_match_open, ST_OPEN);
 535       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 536       break;
 537
 538     case 'p':
 539       match ("print", gfc_match_print, ST_WRITE);
 540       match ("pause", gfc_match_pause, ST_PAUSE);
 541       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 542       if (gfc_match_private (&st) == MATCH_YES)
 543         return st;
 544       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 545       match ("program", gfc_match_program, ST_PROGRAM);
 546       if (gfc_match_public (&st) == MATCH_YES)
 547         return st;
 548       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 549       break;
 550
 551     case 'r':
 552       match ("rank", gfc_match_rank_is, ST_RANK);
 553       match ("read", gfc_match_read, ST_READ);
 554       match ("return", gfc_match_return, ST_RETURN);
 555       match ("rewind", gfc_match_rewind, ST_REWIND);
 556       break;
 557
 558     case 's':
 559       match ("structure", gfc_match_structure_decl, ST_STRUCTURE_DECL);
 560       match ("sequence", gfc_match_eos, ST_SEQUENCE);
 561       match ("stop", gfc_match_stop, ST_STOP);
 562       match ("save", gfc_match_save, ST_ATTR_DECL);
 563       match ("static", gfc_match_static, ST_ATTR_DECL);
 564       match ("submodule", gfc_match_submodule, ST_SUBMODULE);
 565       match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
 566       match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
 567       match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
 568       match ("sync team", gfc_match_sync_team, ST_SYNC_TEAM);
 569       break;
 570
 571     case 't':
 572       match ("target", gfc_match_target, ST_ATTR_DECL);
 573       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 574       match ("type is", gfc_match_type_is, ST_TYPE_IS);
 575       break;
 576
 577     case 'u':
 578       match ("union", gfc_match_union, ST_UNION);
 579       match ("unlock", gfc_match_unlock, ST_UNLOCK);
 580       break;
 581
 582     case 'v':
 583       match ("value", gfc_match_value, ST_ATTR_DECL);
 584       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 585       break;
 586
 587     case 'w':
 588       match ("wait", gfc_match_wait, ST_WAIT);
 589       match ("write", gfc_match_write, ST_WRITE);
 590       break;
 591     }
 592
 593   /* All else has failed, so give up.  See if any of the matchers has
 594      stored an error message of some sort.  Suppress the "Unclassifiable
 595      statement" if a previous error message was emitted, e.g., by
 596      gfc_error_now ().  */
 597   if (!gfc_error_check ())
 598     {
 599       int ecnt;
 600       gfc_get_errors (NULL, &ecnt);
 601       if (ecnt <= 0)
 602         gfc_error_now ("Unclassifiable statement at %C");
 603     }
 604
 605   reject_statement ();
 606
 607   gfc_error_recovery ();
 608
 609   return ST_NONE;
 610 }
 611
 612 /* Like match and if spec_only, goto do_spec_only without actually
 613    matching.  */
 614 /* If the directive matched but the clauses failed, do not start
 615    matching the next directive in the same switch statement. */
 616 #define matcha(keyword, subr, st)                               \
 617     do {                                                        \
 618       match m2;                                                 \
 619       if (spec_only && gfc_match (keyword) == MATCH_YES)        \
 620         goto do_spec_only;                                      \
 621       else if ((m2 = match_word (keyword, subr, &old_locus))    \
 622                == MATCH_YES)                                    \
 623         return st;                                              \
 624       else if (m2 == MATCH_ERROR)                               \
 625         goto error_handling;                                    \
 626       else                                                      \
 627         undo_new_statement ();                                  \
 628     } while (0)
 629
 630 static gfc_statement
 631 decode_oacc_directive (void)
 632 {
 633   locus old_locus;
 634   char c;
 635   bool spec_only = false;
 636
 637   gfc_enforce_clean_symbol_state ();
 638
 639   gfc_clear_error ();   /* Clear any pending errors.  */
 640   gfc_clear_warning (); /* Clear any pending warnings.  */
 641
 642   gfc_matching_function = false;
 643
 644   if (gfc_current_state () == COMP_FUNCTION
 645       && gfc_current_block ()->result->ts.kind == -1)
 646     spec_only = true;
 647
 648   old_locus = gfc_current_locus;
 649
 650   /* General OpenACC directive matching: Instead of testing every possible
 651      statement, we eliminate most possibilities by peeking at the
 652      first character.  */
 653
 654   c = gfc_peek_ascii_char ();
 655
 656   switch (c)
 657     {
 658     case 'r':
 659       matcha ("routine", gfc_match_oacc_routine, ST_OACC_ROUTINE);
 660       break;
 661     }
 662
 663   gfc_unset_implicit_pure (NULL);
 664   if (gfc_pure (NULL))
 665     {
 666       gfc_error_now ("OpenACC directives other than ROUTINE may not appear in PURE "
 667                      "procedures at %C");
 668       goto error_handling;
 669     }
 670
 671   switch (c)
 672     {
 673     case 'a':
 674       matcha ("atomic", gfc_match_oacc_atomic, ST_OACC_ATOMIC);
 675       break;
 676     case 'c':
 677       matcha ("cache", gfc_match_oacc_cache, ST_OACC_CACHE);
 678       break;
 679     case 'd':
 680       matcha ("data", gfc_match_oacc_data, ST_OACC_DATA);
 681       match ("declare", gfc_match_oacc_declare, ST_OACC_DECLARE);
 682       break;
 683     case 'e':
 684       matcha ("end atomic", gfc_match_omp_eos_error, ST_OACC_END_ATOMIC);
 685       matcha ("end data", gfc_match_omp_eos_error, ST_OACC_END_DATA);
 686       matcha ("end host_data", gfc_match_omp_eos_error, ST_OACC_END_HOST_DATA);
 687       matcha ("end kernels loop", gfc_match_omp_eos_error, ST_OACC_END_KERNELS_LOOP);
 688       matcha ("end kernels", gfc_match_omp_eos_error, ST_OACC_END_KERNELS);
 689       matcha ("end loop", gfc_match_omp_eos_error, ST_OACC_END_LOOP);
 690       matcha ("end parallel loop", gfc_match_omp_eos_error,
 691               ST_OACC_END_PARALLEL_LOOP);
 692       matcha ("end parallel", gfc_match_omp_eos_error, ST_OACC_END_PARALLEL);
 693       matcha ("end serial loop", gfc_match_omp_eos_error,
 694               ST_OACC_END_SERIAL_LOOP);
 695       matcha ("end serial", gfc_match_omp_eos_error, ST_OACC_END_SERIAL);
 696       matcha ("enter data", gfc_match_oacc_enter_data, ST_OACC_ENTER_DATA);
 697       matcha ("exit data", gfc_match_oacc_exit_data, ST_OACC_EXIT_DATA);
 698       break;
 699     case 'h':
 700       matcha ("host_data", gfc_match_oacc_host_data, ST_OACC_HOST_DATA);
 701       break;
 702     case 'p':
 703       matcha ("parallel loop", gfc_match_oacc_parallel_loop,
 704               ST_OACC_PARALLEL_LOOP);
 705       matcha ("parallel", gfc_match_oacc_parallel, ST_OACC_PARALLEL);
 706       break;
 707     case 'k':
 708       matcha ("kernels loop", gfc_match_oacc_kernels_loop,
 709               ST_OACC_KERNELS_LOOP);
 710       matcha ("kernels", gfc_match_oacc_kernels, ST_OACC_KERNELS);
 711       break;
 712     case 'l':
 713       matcha ("loop", gfc_match_oacc_loop, ST_OACC_LOOP);
 714       break;
 715     case 's':
 716       matcha ("serial loop", gfc_match_oacc_serial_loop, ST_OACC_SERIAL_LOOP);
 717       matcha ("serial", gfc_match_oacc_serial, ST_OACC_SERIAL);
 718       break;
 719     case 'u':
 720       matcha ("update", gfc_match_oacc_update, ST_OACC_UPDATE);
 721       break;
 722     case 'w':
 723       matcha ("wait", gfc_match_oacc_wait, ST_OACC_WAIT);
 724       break;
 725     }
 726
 727   /* Directive not found or stored an error message.
 728      Check and give up.  */
 729
 730  error_handling:
 731   if (gfc_error_check () == 0)
 732     gfc_error_now ("Unclassifiable OpenACC directive at %C");
 733
 734   reject_statement ();
 735
 736   gfc_error_recovery ();
 737
 738   return ST_NONE;
 739
 740  do_spec_only:
 741   reject_statement ();
 742   gfc_clear_error ();
 743   gfc_buffer_error (false);
 744   gfc_current_locus = old_locus;
 745   return ST_GET_FCN_CHARACTERISTICS;
 746 }
 747
 748 /* Like match, but set a flag simd_matched if keyword matched
 749    and if spec_only, goto do_spec_only without actually matching.  */
 750 #define matchs(keyword, subr, st)                               \
 751     do {                                                        \
 752       match m2;                                                 \
 753       if (spec_only && gfc_match (keyword) == MATCH_YES)        \
 754         goto do_spec_only;                                      \
 755       if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
 756                                &simd_matched)) == MATCH_YES)    \
 757         {                                                       \
 758           ret = st;                                             \
 759           goto finish;                                          \
 760         }                                                       \
 761       else if (m2 == MATCH_ERROR)                               \
 762         goto error_handling;                                    \
 763       else                                                      \
 764         undo_new_statement ();                                  \
 765     } while (0)
 766
 767 /* Like match, but don't match anything if not -fopenmp
 768    and if spec_only, goto do_spec_only without actually matching.  */
 769 /* If the directive matched but the clauses failed, do not start
 770    matching the next directive in the same switch statement. */
 771 #define matcho(keyword, subr, st)                               \
 772     do {                                                        \
 773       match m2;                                                 \
 774       if (!flag_openmp)                                         \
 775         ;                                                       \
 776       else if (spec_only && gfc_match (keyword) == MATCH_YES)   \
 777         goto do_spec_only;                                      \
 778       else if ((m2 = match_word (keyword, subr, &old_locus))    \
 779                == MATCH_YES)                                    \
 780         {                                                       \
 781           ret = st;                                             \
 782           goto finish;                                          \
 783         }                                                       \
 784       else if (m2 == MATCH_ERROR)                               \
 785         goto error_handling;                                    \
 786       else                                                      \
 787         undo_new_statement ();                                  \
 788     } while (0)
 789
 790 /* Like match, but set a flag simd_matched if keyword matched.  */
 791 #define matchds(keyword, subr, st)                              \
 792     do {                                                        \
 793       match m2;                                                 \
 794       if ((m2 = match_word_omp_simd (keyword, subr, &old_locus, \
 795                                &simd_matched)) == MATCH_YES)    \
 796         {                                                       \
 797           ret = st;                                             \
 798           goto finish;                                          \
 799         }                                                       \
 800       else if (m2 == MATCH_ERROR)                               \
 801         goto error_handling;                                    \
 802       else                                                      \
 803         undo_new_statement ();                                  \
 804     } while (0)
 805
 806 /* Like match, but don't match anything if not -fopenmp.  */
 807 #define matchdo(keyword, subr, st)                              \
 808     do {                                                        \
 809       match m2;                                                 \
 810       if (!flag_openmp)                                         \
 811         ;                                                       \
 812       else if ((m2 = match_word (keyword, subr, &old_locus))    \
 813                == MATCH_YES)                                    \
 814         {                                                       \
 815           ret = st;                                             \
 816           goto finish;                                          \
 817         }                                                       \
 818       else if (m2 == MATCH_ERROR)                               \
 819         goto error_handling;                                    \
 820       else                                                      \
 821         undo_new_statement ();                                  \
 822     } while (0)
 823
 824 static gfc_statement
 825 decode_omp_directive (void)
 826 {
 827   locus old_locus;
 828   char c;
 829   bool simd_matched = false;
 830   bool spec_only = false;
 831   gfc_statement ret = ST_NONE;
 832   bool pure_ok = true;
 833
 834   gfc_enforce_clean_symbol_state ();
 835
 836   gfc_clear_error ();   /* Clear any pending errors.  */
 837   gfc_clear_warning (); /* Clear any pending warnings.  */
 838
 839   gfc_matching_function = false;
 840
 841   if (gfc_current_state () == COMP_FUNCTION
 842       && gfc_current_block ()->result->ts.kind == -1)
 843     spec_only = true;
 844
 845   old_locus = gfc_current_locus;
 846
 847   /* General OpenMP directive matching: Instead of testing every possible
 848      statement, we eliminate most possibilities by peeking at the
 849      first character.  */
 850
 851   c = gfc_peek_ascii_char ();
 852
 853   /* match is for directives that should be recognized only if
 854      -fopenmp, matchs for directives that should be recognized
 855      if either -fopenmp or -fopenmp-simd.
 856      Handle only the directives allowed in PURE procedures
 857      first (those also shall not turn off implicit pure).  */
 858   switch (c)
 859     {
 860     case 'd':
 861       matchds ("declare simd", gfc_match_omp_declare_simd,
 862                ST_OMP_DECLARE_SIMD);
 863       matchdo ("declare target", gfc_match_omp_declare_target,
 864                ST_OMP_DECLARE_TARGET);
 865       matchdo ("declare variant", gfc_match_omp_declare_variant,
 866                ST_OMP_DECLARE_VARIANT);
 867       break;
 868     case 's':
 869       matchs ("simd", gfc_match_omp_simd, ST_OMP_SIMD);
 870       break;
 871     }
 872
 873   pure_ok = false;
 874   if (flag_openmp && gfc_pure (NULL))
 875     {
 876       gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
 877                      "at %C may not appear in PURE procedures");
 878       gfc_error_recovery ();
 879       return ST_NONE;
 880     }
 881
 882   /* match is for directives that should be recognized only if
 883      -fopenmp, matchs for directives that should be recognized
 884      if either -fopenmp or -fopenmp-simd.  */
 885   switch (c)
 886     {
 887     case 'a':
 888       matcho ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
 889       break;
 890     case 'b':
 891       matcho ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
 892       break;
 893     case 'c':
 894       matcho ("cancellation% point", gfc_match_omp_cancellation_point,
 895               ST_OMP_CANCELLATION_POINT);
 896       matcho ("cancel", gfc_match_omp_cancel, ST_OMP_CANCEL);
 897       matcho ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
 898       break;
 899     case 'd':
 900       matchds ("declare reduction", gfc_match_omp_declare_reduction,
 901                ST_OMP_DECLARE_REDUCTION);
 902       matcho ("depobj", gfc_match_omp_depobj, ST_OMP_DEPOBJ);
 903       matchs ("distribute parallel do simd",
 904               gfc_match_omp_distribute_parallel_do_simd,
 905               ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD);
 906       matcho ("distribute parallel do", gfc_match_omp_distribute_parallel_do,
 907               ST_OMP_DISTRIBUTE_PARALLEL_DO);
 908       matchs ("distribute simd", gfc_match_omp_distribute_simd,
 909               ST_OMP_DISTRIBUTE_SIMD);
 910       matcho ("distribute", gfc_match_omp_distribute, ST_OMP_DISTRIBUTE);
 911       matchs ("do simd", gfc_match_omp_do_simd, ST_OMP_DO_SIMD);
 912       matcho ("do", gfc_match_omp_do, ST_OMP_DO);
 913       break;
 914     case 'e':
 915       matcho ("error", gfc_match_omp_error, ST_OMP_ERROR);
 916       matcho ("end atomic", gfc_match_omp_eos_error, ST_OMP_END_ATOMIC);
 917       matcho ("end critical", gfc_match_omp_end_critical, ST_OMP_END_CRITICAL);
 918       matchs ("end distribute parallel do simd", gfc_match_omp_eos_error,
 919               ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD);
 920       matcho ("end distribute parallel do", gfc_match_omp_eos_error,
 921               ST_OMP_END_DISTRIBUTE_PARALLEL_DO);
 922       matchs ("end distribute simd", gfc_match_omp_eos_error,
 923               ST_OMP_END_DISTRIBUTE_SIMD);
 924       matcho ("end distribute", gfc_match_omp_eos_error, ST_OMP_END_DISTRIBUTE);
 925       matchs ("end do simd", gfc_match_omp_end_nowait, ST_OMP_END_DO_SIMD);
 926       matcho ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
 927       matcho ("end loop", gfc_match_omp_eos_error, ST_OMP_END_LOOP);
 928       matchs ("end simd", gfc_match_omp_eos_error, ST_OMP_END_SIMD);
 929       matcho ("end masked taskloop simd", gfc_match_omp_eos_error,
 930               ST_OMP_END_MASKED_TASKLOOP_SIMD);
 931       matcho ("end masked taskloop", gfc_match_omp_eos_error,
 932               ST_OMP_END_MASKED_TASKLOOP);
 933       matcho ("end masked", gfc_match_omp_eos_error, ST_OMP_END_MASKED);
 934       matcho ("end master taskloop simd", gfc_match_omp_eos_error,
 935               ST_OMP_END_MASTER_TASKLOOP_SIMD);
 936       matcho ("end master taskloop", gfc_match_omp_eos_error,
 937               ST_OMP_END_MASTER_TASKLOOP);
 938       matcho ("end master", gfc_match_omp_eos_error, ST_OMP_END_MASTER);
 939       matchs ("end ordered", gfc_match_omp_eos_error, ST_OMP_END_ORDERED);
 940       matchs ("end parallel do simd", gfc_match_omp_eos_error,
 941               ST_OMP_END_PARALLEL_DO_SIMD);
 942       matcho ("end parallel do", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL_DO);
 943       matcho ("end parallel loop", gfc_match_omp_eos_error,
 944               ST_OMP_END_PARALLEL_LOOP);
 945       matcho ("end parallel masked taskloop simd", gfc_match_omp_eos_error,
 946               ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD);
 947       matcho ("end parallel masked taskloop", gfc_match_omp_eos_error,
 948               ST_OMP_END_PARALLEL_MASKED_TASKLOOP);
 949       matcho ("end parallel masked", gfc_match_omp_eos_error,
 950               ST_OMP_END_PARALLEL_MASKED);
 951       matcho ("end parallel master taskloop simd", gfc_match_omp_eos_error,
 952               ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD);
 953       matcho ("end parallel master taskloop", gfc_match_omp_eos_error,
 954               ST_OMP_END_PARALLEL_MASTER_TASKLOOP);
 955       matcho ("end parallel master", gfc_match_omp_eos_error,
 956               ST_OMP_END_PARALLEL_MASTER);
 957       matcho ("end parallel sections", gfc_match_omp_eos_error,
 958               ST_OMP_END_PARALLEL_SECTIONS);
 959       matcho ("end parallel workshare", gfc_match_omp_eos_error,
 960               ST_OMP_END_PARALLEL_WORKSHARE);
 961       matcho ("end parallel", gfc_match_omp_eos_error, ST_OMP_END_PARALLEL);
 962       matcho ("end scope", gfc_match_omp_end_nowait, ST_OMP_END_SCOPE);
 963       matcho ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
 964       matcho ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
 965       matcho ("end target data", gfc_match_omp_eos_error, ST_OMP_END_TARGET_DATA);
 966       matchs ("end target parallel do simd", gfc_match_omp_end_nowait,
 967               ST_OMP_END_TARGET_PARALLEL_DO_SIMD);
 968       matcho ("end target parallel do", gfc_match_omp_end_nowait,
 969               ST_OMP_END_TARGET_PARALLEL_DO);
 970       matcho ("end target parallel loop", gfc_match_omp_end_nowait,
 971               ST_OMP_END_TARGET_PARALLEL_LOOP);
 972       matcho ("end target parallel", gfc_match_omp_end_nowait,
 973               ST_OMP_END_TARGET_PARALLEL);
 974       matchs ("end target simd", gfc_match_omp_end_nowait, ST_OMP_END_TARGET_SIMD);
 975       matchs ("end target teams distribute parallel do simd",
 976               gfc_match_omp_end_nowait,
 977               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
 978       matcho ("end target teams distribute parallel do", gfc_match_omp_end_nowait,
 979               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
 980       matchs ("end target teams distribute simd", gfc_match_omp_end_nowait,
 981               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD);
 982       matcho ("end target teams distribute", gfc_match_omp_end_nowait,
 983               ST_OMP_END_TARGET_TEAMS_DISTRIBUTE);
 984       matcho ("end target teams loop", gfc_match_omp_end_nowait,
 985               ST_OMP_END_TARGET_TEAMS_LOOP);
 986       matcho ("end target teams", gfc_match_omp_end_nowait,
 987               ST_OMP_END_TARGET_TEAMS);
 988       matcho ("end target", gfc_match_omp_end_nowait, ST_OMP_END_TARGET);
 989       matcho ("end taskgroup", gfc_match_omp_eos_error, ST_OMP_END_TASKGROUP);
 990       matchs ("end taskloop simd", gfc_match_omp_eos_error,
 991               ST_OMP_END_TASKLOOP_SIMD);
 992       matcho ("end taskloop", gfc_match_omp_eos_error, ST_OMP_END_TASKLOOP);
 993       matcho ("end task", gfc_match_omp_eos_error, ST_OMP_END_TASK);
 994       matchs ("end teams distribute parallel do simd", gfc_match_omp_eos_error,
 995               ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
 996       matcho ("end teams distribute parallel do", gfc_match_omp_eos_error,
 997               ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO);
 998       matchs ("end teams distribute simd", gfc_match_omp_eos_error,
 999               ST_OMP_END_TEAMS_DISTRIBUTE_SIMD);
1000       matcho ("end teams distribute", gfc_match_omp_eos_error,
1001               ST_OMP_END_TEAMS_DISTRIBUTE);
1002       matcho ("end teams loop", gfc_match_omp_eos_error, ST_OMP_END_TEAMS_LOOP);
1003       matcho ("end teams", gfc_match_omp_eos_error, ST_OMP_END_TEAMS);
1004       matcho ("end workshare", gfc_match_omp_end_nowait,
1005               ST_OMP_END_WORKSHARE);
1006       break;
1007     case 'f':
1008       matcho ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
1009       break;
1010     case 'm':
1011       matcho ("masked taskloop simd", gfc_match_omp_masked_taskloop_simd,
1012               ST_OMP_MASKED_TASKLOOP_SIMD);
1013       matcho ("masked taskloop", gfc_match_omp_masked_taskloop,
1014               ST_OMP_MASKED_TASKLOOP);
1015       matcho ("masked", gfc_match_omp_masked, ST_OMP_MASKED);
1016       matcho ("master taskloop simd", gfc_match_omp_master_taskloop_simd,
1017               ST_OMP_MASTER_TASKLOOP_SIMD);
1018       matcho ("master taskloop", gfc_match_omp_master_taskloop,
1019               ST_OMP_MASTER_TASKLOOP);
1020       matcho ("master", gfc_match_omp_master, ST_OMP_MASTER);
1021       break;
1022     case 'n':
1023       matcho ("nothing", gfc_match_omp_nothing, ST_NONE);
1024       break;
1025     case 'l':
1026       matcho ("loop", gfc_match_omp_loop, ST_OMP_LOOP);
1027       break;
1028     case 'o':
1029       if (gfc_match ("ordered depend (") == MATCH_YES)
1030         {
1031           gfc_current_locus = old_locus;
1032           if (!flag_openmp)
1033             break;
1034           matcho ("ordered", gfc_match_omp_ordered_depend,
1035                   ST_OMP_ORDERED_DEPEND);
1036         }
1037       else
1038         matchs ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
1039       break;
1040     case 'p':
1041       matchs ("parallel do simd", gfc_match_omp_parallel_do_simd,
1042               ST_OMP_PARALLEL_DO_SIMD);
1043       matcho ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
1044       matcho ("parallel loop", gfc_match_omp_parallel_loop,
1045               ST_OMP_PARALLEL_LOOP);
1046       matcho ("parallel masked taskloop simd",
1047               gfc_match_omp_parallel_masked_taskloop_simd,
1048               ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD);
1049       matcho ("parallel masked taskloop",
1050               gfc_match_omp_parallel_masked_taskloop,
1051               ST_OMP_PARALLEL_MASKED_TASKLOOP);
1052       matcho ("parallel masked", gfc_match_omp_parallel_masked,
1053               ST_OMP_PARALLEL_MASKED);
1054       matcho ("parallel master taskloop simd",
1055               gfc_match_omp_parallel_master_taskloop_simd,
1056               ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD);
1057       matcho ("parallel master taskloop",
1058               gfc_match_omp_parallel_master_taskloop,
1059               ST_OMP_PARALLEL_MASTER_TASKLOOP);
1060       matcho ("parallel master", gfc_match_omp_parallel_master,
1061               ST_OMP_PARALLEL_MASTER);
1062       matcho ("parallel sections", gfc_match_omp_parallel_sections,
1063               ST_OMP_PARALLEL_SECTIONS);
1064       matcho ("parallel workshare", gfc_match_omp_parallel_workshare,
1065               ST_OMP_PARALLEL_WORKSHARE);
1066       matcho ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
1067       break;
1068     case 'r':
1069       matcho ("requires", gfc_match_omp_requires, ST_OMP_REQUIRES);
1070       break;
1071     case 's':
1072       matcho ("scan", gfc_match_omp_scan, ST_OMP_SCAN);
1073       matcho ("scope", gfc_match_omp_scope, ST_OMP_SCOPE);
1074       matcho ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
1075       matcho ("section", gfc_match_omp_eos_error, ST_OMP_SECTION);
1076       matcho ("single", gfc_match_omp_single, ST_OMP_SINGLE);
1077       break;
1078     case 't':
1079       matcho ("target data", gfc_match_omp_target_data, ST_OMP_TARGET_DATA);
1080       matcho ("target enter data", gfc_match_omp_target_enter_data,
1081               ST_OMP_TARGET_ENTER_DATA);
1082       matcho ("target exit data", gfc_match_omp_target_exit_data,
1083               ST_OMP_TARGET_EXIT_DATA);
1084       matchs ("target parallel do simd", gfc_match_omp_target_parallel_do_simd,
1085               ST_OMP_TARGET_PARALLEL_DO_SIMD);
1086       matcho ("target parallel do", gfc_match_omp_target_parallel_do,
1087               ST_OMP_TARGET_PARALLEL_DO);
1088       matcho ("target parallel loop", gfc_match_omp_target_parallel_loop,
1089               ST_OMP_TARGET_PARALLEL_LOOP);
1090       matcho ("target parallel", gfc_match_omp_target_parallel,
1091               ST_OMP_TARGET_PARALLEL);
1092       matchs ("target simd", gfc_match_omp_target_simd, ST_OMP_TARGET_SIMD);
1093       matchs ("target teams distribute parallel do simd",
1094               gfc_match_omp_target_teams_distribute_parallel_do_simd,
1095               ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
1096       matcho ("target teams distribute parallel do",
1097               gfc_match_omp_target_teams_distribute_parallel_do,
1098               ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO);
1099       matchs ("target teams distribute simd",
1100               gfc_match_omp_target_teams_distribute_simd,
1101               ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD);
1102       matcho ("target teams distribute", gfc_match_omp_target_teams_distribute,
1103               ST_OMP_TARGET_TEAMS_DISTRIBUTE);
1104       matcho ("target teams loop", gfc_match_omp_target_teams_loop,
1105               ST_OMP_TARGET_TEAMS_LOOP);
1106       matcho ("target teams", gfc_match_omp_target_teams, ST_OMP_TARGET_TEAMS);
1107       matcho ("target update", gfc_match_omp_target_update,
1108               ST_OMP_TARGET_UPDATE);
1109       matcho ("target", gfc_match_omp_target, ST_OMP_TARGET);
1110       matcho ("taskgroup", gfc_match_omp_taskgroup, ST_OMP_TASKGROUP);
1111       matchs ("taskloop simd", gfc_match_omp_taskloop_simd,
1112               ST_OMP_TASKLOOP_SIMD);
1113       matcho ("taskloop", gfc_match_omp_taskloop, ST_OMP_TASKLOOP);
1114       matcho ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
1115       matcho ("taskyield", gfc_match_omp_taskyield, ST_OMP_TASKYIELD);
1116       matcho ("task", gfc_match_omp_task, ST_OMP_TASK);
1117       matchs ("teams distribute parallel do simd",
1118               gfc_match_omp_teams_distribute_parallel_do_simd,
1119               ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD);
1120       matcho ("teams distribute parallel do",
1121               gfc_match_omp_teams_distribute_parallel_do,
1122               ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO);
1123       matchs ("teams distribute simd", gfc_match_omp_teams_distribute_simd,
1124               ST_OMP_TEAMS_DISTRIBUTE_SIMD);
1125       matcho ("teams distribute", gfc_match_omp_teams_distribute,
1126               ST_OMP_TEAMS_DISTRIBUTE);
1127       matcho ("teams loop", gfc_match_omp_teams_loop, ST_OMP_TEAMS_LOOP);
1128       matcho ("teams", gfc_match_omp_teams, ST_OMP_TEAMS);
1129       matchdo ("threadprivate", gfc_match_omp_threadprivate,
1130                ST_OMP_THREADPRIVATE);
1131       break;
1132     case 'w':
1133       matcho ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
1134       break;
1135     }
1136
1137   /* All else has failed, so give up.  See if any of the matchers has
1138      stored an error message of some sort.  Don't error out if
1139      not -fopenmp and simd_matched is false, i.e. if a directive other
1140      than one marked with match has been seen.  */
1141
1142  error_handling:
1143   if (flag_openmp || simd_matched)
1144     {
1145       if (!gfc_error_check ())
1146         gfc_error_now ("Unclassifiable OpenMP directive at %C");
1147     }
1148
1149   reject_statement ();
1150
1151   gfc_error_recovery ();
1152
1153   return ST_NONE;
1154
1155  finish:
1156   if (!pure_ok)
1157     {
1158       gfc_unset_implicit_pure (NULL);
1159
1160       if (!flag_openmp && gfc_pure (NULL))
1161         {
1162           gfc_error_now ("OpenMP directives other than SIMD or DECLARE TARGET "
1163                          "at %C may not appear in PURE procedures");
1164           reject_statement ();
1165           gfc_error_recovery ();
1166           return ST_NONE;
1167         }
1168     }
1169   switch (ret)
1170     {
1171     case ST_OMP_DECLARE_TARGET:
1172     case ST_OMP_TARGET:
1173     case ST_OMP_TARGET_DATA:
1174     case ST_OMP_TARGET_ENTER_DATA:
1175     case ST_OMP_TARGET_EXIT_DATA:
1176     case ST_OMP_TARGET_TEAMS:
1177     case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
1178     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
1179     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
1180     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
1181     case ST_OMP_TARGET_TEAMS_LOOP:
1182     case ST_OMP_TARGET_PARALLEL:
1183     case ST_OMP_TARGET_PARALLEL_DO:
1184     case ST_OMP_TARGET_PARALLEL_DO_SIMD:
1185     case ST_OMP_TARGET_PARALLEL_LOOP:
1186     case ST_OMP_TARGET_SIMD:
1187     case ST_OMP_TARGET_UPDATE:
1188       {
1189         gfc_namespace *prog_unit = gfc_current_ns;
1190         while (prog_unit->parent)
1191           {
1192             if (gfc_state_stack->previous
1193                 && gfc_state_stack->previous->state == COMP_INTERFACE)
1194               break;
1195             prog_unit = prog_unit->parent;
1196           }
1197           prog_unit->omp_target_seen = true;
1198         break;
1199       }
1200     case ST_OMP_ERROR:
1201       if (new_st.ext.omp_clauses->at != OMP_AT_EXECUTION)
1202         return ST_NONE;
1203     default:
1204       break;
1205     }
1206   return ret;
1207
1208  do_spec_only:
1209   reject_statement ();
1210   gfc_clear_error ();
1211   gfc_buffer_error (false);
1212   gfc_current_locus = old_locus;
1213   return ST_GET_FCN_CHARACTERISTICS;
1214 }
1215
1216 static gfc_statement
1217 decode_gcc_attribute (void)
1218 {
1219   locus old_locus;
1220
1221   gfc_enforce_clean_symbol_state ();
1222
1223   gfc_clear_error ();   /* Clear any pending errors.  */
1224   gfc_clear_warning (); /* Clear any pending warnings.  */
1225   old_locus = gfc_current_locus;
1226
1227   match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
1228   match ("unroll", gfc_match_gcc_unroll, ST_NONE);
1229   match ("builtin", gfc_match_gcc_builtin, ST_NONE);
1230   match ("ivdep", gfc_match_gcc_ivdep, ST_NONE);
1231   match ("vector", gfc_match_gcc_vector, ST_NONE);
1232   match ("novector", gfc_match_gcc_novector, ST_NONE);
1233
1234   /* All else has failed, so give up.  See if any of the matchers has
1235      stored an error message of some sort.  */
1236
1237   if (!gfc_error_check ())
1238     {
1239       if (pedantic)
1240         gfc_error_now ("Unclassifiable GCC directive at %C");
1241       else
1242         gfc_warning_now (0, "Unclassifiable GCC directive at %C, ignored");
1243     }
1244
1245   reject_statement ();
1246
1247   gfc_error_recovery ();
1248
1249   return ST_NONE;
1250 }
1251
1252 #undef match
1253
1254 /* Assert next length characters to be equal to token in free form.  */
1255
1256 static void
1257 verify_token_free (const char* token, int length, bool last_was_use_stmt)
1258 {
1259   int i;
1260   char c;
1261
1262   c = gfc_next_ascii_char ();
1263   for (i = 0; i < length; i++, c = gfc_next_ascii_char ())
1264     gcc_assert (c == token[i]);
1265
1266   gcc_assert (gfc_is_whitespace(c));
1267   gfc_gobble_whitespace ();
1268   if (last_was_use_stmt)
1269     use_modules ();
1270 }
1271
1272 /* Get the next statement in free form source.  */
1273
1274 static gfc_statement
1275 next_free (void)
1276 {
1277   match m;
1278   int i, cnt, at_bol;
1279   char c;
1280
1281   at_bol = gfc_at_bol ();
1282   gfc_gobble_whitespace ();
1283
1284   c = gfc_peek_ascii_char ();
1285
1286   if (ISDIGIT (c))
1287     {
1288       char d;
1289
1290       /* Found a statement label?  */
1291       m = gfc_match_st_label (&gfc_statement_label);
1292
1293       d = gfc_peek_ascii_char ();
1294       if (m != MATCH_YES || !gfc_is_whitespace (d))
1295         {
1296           gfc_match_small_literal_int (&i, &cnt);
1297
1298           if (cnt > 5)
1299             gfc_error_now ("Too many digits in statement label at %C");
1300
1301           if (i == 0)
1302             gfc_error_now ("Zero is not a valid statement label at %C");
1303
1304           do
1305             c = gfc_next_ascii_char ();
1306           while (ISDIGIT(c));
1307
1308           if (!gfc_is_whitespace (c))
1309             gfc_error_now ("Non-numeric character in statement label at %C");
1310
1311           return ST_NONE;
1312         }
1313       else
1314         {
1315           label_locus = gfc_current_locus;
1316
1317           gfc_gobble_whitespace ();
1318
1319           if (at_bol && gfc_peek_ascii_char () == ';')
1320             {
1321               gfc_error_now ("Semicolon at %C needs to be preceded by "
1322                              "statement");
1323               gfc_next_ascii_char (); /* Eat up the semicolon.  */
1324               return ST_NONE;
1325             }
1326
1327           if (gfc_match_eos () == MATCH_YES)
1328             gfc_error_now ("Statement label without statement at %L",
1329                            &label_locus);
1330         }
1331     }
1332   else if (c == '!')
1333     {
1334       /* Comments have already been skipped by the time we get here,
1335          except for GCC attributes and OpenMP/OpenACC directives.  */
1336
1337       gfc_next_ascii_char (); /* Eat up the exclamation sign.  */
1338       c = gfc_peek_ascii_char ();
1339
1340       if (c == 'g')
1341         {
1342           int i;
1343
1344           c = gfc_next_ascii_char ();
1345           for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
1346             gcc_assert (c == "gcc$"[i]);
1347
1348           gfc_gobble_whitespace ();
1349           return decode_gcc_attribute ();
1350
1351         }
1352       else if (c == '$')
1353         {
1354           /* Since both OpenMP and OpenACC directives starts with
1355              !$ character sequence, we must check all flags combinations */
1356           if ((flag_openmp || flag_openmp_simd)
1357               && !flag_openacc)
1358             {
1359               verify_token_free ("$omp", 4, last_was_use_stmt);
1360               return decode_omp_directive ();
1361             }
1362           else if ((flag_openmp || flag_openmp_simd)
1363                    && flag_openacc)
1364             {
1365               gfc_next_ascii_char (); /* Eat up dollar character */
1366               c = gfc_peek_ascii_char ();
1367
1368               if (c == 'o')
1369                 {
1370                   verify_token_free ("omp", 3, last_was_use_stmt);
1371                   return decode_omp_directive ();
1372                 }
1373               else if (c == 'a')
1374                 {
1375                   verify_token_free ("acc", 3, last_was_use_stmt);
1376                   return decode_oacc_directive ();
1377                 }
1378             }
1379           else if (flag_openacc)
1380             {
1381               verify_token_free ("$acc", 4, last_was_use_stmt);
1382               return decode_oacc_directive ();
1383             }
1384         }
1385       gcc_unreachable ();
1386     }
1387
1388   if (at_bol && c == ';')
1389     {
1390       if (!(gfc_option.allow_std & GFC_STD_F2008))
1391         gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1392                        "statement");
1393       gfc_next_ascii_char (); /* Eat up the semicolon.  */
1394       return ST_NONE;
1395     }
1396
1397   return decode_statement ();
1398 }
1399
1400 /* Assert next length characters to be equal to token in fixed form.  */
1401
1402 static bool
1403 verify_token_fixed (const char *token, int length, bool last_was_use_stmt)
1404 {
1405   int i;
1406   char c = gfc_next_char_literal (NONSTRING);
1407
1408   for (i = 0; i < length; i++, c = gfc_next_char_literal (NONSTRING))
1409     gcc_assert ((char) gfc_wide_tolower (c) == token[i]);
1410
1411   if (c != ' ' && c != '0')
1412     {
1413       gfc_buffer_error (false);
1414       gfc_error ("Bad continuation line at %C");
1415       return false;
1416     }
1417   if (last_was_use_stmt)
1418     use_modules ();
1419
1420   return true;
1421 }
1422
1423 /* Get the next statement in fixed-form source.  */
1424
1425 static gfc_statement
1426 next_fixed (void)
1427 {
1428   int label, digit_flag, i;
1429   locus loc;
1430   gfc_char_t c;
1431
1432   if (!gfc_at_bol ())
1433     return decode_statement ();
1434
1435   /* Skip past the current label field, parsing a statement label if
1436      one is there.  This is a weird number parser, since the number is
1437      contained within five columns and can have any kind of embedded
1438      spaces.  We also check for characters that make the rest of the
1439      line a comment.  */
1440
1441   label = 0;
1442   digit_flag = 0;
1443
1444   for (i = 0; i < 5; i++)
1445     {
1446       c = gfc_next_char_literal (NONSTRING);
1447
1448       switch (c)
1449         {
1450         case ' ':
1451           break;
1452
1453         case '0':
1454         case '1':
1455         case '2':
1456         case '3':
1457         case '4':
1458         case '5':
1459         case '6':
1460         case '7':
1461         case '8':
1462         case '9':
1463           label = label * 10 + ((unsigned char) c - '0');
1464           label_locus = gfc_current_locus;
1465           digit_flag = 1;
1466           break;
1467
1468           /* Comments have already been skipped by the time we get
1469              here, except for GCC attributes and OpenMP directives.  */
1470
1471         case '*':
1472           c = gfc_next_char_literal (NONSTRING);
1473
1474           if (TOLOWER (c) == 'g')
1475             {
1476               for (i = 0; i < 4; i++, c = gfc_next_char_literal (NONSTRING))
1477                 gcc_assert (TOLOWER (c) == "gcc$"[i]);
1478
1479               return decode_gcc_attribute ();
1480             }
1481           else if (c == '$')
1482             {
1483               if ((flag_openmp || flag_openmp_simd)
1484                   && !flag_openacc)
1485                 {
1486                   if (!verify_token_fixed ("omp", 3, last_was_use_stmt))
1487                     return ST_NONE;
1488                   return decode_omp_directive ();
1489                 }
1490               else if ((flag_openmp || flag_openmp_simd)
1491                        && flag_openacc)
1492                 {
1493                   c = gfc_next_char_literal(NONSTRING);
1494                   if (c == 'o' || c == 'O')
1495                     {
1496                       if (!verify_token_fixed ("mp", 2, last_was_use_stmt))
1497                         return ST_NONE;
1498                       return decode_omp_directive ();
1499                     }
1500                   else if (c == 'a' || c == 'A')
1501                     {
1502                       if (!verify_token_fixed ("cc", 2, last_was_use_stmt))
1503                         return ST_NONE;
1504                       return decode_oacc_directive ();
1505                     }
1506                 }
1507               else if (flag_openacc)
1508                 {
1509                   if (!verify_token_fixed ("acc", 3, last_was_use_stmt))
1510                     return ST_NONE;
1511                   return decode_oacc_directive ();
1512                 }
1513             }
1514           gcc_fallthrough ();
1515
1516           /* Comments have already been skipped by the time we get
1517              here so don't bother checking for them.  */
1518
1519         default:
1520           gfc_buffer_error (false);
1521           gfc_error ("Non-numeric character in statement label at %C");
1522           return ST_NONE;
1523         }
1524     }
1525
1526   if (digit_flag)
1527     {
1528       if (label == 0)
1529         gfc_warning_now (0, "Zero is not a valid statement label at %C");
1530       else
1531         {
1532           /* We've found a valid statement label.  */
1533           gfc_statement_label = gfc_get_st_label (label);
1534         }
1535     }
1536
1537   /* Since this line starts a statement, it cannot be a continuation
1538      of a previous statement.  If we see something here besides a
1539      space or zero, it must be a bad continuation line.  */
1540
1541   c = gfc_next_char_literal (NONSTRING);
1542   if (c == '\n')
1543     goto blank_line;
1544
1545   if (c != ' ' && c != '0')
1546     {
1547       gfc_buffer_error (false);
1548       gfc_error ("Bad continuation line at %C");
1549       return ST_NONE;
1550     }
1551
1552   /* Now that we've taken care of the statement label columns, we have
1553      to make sure that the first nonblank character is not a '!'.  If
1554      it is, the rest of the line is a comment.  */
1555
1556   do
1557     {
1558       loc = gfc_current_locus;
1559       c = gfc_next_char_literal (NONSTRING);
1560     }
1561   while (gfc_is_whitespace (c));
1562
1563   if (c == '!')
1564     goto blank_line;
1565   gfc_current_locus = loc;
1566
1567   if (c == ';')
1568     {
1569       if (digit_flag)
1570         gfc_error_now ("Semicolon at %C needs to be preceded by statement");
1571       else if (!(gfc_option.allow_std & GFC_STD_F2008))
1572         gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
1573                        "statement");
1574       return ST_NONE;
1575     }
1576
1577   if (gfc_match_eos () == MATCH_YES)
1578     goto blank_line;
1579
1580   /* At this point, we've got a nonblank statement to parse.  */
1581   return decode_statement ();
1582
1583 blank_line:
1584   if (digit_flag)
1585     gfc_error_now ("Statement label without statement at %L", &label_locus);
1586
1587   gfc_current_locus.lb->truncated = 0;
1588   gfc_advance_line ();
1589   return ST_NONE;
1590 }
1591
1592
1593 /* Return the next non-ST_NONE statement to the caller.  We also worry
1594    about including files and the ends of include files at this stage.  */
1595
1596 static gfc_statement
1597 next_statement (void)
1598 {
1599   gfc_statement st;
1600   locus old_locus;
1601
1602   gfc_enforce_clean_symbol_state ();
1603
1604   gfc_new_block = NULL;
1605
1606   gfc_current_ns->old_equiv = gfc_current_ns->equiv;
1607   gfc_current_ns->old_data = gfc_current_ns->data;
1608   for (;;)
1609     {
1610       gfc_statement_label = NULL;
1611       gfc_buffer_error (true);
1612
1613       if (gfc_at_eol ())
1614         gfc_advance_line ();
1615
1616       gfc_skip_comments ();
1617
1618       if (gfc_at_end ())
1619         {
1620           st = ST_NONE;
1621           break;
1622         }
1623
1624       if (gfc_define_undef_line ())
1625         continue;
1626
1627       old_locus = gfc_current_locus;
1628
1629       st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
1630
1631       if (st != ST_NONE)
1632         break;
1633     }
1634
1635   gfc_buffer_error (false);
1636
1637   if (st == ST_GET_FCN_CHARACTERISTICS)
1638     {
1639       if (gfc_statement_label != NULL)
1640         {
1641           gfc_free_st_label (gfc_statement_label);
1642           gfc_statement_label = NULL;
1643         }
1644       gfc_current_locus = old_locus;
1645     }
1646
1647   if (st != ST_NONE)
1648     check_statement_label (st);
1649
1650   return st;
1651 }
1652
1653
1654 /****************************** Parser ***********************************/
1655
1656 /* The parser subroutines are of type 'try' that fail if the file ends
1657    unexpectedly.  */
1658
1659 /* Macros that expand to case-labels for various classes of
1660    statements.  Start with executable statements that directly do
1661    things.  */
1662
1663 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
1664   case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
1665   case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
1666   case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
1667   case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
1668   case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
1669   case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
1670   case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
1671   case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_OMP_TASKYIELD: \
1672   case ST_OMP_CANCEL: case ST_OMP_CANCELLATION_POINT: case ST_OMP_DEPOBJ: \
1673   case ST_OMP_TARGET_UPDATE: case ST_OMP_TARGET_ENTER_DATA: \
1674   case ST_OMP_TARGET_EXIT_DATA: case ST_OMP_ORDERED_DEPEND: case ST_OMP_ERROR: \
1675   case ST_ERROR_STOP: case ST_OMP_SCAN: case ST_SYNC_ALL: \
1676   case ST_SYNC_IMAGES: case ST_SYNC_MEMORY: case ST_LOCK: case ST_UNLOCK: \
1677   case ST_FORM_TEAM: case ST_CHANGE_TEAM: \
1678   case ST_END_TEAM: case ST_SYNC_TEAM: \
1679   case ST_EVENT_POST: case ST_EVENT_WAIT: case ST_FAIL_IMAGE: \
1680   case ST_OACC_UPDATE: case ST_OACC_WAIT: case ST_OACC_CACHE: \
1681   case ST_OACC_ENTER_DATA: case ST_OACC_EXIT_DATA
1682
1683 /* Statements that mark other executable statements.  */
1684
1685 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
1686   case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
1687   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
1688   case ST_SELECT_RANK: case ST_OMP_PARALLEL: case ST_OMP_PARALLEL_MASKED: \
1689   case ST_OMP_PARALLEL_MASKED_TASKLOOP: \
1690   case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD: case ST_OMP_PARALLEL_MASTER: \
1691   case ST_OMP_PARALLEL_MASTER_TASKLOOP: \
1692   case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD: \
1693   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
1694   case ST_OMP_CRITICAL: case ST_OMP_MASKED: case ST_OMP_MASKED_TASKLOOP: \
1695   case ST_OMP_MASKED_TASKLOOP_SIMD: \
1696   case ST_OMP_MASTER: case ST_OMP_MASTER_TASKLOOP: \
1697   case ST_OMP_MASTER_TASKLOOP_SIMD: case ST_OMP_SCOPE: case ST_OMP_SINGLE: \
1698   case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
1699   case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
1700   case ST_OMP_TASK: case ST_OMP_TASKGROUP: case ST_OMP_SIMD: \
1701   case ST_OMP_DO_SIMD: case ST_OMP_PARALLEL_DO_SIMD: case ST_OMP_TARGET: \
1702   case ST_OMP_TARGET_DATA: case ST_OMP_TARGET_TEAMS: \
1703   case ST_OMP_TARGET_TEAMS_DISTRIBUTE: \
1704   case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD: \
1705   case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1706   case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: \
1707   case ST_OMP_TEAMS: case ST_OMP_TEAMS_DISTRIBUTE: \
1708   case ST_OMP_TEAMS_DISTRIBUTE_SIMD: \
1709   case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO: \
1710   case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_DISTRIBUTE: \
1711   case ST_OMP_DISTRIBUTE_SIMD: case ST_OMP_DISTRIBUTE_PARALLEL_DO: \
1712   case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD: case ST_OMP_TARGET_PARALLEL: \
1713   case ST_OMP_TARGET_PARALLEL_DO: case ST_OMP_TARGET_PARALLEL_DO_SIMD: \
1714   case ST_OMP_TARGET_SIMD: case ST_OMP_TASKLOOP: case ST_OMP_TASKLOOP_SIMD: \
1715   case ST_OMP_LOOP: case ST_OMP_PARALLEL_LOOP: case ST_OMP_TEAMS_LOOP: \
1716   case ST_OMP_TARGET_PARALLEL_LOOP: case ST_OMP_TARGET_TEAMS_LOOP: \
1717   case ST_CRITICAL: \
1718   case ST_OACC_PARALLEL_LOOP: case ST_OACC_PARALLEL: case ST_OACC_KERNELS: \
1719   case ST_OACC_DATA: case ST_OACC_HOST_DATA: case ST_OACC_LOOP: \
1720   case ST_OACC_KERNELS_LOOP: case ST_OACC_SERIAL_LOOP: case ST_OACC_SERIAL: \
1721   case ST_OACC_ATOMIC
1722
1723 /* Declaration statements */
1724
1725 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
1726   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
1727   case ST_TYPE: case ST_INTERFACE: case ST_PROCEDURE
1728
1729 /* OpenMP and OpenACC declaration statements, which may appear anywhere in
1730    the specification part.  */
1731
1732 #define case_omp_decl case ST_OMP_THREADPRIVATE: case ST_OMP_DECLARE_SIMD: \
1733   case ST_OMP_DECLARE_TARGET: case ST_OMP_DECLARE_REDUCTION: \
1734   case ST_OMP_DECLARE_VARIANT: \
1735   case ST_OMP_REQUIRES: case ST_OACC_ROUTINE: case ST_OACC_DECLARE
1736
1737 /* Block end statements.  Errors associated with interchanging these
1738    are detected in gfc_match_end().  */
1739
1740 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
1741                  case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
1742                  case ST_END_BLOCK: case ST_END_ASSOCIATE
1743
1744
1745 /* Push a new state onto the stack.  */
1746
1747 static void
1748 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
1749 {
1750   p->state = new_state;
1751   p->previous = gfc_state_stack;
1752   p->sym = sym;
1753   p->head = p->tail = NULL;
1754   p->do_variable = NULL;
1755   if (p->state != COMP_DO && p->state != COMP_DO_CONCURRENT)
1756     p->ext.oacc_declare_clauses = NULL;
1757
1758   /* If this the state of a construct like BLOCK, DO or IF, the corresponding
1759      construct statement was accepted right before pushing the state.  Thus,
1760      the construct's gfc_code is available as tail of the parent state.  */
1761   gcc_assert (gfc_state_stack);
1762   p->construct = gfc_state_stack->tail;
1763
1764   gfc_state_stack = p;
1765 }
1766
1767
1768 /* Pop the current state.  */
1769 static void
1770 pop_state (void)
1771 {
1772   gfc_state_stack = gfc_state_stack->previous;
1773 }
1774
1775
1776 /* Try to find the given state in the state stack.  */
1777
1778 bool
1779 gfc_find_state (gfc_compile_state state)
1780 {
1781   gfc_state_data *p;
1782
1783   for (p = gfc_state_stack; p; p = p->previous)
1784     if (p->state == state)
1785       break;
1786
1787   return (p == NULL) ? false : true;
1788 }
1789
1790
1791 /* Starts a new level in the statement list.  */
1792
1793 static gfc_code *
1794 new_level (gfc_code *q)
1795 {
1796   gfc_code *p;
1797
1798   p = q->block = gfc_get_code (EXEC_NOP);
1799
1800   gfc_state_stack->head = gfc_state_stack->tail = p;
1801
1802   return p;
1803 }
1804
1805
1806 /* Add the current new_st code structure and adds it to the current
1807    program unit.  As a side-effect, it zeroes the new_st.  */
1808
1809 static gfc_code *
1810 add_statement (void)
1811 {
1812   gfc_code *p;
1813
1814   p = XCNEW (gfc_code);
1815   *p = new_st;
1816
1817   p->loc = gfc_current_locus;
1818
1819   if (gfc_state_stack->head == NULL)
1820     gfc_state_stack->head = p;
1821   else
1822     gfc_state_stack->tail->next = p;
1823
1824   while (p->next != NULL)
1825     p = p->next;
1826
1827   gfc_state_stack->tail = p;
1828
1829   gfc_clear_new_st ();
1830
1831   return p;
1832 }
1833
1834
1835 /* Frees everything associated with the current statement.  */
1836
1837 static void
1838 undo_new_statement (void)
1839 {
1840   gfc_free_statements (new_st.block);
1841   gfc_free_statements (new_st.next);
1842   gfc_free_statement (&new_st);
1843   gfc_clear_new_st ();
1844 }
1845
1846
1847 /* If the current statement has a statement label, make sure that it
1848    is allowed to, or should have one.  */
1849
1850 static void
1851 check_statement_label (gfc_statement st)
1852 {
1853   gfc_sl_type type;
1854
1855   if (gfc_statement_label == NULL)
1856     {
1857       if (st == ST_FORMAT)
1858         gfc_error ("FORMAT statement at %L does not have a statement label",
1859                    &new_st.loc);
1860       return;
1861     }
1862
1863   switch (st)
1864     {
1865     case ST_END_PROGRAM:
1866     case ST_END_FUNCTION:
1867     case ST_END_SUBROUTINE:
1868     case ST_ENDDO:
1869     case ST_ENDIF:
1870     case ST_END_SELECT:
1871     case ST_END_CRITICAL:
1872     case ST_END_BLOCK:
1873     case ST_END_ASSOCIATE:
1874     case_executable:
1875     case_exec_markers:
1876       if (st == ST_ENDDO || st == ST_CONTINUE)
1877         type = ST_LABEL_DO_TARGET;
1878       else
1879         type = ST_LABEL_TARGET;
1880       break;
1881
1882     case ST_FORMAT:
1883       type = ST_LABEL_FORMAT;
1884       break;
1885
1886       /* Statement labels are not restricted from appearing on a
1887          particular line.  However, there are plenty of situations
1888          where the resulting label can't be referenced.  */
1889
1890     default:
1891       type = ST_LABEL_BAD_TARGET;
1892       break;
1893     }
1894
1895   gfc_define_st_label (gfc_statement_label, type, &label_locus);
1896
1897   new_st.here = gfc_statement_label;
1898 }
1899
1900
1901 /* Figures out what the enclosing program unit is.  This will be a
1902    function, subroutine, program, block data or module.  */
1903
1904 gfc_state_data *
1905 gfc_enclosing_unit (gfc_compile_state * result)
1906 {
1907   gfc_state_data *p;
1908
1909   for (p = gfc_state_stack; p; p = p->previous)
1910     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1911         || p->state == COMP_MODULE || p->state == COMP_SUBMODULE
1912         || p->state == COMP_BLOCK_DATA || p->state == COMP_PROGRAM)
1913       {
1914
1915         if (result != NULL)
1916           *result = p->state;
1917         return p;
1918       }
1919
1920   if (result != NULL)
1921     *result = COMP_PROGRAM;
1922   return NULL;
1923 }
1924
1925
1926 /* Translate a statement enum to a string.  */
1927
1928 const char *
1929 gfc_ascii_statement (gfc_statement st)
1930 {
1931   const char *p;
1932
1933   switch (st)
1934     {
1935     case ST_ARITHMETIC_IF:
1936       p = _("arithmetic IF");
1937       break;
1938     case ST_ALLOCATE:
1939       p = "ALLOCATE";
1940       break;
1941     case ST_ASSOCIATE:
1942       p = "ASSOCIATE";
1943       break;
1944     case ST_ATTR_DECL:
1945       p = _("attribute declaration");
1946       break;
1947     case ST_BACKSPACE:
1948       p = "BACKSPACE";
1949       break;
1950     case ST_BLOCK:
1951       p = "BLOCK";
1952       break;
1953     case ST_BLOCK_DATA:
1954       p = "BLOCK DATA";
1955       break;
1956     case ST_CALL:
1957       p = "CALL";
1958       break;
1959     case ST_CASE:
1960       p = "CASE";
1961       break;
1962     case ST_CLOSE:
1963       p = "CLOSE";
1964       break;
1965     case ST_COMMON:
1966       p = "COMMON";
1967       break;
1968     case ST_CONTINUE:
1969       p = "CONTINUE";
1970       break;
1971     case ST_CONTAINS:
1972       p = "CONTAINS";
1973       break;
1974     case ST_CRITICAL:
1975       p = "CRITICAL";
1976       break;
1977     case ST_CYCLE:
1978       p = "CYCLE";
1979       break;
1980     case ST_DATA_DECL:
1981       p = _("data declaration");
1982       break;
1983     case ST_DATA:
1984       p = "DATA";
1985       break;
1986     case ST_DEALLOCATE:
1987       p = "DEALLOCATE";
1988       break;
1989     case ST_MAP:
1990       p = "MAP";
1991       break;
1992     case ST_UNION:
1993       p = "UNION";
1994       break;
1995     case ST_STRUCTURE_DECL:
1996       p = "STRUCTURE";
1997       break;
1998     case ST_DERIVED_DECL:
1999       p = _("derived type declaration");
2000       break;
2001     case ST_DO:
2002       p = "DO";
2003       break;
2004     case ST_ELSE:
2005       p = "ELSE";
2006       break;
2007     case ST_ELSEIF:
2008       p = "ELSE IF";
2009       break;
2010     case ST_ELSEWHERE:
2011       p = "ELSEWHERE";
2012       break;
2013     case ST_EVENT_POST:
2014       p = "EVENT POST";
2015       break;
2016     case ST_EVENT_WAIT:
2017       p = "EVENT WAIT";
2018       break;
2019     case ST_FAIL_IMAGE:
2020       p = "FAIL IMAGE";
2021       break;
2022     case ST_CHANGE_TEAM:
2023       p = "CHANGE TEAM";
2024       break;
2025     case ST_END_TEAM:
2026       p = "END TEAM";
2027       break;
2028     case ST_FORM_TEAM:
2029       p = "FORM TEAM";
2030       break;
2031     case ST_SYNC_TEAM:
2032       p = "SYNC TEAM";
2033       break;
2034     case ST_END_ASSOCIATE:
2035       p = "END ASSOCIATE";
2036       break;
2037     case ST_END_BLOCK:
2038       p = "END BLOCK";
2039       break;
2040     case ST_END_BLOCK_DATA:
2041       p = "END BLOCK DATA";
2042       break;
2043     case ST_END_CRITICAL:
2044       p = "END CRITICAL";
2045       break;
2046     case ST_ENDDO:
2047       p = "END DO";
2048       break;
2049     case ST_END_FILE:
2050       p = "END FILE";
2051       break;
2052     case ST_END_FORALL:
2053       p = "END FORALL";
2054       break;
2055     case ST_END_FUNCTION:
2056       p = "END FUNCTION";
2057       break;
2058     case ST_ENDIF:
2059       p = "END IF";
2060       break;
2061     case ST_END_INTERFACE:
2062       p = "END INTERFACE";
2063       break;
2064     case ST_END_MODULE:
2065       p = "END MODULE";
2066       break;
2067     case ST_END_SUBMODULE:
2068       p = "END SUBMODULE";
2069       break;
2070     case ST_END_PROGRAM:
2071       p = "END PROGRAM";
2072       break;
2073     case ST_END_SELECT:
2074       p = "END SELECT";
2075       break;
2076     case ST_END_SUBROUTINE:
2077       p = "END SUBROUTINE";
2078       break;
2079     case ST_END_WHERE:
2080       p = "END WHERE";
2081       break;
2082     case ST_END_STRUCTURE:
2083       p = "END STRUCTURE";
2084       break;
2085     case ST_END_UNION:
2086       p = "END UNION";
2087       break;
2088     case ST_END_MAP:
2089       p = "END MAP";
2090       break;
2091     case ST_END_TYPE:
2092       p = "END TYPE";
2093       break;
2094     case ST_ENTRY:
2095       p = "ENTRY";
2096       break;
2097     case ST_EQUIVALENCE:
2098       p = "EQUIVALENCE";
2099       break;
2100     case ST_ERROR_STOP:
2101       p = "ERROR STOP";
2102       break;
2103     case ST_EXIT:
2104       p = "EXIT";
2105       break;
2106     case ST_FLUSH:
2107       p = "FLUSH";
2108       break;
2109     case ST_FORALL_BLOCK:       /* Fall through */
2110     case ST_FORALL:
2111       p = "FORALL";
2112       break;
2113     case ST_FORMAT:
2114       p = "FORMAT";
2115       break;
2116     case ST_FUNCTION:
2117       p = "FUNCTION";
2118       break;
2119     case ST_GENERIC:
2120       p = "GENERIC";
2121       break;
2122     case ST_GOTO:
2123       p = "GOTO";
2124       break;
2125     case ST_IF_BLOCK:
2126       p = _("block IF");
2127       break;
2128     case ST_IMPLICIT:
2129       p = "IMPLICIT";
2130       break;
2131     case ST_IMPLICIT_NONE:
2132       p = "IMPLICIT NONE";
2133       break;
2134     case ST_IMPLIED_ENDDO:
2135       p = _("implied END DO");
2136       break;
2137     case ST_IMPORT:
2138       p = "IMPORT";
2139       break;
2140     case ST_INQUIRE:
2141       p = "INQUIRE";
2142       break;
2143     case ST_INTERFACE:
2144       p = "INTERFACE";
2145       break;
2146     case ST_LOCK:
2147       p = "LOCK";
2148       break;
2149     case ST_PARAMETER:
2150       p = "PARAMETER";
2151       break;
2152     case ST_PRIVATE:
2153       p = "PRIVATE";
2154       break;
2155     case ST_PUBLIC:
2156       p = "PUBLIC";
2157       break;
2158     case ST_MODULE:
2159       p = "MODULE";
2160       break;
2161     case ST_SUBMODULE:
2162       p = "SUBMODULE";
2163       break;
2164     case ST_PAUSE:
2165       p = "PAUSE";
2166       break;
2167     case ST_MODULE_PROC:
2168       p = "MODULE PROCEDURE";
2169       break;
2170     case ST_NAMELIST:
2171       p = "NAMELIST";
2172       break;
2173     case ST_NULLIFY:
2174       p = "NULLIFY";
2175       break;
2176     case ST_OPEN:
2177       p = "OPEN";
2178       break;
2179     case ST_PROGRAM:
2180       p = "PROGRAM";
2181       break;
2182     case ST_PROCEDURE:
2183       p = "PROCEDURE";
2184       break;
2185     case ST_READ:
2186       p = "READ";
2187       break;
2188     case ST_RETURN:
2189       p = "RETURN";
2190       break;
2191     case ST_REWIND:
2192       p = "REWIND";
2193       break;
2194     case ST_STOP:
2195       p = "STOP";
2196       break;
2197     case ST_SYNC_ALL:
2198       p = "SYNC ALL";
2199       break;
2200     case ST_SYNC_IMAGES:
2201       p = "SYNC IMAGES";
2202       break;
2203     case ST_SYNC_MEMORY:
2204       p = "SYNC MEMORY";
2205       break;
2206     case ST_SUBROUTINE:
2207       p = "SUBROUTINE";
2208       break;
2209     case ST_TYPE:
2210       p = "TYPE";
2211       break;
2212     case ST_UNLOCK:
2213       p = "UNLOCK";
2214       break;
2215     case ST_USE:
2216       p = "USE";
2217       break;
2218     case ST_WHERE_BLOCK:        /* Fall through */
2219     case ST_WHERE:
2220       p = "WHERE";
2221       break;
2222     case ST_WAIT:
2223       p = "WAIT";
2224       break;
2225     case ST_WRITE:
2226       p = "WRITE";
2227       break;
2228     case ST_ASSIGNMENT:
2229       p = _("assignment");
2230       break;
2231     case ST_POINTER_ASSIGNMENT:
2232       p = _("pointer assignment");
2233       break;
2234     case ST_SELECT_CASE:
2235       p = "SELECT CASE";
2236       break;
2237     case ST_SELECT_TYPE:
2238       p = "SELECT TYPE";
2239       break;
2240     case ST_SELECT_RANK:
2241       p = "SELECT RANK";
2242       break;
2243     case ST_TYPE_IS:
2244       p = "TYPE IS";
2245       break;
2246     case ST_CLASS_IS:
2247       p = "CLASS IS";
2248       break;
2249     case ST_RANK:
2250       p = "RANK";
2251       break;
2252     case ST_SEQUENCE:
2253       p = "SEQUENCE";
2254       break;
2255     case ST_SIMPLE_IF:
2256       p = _("simple IF");
2257       break;
2258     case ST_STATEMENT_FUNCTION:
2259       p = "STATEMENT FUNCTION";
2260       break;
2261     case ST_LABEL_ASSIGNMENT:
2262       p = "LABEL ASSIGNMENT";
2263       break;
2264     case ST_ENUM:
2265       p = "ENUM DEFINITION";
2266       break;
2267     case ST_ENUMERATOR:
2268       p = "ENUMERATOR DEFINITION";
2269       break;
2270     case ST_END_ENUM:
2271       p = "END ENUM";
2272       break;
2273     case ST_OACC_PARALLEL_LOOP:
2274       p = "!$ACC PARALLEL LOOP";
2275       break;
2276     case ST_OACC_END_PARALLEL_LOOP:
2277       p = "!$ACC END PARALLEL LOOP";
2278       break;
2279     case ST_OACC_PARALLEL:
2280       p = "!$ACC PARALLEL";
2281       break;
2282     case ST_OACC_END_PARALLEL:
2283       p = "!$ACC END PARALLEL";
2284       break;
2285     case ST_OACC_KERNELS:
2286       p = "!$ACC KERNELS";
2287       break;
2288     case ST_OACC_END_KERNELS:
2289       p = "!$ACC END KERNELS";
2290       break;
2291     case ST_OACC_KERNELS_LOOP:
2292       p = "!$ACC KERNELS LOOP";
2293       break;
2294     case ST_OACC_END_KERNELS_LOOP:
2295       p = "!$ACC END KERNELS LOOP";
2296       break;
2297     case ST_OACC_SERIAL_LOOP:
2298       p = "!$ACC SERIAL LOOP";
2299       break;
2300     case ST_OACC_END_SERIAL_LOOP:
2301       p = "!$ACC END SERIAL LOOP";
2302       break;
2303     case ST_OACC_SERIAL:
2304       p = "!$ACC SERIAL";
2305       break;
2306     case ST_OACC_END_SERIAL:
2307       p = "!$ACC END SERIAL";
2308       break;
2309     case ST_OACC_DATA:
2310       p = "!$ACC DATA";
2311       break;
2312     case ST_OACC_END_DATA:
2313       p = "!$ACC END DATA";
2314       break;
2315     case ST_OACC_HOST_DATA:
2316       p = "!$ACC HOST_DATA";
2317       break;
2318     case ST_OACC_END_HOST_DATA:
2319       p = "!$ACC END HOST_DATA";
2320       break;
2321     case ST_OACC_LOOP:
2322       p = "!$ACC LOOP";
2323       break;
2324     case ST_OACC_END_LOOP:
2325       p = "!$ACC END LOOP";
2326       break;
2327     case ST_OACC_DECLARE:
2328       p = "!$ACC DECLARE";
2329       break;
2330     case ST_OACC_UPDATE:
2331       p = "!$ACC UPDATE";
2332       break;
2333     case ST_OACC_WAIT:
2334       p = "!$ACC WAIT";
2335       break;
2336     case ST_OACC_CACHE:
2337       p = "!$ACC CACHE";
2338       break;
2339     case ST_OACC_ENTER_DATA:
2340       p = "!$ACC ENTER DATA";
2341       break;
2342     case ST_OACC_EXIT_DATA:
2343       p = "!$ACC EXIT DATA";
2344       break;
2345     case ST_OACC_ROUTINE:
2346       p = "!$ACC ROUTINE";
2347       break;
2348     case ST_OACC_ATOMIC:
2349       p = "!$ACC ATOMIC";
2350       break;
2351     case ST_OACC_END_ATOMIC:
2352       p = "!$ACC END ATOMIC";
2353       break;
2354     case ST_OMP_ATOMIC:
2355       p = "!$OMP ATOMIC";
2356       break;
2357     case ST_OMP_BARRIER:
2358       p = "!$OMP BARRIER";
2359       break;
2360     case ST_OMP_CANCEL:
2361       p = "!$OMP CANCEL";
2362       break;
2363     case ST_OMP_CANCELLATION_POINT:
2364       p = "!$OMP CANCELLATION POINT";
2365       break;
2366     case ST_OMP_CRITICAL:
2367       p = "!$OMP CRITICAL";
2368       break;
2369     case ST_OMP_DECLARE_REDUCTION:
2370       p = "!$OMP DECLARE REDUCTION";
2371       break;
2372     case ST_OMP_DECLARE_SIMD:
2373       p = "!$OMP DECLARE SIMD";
2374       break;
2375     case ST_OMP_DECLARE_TARGET:
2376       p = "!$OMP DECLARE TARGET";
2377       break;
2378     case ST_OMP_DECLARE_VARIANT:
2379       p = "!$OMP DECLARE VARIANT";
2380       break;
2381     case ST_OMP_DEPOBJ:
2382       p = "!$OMP DEPOBJ";
2383       break;
2384     case ST_OMP_DISTRIBUTE:
2385       p = "!$OMP DISTRIBUTE";
2386       break;
2387     case ST_OMP_DISTRIBUTE_PARALLEL_DO:
2388       p = "!$OMP DISTRIBUTE PARALLEL DO";
2389       break;
2390     case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
2391       p = "!$OMP DISTRIBUTE PARALLEL DO SIMD";
2392       break;
2393     case ST_OMP_DISTRIBUTE_SIMD:
2394       p = "!$OMP DISTRIBUTE SIMD";
2395       break;
2396     case ST_OMP_DO:
2397       p = "!$OMP DO";
2398       break;
2399     case ST_OMP_DO_SIMD:
2400       p = "!$OMP DO SIMD";
2401       break;
2402     case ST_OMP_END_ATOMIC:
2403       p = "!$OMP END ATOMIC";
2404       break;
2405     case ST_OMP_END_CRITICAL:
2406       p = "!$OMP END CRITICAL";
2407       break;
2408     case ST_OMP_END_DISTRIBUTE:
2409       p = "!$OMP END DISTRIBUTE";
2410       break;
2411     case ST_OMP_END_DISTRIBUTE_PARALLEL_DO:
2412       p = "!$OMP END DISTRIBUTE PARALLEL DO";
2413       break;
2414     case ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD:
2415       p = "!$OMP END DISTRIBUTE PARALLEL DO SIMD";
2416       break;
2417     case ST_OMP_END_DISTRIBUTE_SIMD:
2418       p = "!$OMP END DISTRIBUTE SIMD";
2419       break;
2420     case ST_OMP_END_DO:
2421       p = "!$OMP END DO";
2422       break;
2423     case ST_OMP_END_DO_SIMD:
2424       p = "!$OMP END DO SIMD";
2425       break;
2426     case ST_OMP_END_SCOPE:
2427       p = "!$OMP END SCOPE";
2428       break;
2429     case ST_OMP_END_SIMD:
2430       p = "!$OMP END SIMD";
2431       break;
2432     case ST_OMP_END_LOOP:
2433       p = "!$OMP END LOOP";
2434       break;
2435     case ST_OMP_END_MASKED:
2436       p = "!$OMP END MASKED";
2437       break;
2438     case ST_OMP_END_MASKED_TASKLOOP:
2439       p = "!$OMP END MASKED TASKLOOP";
2440       break;
2441     case ST_OMP_END_MASKED_TASKLOOP_SIMD:
2442       p = "!$OMP END MASKED TASKLOOP SIMD";
2443       break;
2444     case ST_OMP_END_MASTER:
2445       p = "!$OMP END MASTER";
2446       break;
2447     case ST_OMP_END_MASTER_TASKLOOP:
2448       p = "!$OMP END MASTER TASKLOOP";
2449       break;
2450     case ST_OMP_END_MASTER_TASKLOOP_SIMD:
2451       p = "!$OMP END MASTER TASKLOOP SIMD";
2452       break;
2453     case ST_OMP_END_ORDERED:
2454       p = "!$OMP END ORDERED";
2455       break;
2456     case ST_OMP_END_PARALLEL:
2457       p = "!$OMP END PARALLEL";
2458       break;
2459     case ST_OMP_END_PARALLEL_DO:
2460       p = "!$OMP END PARALLEL DO";
2461       break;
2462     case ST_OMP_END_PARALLEL_DO_SIMD:
2463       p = "!$OMP END PARALLEL DO SIMD";
2464       break;
2465     case ST_OMP_END_PARALLEL_LOOP:
2466       p = "!$OMP END PARALLEL LOOP";
2467       break;
2468     case ST_OMP_END_PARALLEL_MASKED:
2469       p = "!$OMP END PARALLEL MASKED";
2470       break;
2471     case ST_OMP_END_PARALLEL_MASKED_TASKLOOP:
2472       p = "!$OMP END PARALLEL MASKED TASKLOOP";
2473       break;
2474     case ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD:
2475       p = "!$OMP END PARALLEL MASKED TASKLOOP SIMD";
2476       break;
2477     case ST_OMP_END_PARALLEL_MASTER:
2478       p = "!$OMP END PARALLEL MASTER";
2479       break;
2480     case ST_OMP_END_PARALLEL_MASTER_TASKLOOP:
2481       p = "!$OMP END PARALLEL MASTER TASKLOOP";
2482       break;
2483     case ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD:
2484       p = "!$OMP END PARALLEL MASTER TASKLOOP SIMD";
2485       break;
2486     case ST_OMP_END_PARALLEL_SECTIONS:
2487       p = "!$OMP END PARALLEL SECTIONS";
2488       break;
2489     case ST_OMP_END_PARALLEL_WORKSHARE:
2490       p = "!$OMP END PARALLEL WORKSHARE";
2491       break;
2492     case ST_OMP_END_SECTIONS:
2493       p = "!$OMP END SECTIONS";
2494       break;
2495     case ST_OMP_END_SINGLE:
2496       p = "!$OMP END SINGLE";
2497       break;
2498     case ST_OMP_END_TASK:
2499       p = "!$OMP END TASK";
2500       break;
2501     case ST_OMP_END_TARGET:
2502       p = "!$OMP END TARGET";
2503       break;
2504     case ST_OMP_END_TARGET_DATA:
2505       p = "!$OMP END TARGET DATA";
2506       break;
2507     case ST_OMP_END_TARGET_PARALLEL:
2508       p = "!$OMP END TARGET PARALLEL";
2509       break;
2510     case ST_OMP_END_TARGET_PARALLEL_DO:
2511       p = "!$OMP END TARGET PARALLEL DO";
2512       break;
2513     case ST_OMP_END_TARGET_PARALLEL_DO_SIMD:
2514       p = "!$OMP END TARGET PARALLEL DO SIMD";
2515       break;
2516     case ST_OMP_END_TARGET_PARALLEL_LOOP:
2517       p = "!$OMP END TARGET PARALLEL LOOP";
2518       break;
2519     case ST_OMP_END_TARGET_SIMD:
2520       p = "!$OMP END TARGET SIMD";
2521       break;
2522     case ST_OMP_END_TARGET_TEAMS:
2523       p = "!$OMP END TARGET TEAMS";
2524       break;
2525     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE:
2526       p = "!$OMP END TARGET TEAMS DISTRIBUTE";
2527       break;
2528     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2529       p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO";
2530       break;
2531     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2532       p = "!$OMP END TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2533       break;
2534     case ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD:
2535       p = "!$OMP END TARGET TEAMS DISTRIBUTE SIMD";
2536       break;
2537     case ST_OMP_END_TARGET_TEAMS_LOOP:
2538       p = "!$OMP END TARGET TEAMS LOOP";
2539       break;
2540     case ST_OMP_END_TASKGROUP:
2541       p = "!$OMP END TASKGROUP";
2542       break;
2543     case ST_OMP_END_TASKLOOP:
2544       p = "!$OMP END TASKLOOP";
2545       break;
2546     case ST_OMP_END_TASKLOOP_SIMD:
2547       p = "!$OMP END TASKLOOP SIMD";
2548       break;
2549     case ST_OMP_END_TEAMS:
2550       p = "!$OMP END TEAMS";
2551       break;
2552     case ST_OMP_END_TEAMS_DISTRIBUTE:
2553       p = "!$OMP END TEAMS DISTRIBUTE";
2554       break;
2555     case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO:
2556       p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO";
2557       break;
2558     case ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2559       p = "!$OMP END TEAMS DISTRIBUTE PARALLEL DO SIMD";
2560       break;
2561     case ST_OMP_END_TEAMS_DISTRIBUTE_SIMD:
2562       p = "!$OMP END TEAMS DISTRIBUTE SIMD";
2563       break;
2564     case ST_OMP_END_TEAMS_LOOP:
2565       p = "!$OMP END TEAMS LOOP";
2566       break;
2567     case ST_OMP_END_WORKSHARE:
2568       p = "!$OMP END WORKSHARE";
2569       break;
2570     case ST_OMP_ERROR:
2571       p = "!$OMP ERROR";
2572       break;
2573     case ST_OMP_FLUSH:
2574       p = "!$OMP FLUSH";
2575       break;
2576     case ST_OMP_LOOP:
2577       p = "!$OMP LOOP";
2578       break;
2579     case ST_OMP_MASKED:
2580       p = "!$OMP MASKED";
2581       break;
2582     case ST_OMP_MASKED_TASKLOOP:
2583       p = "!$OMP MASKED TASKLOOP";
2584       break;
2585     case ST_OMP_MASKED_TASKLOOP_SIMD:
2586       p = "!$OMP MASKED TASKLOOP SIMD";
2587       break;
2588     case ST_OMP_MASTER:
2589       p = "!$OMP MASTER";
2590       break;
2591     case ST_OMP_MASTER_TASKLOOP:
2592       p = "!$OMP MASTER TASKLOOP";
2593       break;
2594     case ST_OMP_MASTER_TASKLOOP_SIMD:
2595       p = "!$OMP MASTER TASKLOOP SIMD";
2596       break;
2597     case ST_OMP_ORDERED:
2598     case ST_OMP_ORDERED_DEPEND:
2599       p = "!$OMP ORDERED";
2600       break;
2601     case ST_OMP_PARALLEL:
2602       p = "!$OMP PARALLEL";
2603       break;
2604     case ST_OMP_PARALLEL_DO:
2605       p = "!$OMP PARALLEL DO";
2606       break;
2607     case ST_OMP_PARALLEL_LOOP:
2608       p = "!$OMP PARALLEL LOOP";
2609       break;
2610     case ST_OMP_PARALLEL_DO_SIMD:
2611       p = "!$OMP PARALLEL DO SIMD";
2612       break;
2613     case ST_OMP_PARALLEL_MASKED:
2614       p = "!$OMP PARALLEL MASKED";
2615       break;
2616     case ST_OMP_PARALLEL_MASKED_TASKLOOP:
2617       p = "!$OMP PARALLEL MASKED TASKLOOP";
2618       break;
2619     case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
2620       p = "!$OMP PARALLEL MASKED TASKLOOP SIMD";
2621       break;
2622     case ST_OMP_PARALLEL_MASTER:
2623       p = "!$OMP PARALLEL MASTER";
2624       break;
2625     case ST_OMP_PARALLEL_MASTER_TASKLOOP:
2626       p = "!$OMP PARALLEL MASTER TASKLOOP";
2627       break;
2628     case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
2629       p = "!$OMP PARALLEL MASTER TASKLOOP SIMD";
2630       break;
2631     case ST_OMP_PARALLEL_SECTIONS:
2632       p = "!$OMP PARALLEL SECTIONS";
2633       break;
2634     case ST_OMP_PARALLEL_WORKSHARE:
2635       p = "!$OMP PARALLEL WORKSHARE";
2636       break;
2637     case ST_OMP_REQUIRES:
2638       p = "!$OMP REQUIRES";
2639       break;
2640     case ST_OMP_SCAN:
2641       p = "!$OMP SCAN";
2642       break;
2643     case ST_OMP_SCOPE:
2644       p = "!$OMP SCOPE";
2645       break;
2646     case ST_OMP_SECTIONS:
2647       p = "!$OMP SECTIONS";
2648       break;
2649     case ST_OMP_SECTION:
2650       p = "!$OMP SECTION";
2651       break;
2652     case ST_OMP_SIMD:
2653       p = "!$OMP SIMD";
2654       break;
2655     case ST_OMP_SINGLE:
2656       p = "!$OMP SINGLE";
2657       break;
2658     case ST_OMP_TARGET:
2659       p = "!$OMP TARGET";
2660       break;
2661     case ST_OMP_TARGET_DATA:
2662       p = "!$OMP TARGET DATA";
2663       break;
2664     case ST_OMP_TARGET_ENTER_DATA:
2665       p = "!$OMP TARGET ENTER DATA";
2666       break;
2667     case ST_OMP_TARGET_EXIT_DATA:
2668       p = "!$OMP TARGET EXIT DATA";
2669       break;
2670     case ST_OMP_TARGET_PARALLEL:
2671       p = "!$OMP TARGET PARALLEL";
2672       break;
2673     case ST_OMP_TARGET_PARALLEL_DO:
2674       p = "!$OMP TARGET PARALLEL DO";
2675       break;
2676     case ST_OMP_TARGET_PARALLEL_DO_SIMD:
2677       p = "!$OMP TARGET PARALLEL DO SIMD";
2678       break;
2679     case ST_OMP_TARGET_PARALLEL_LOOP:
2680       p = "!$OMP TARGET PARALLEL LOOP";
2681       break;
2682     case ST_OMP_TARGET_SIMD:
2683       p = "!$OMP TARGET SIMD";
2684       break;
2685     case ST_OMP_TARGET_TEAMS:
2686       p = "!$OMP TARGET TEAMS";
2687       break;
2688     case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
2689       p = "!$OMP TARGET TEAMS DISTRIBUTE";
2690       break;
2691     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
2692       p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO";
2693       break;
2694     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2695       p = "!$OMP TARGET TEAMS DISTRIBUTE PARALLEL DO SIMD";
2696       break;
2697     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
2698       p = "!$OMP TARGET TEAMS DISTRIBUTE SIMD";
2699       break;
2700     case ST_OMP_TARGET_TEAMS_LOOP:
2701       p = "!$OMP TARGET TEAMS LOOP";
2702       break;
2703     case ST_OMP_TARGET_UPDATE:
2704       p = "!$OMP TARGET UPDATE";
2705       break;
2706     case ST_OMP_TASK:
2707       p = "!$OMP TASK";
2708       break;
2709     case ST_OMP_TASKGROUP:
2710       p = "!$OMP TASKGROUP";
2711       break;
2712     case ST_OMP_TASKLOOP:
2713       p = "!$OMP TASKLOOP";
2714       break;
2715     case ST_OMP_TASKLOOP_SIMD:
2716       p = "!$OMP TASKLOOP SIMD";
2717       break;
2718     case ST_OMP_TASKWAIT:
2719       p = "!$OMP TASKWAIT";
2720       break;
2721     case ST_OMP_TASKYIELD:
2722       p = "!$OMP TASKYIELD";
2723       break;
2724     case ST_OMP_TEAMS:
2725       p = "!$OMP TEAMS";
2726       break;
2727     case ST_OMP_TEAMS_DISTRIBUTE:
2728       p = "!$OMP TEAMS DISTRIBUTE";
2729       break;
2730     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
2731       p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO";
2732       break;
2733     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
2734       p = "!$OMP TEAMS DISTRIBUTE PARALLEL DO SIMD";
2735       break;
2736     case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
2737       p = "!$OMP TEAMS DISTRIBUTE SIMD";
2738       break;
2739     case ST_OMP_TEAMS_LOOP:
2740       p = "!$OMP TEAMS LOOP";
2741       break;
2742     case ST_OMP_THREADPRIVATE:
2743       p = "!$OMP THREADPRIVATE";
2744       break;
2745     case ST_OMP_WORKSHARE:
2746       p = "!$OMP WORKSHARE";
2747       break;
2748     default:
2749       gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
2750     }
2751
2752   return p;
2753 }
2754
2755
2756 /* Create a symbol for the main program and assign it to ns->proc_name.  */
2757
2758 static void
2759 main_program_symbol (gfc_namespace *ns, const char *name)
2760 {
2761   gfc_symbol *main_program;
2762   symbol_attribute attr;
2763
2764   gfc_get_symbol (name, ns, &main_program);
2765   gfc_clear_attr (&attr);
2766   attr.flavor = FL_PROGRAM;
2767   attr.proc = PROC_UNKNOWN;
2768   attr.subroutine = 1;
2769   attr.access = ACCESS_PUBLIC;
2770   attr.is_main_program = 1;
2771   main_program->attr = attr;
2772   main_program->declared_at = gfc_current_locus;
2773   ns->proc_name = main_program;
2774   gfc_commit_symbols ();
2775 }
2776
2777
2778 /* Do whatever is necessary to accept the last statement.  */
2779
2780 static void
2781 accept_statement (gfc_statement st)
2782 {
2783   switch (st)
2784     {
2785     case ST_IMPLICIT_NONE:
2786     case ST_IMPLICIT:
2787       break;
2788
2789     case ST_FUNCTION:
2790     case ST_SUBROUTINE:
2791     case ST_MODULE:
2792     case ST_SUBMODULE:
2793       gfc_current_ns->proc_name = gfc_new_block;
2794       break;
2795
2796       /* If the statement is the end of a block, lay down a special code
2797          that allows a branch to the end of the block from within the
2798          construct.  IF and SELECT are treated differently from DO
2799          (where EXEC_NOP is added inside the loop) for two
2800          reasons:
2801          1. END DO has a meaning in the sense that after a GOTO to
2802             it, the loop counter must be increased.
2803          2. IF blocks and SELECT blocks can consist of multiple
2804             parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
2805             Putting the label before the END IF would make the jump
2806             from, say, the ELSE IF block to the END IF illegal.  */
2807
2808     case ST_ENDIF:
2809     case ST_END_SELECT:
2810     case ST_END_CRITICAL:
2811       if (gfc_statement_label != NULL)
2812         {
2813           new_st.op = EXEC_END_NESTED_BLOCK;
2814           add_statement ();
2815         }
2816       break;
2817
2818       /* In the case of BLOCK and ASSOCIATE blocks, there cannot be more than
2819          one parallel block.  Thus, we add the special code to the nested block
2820          itself, instead of the parent one.  */
2821     case ST_END_BLOCK:
2822     case ST_END_ASSOCIATE:
2823       if (gfc_statement_label != NULL)
2824         {
2825           new_st.op = EXEC_END_BLOCK;
2826           add_statement ();
2827         }
2828       break;
2829
2830       /* The end-of-program unit statements do not get the special
2831          marker and require a statement of some sort if they are a
2832          branch target.  */
2833
2834     case ST_END_PROGRAM:
2835     case ST_END_FUNCTION:
2836     case ST_END_SUBROUTINE:
2837       if (gfc_statement_label != NULL)
2838         {
2839           new_st.op = EXEC_RETURN;
2840           add_statement ();
2841         }
2842       else
2843         {
2844           new_st.op = EXEC_END_PROCEDURE;
2845           add_statement ();
2846         }
2847
2848       break;
2849
2850     case ST_ENTRY:
2851     case_executable:
2852     case_exec_markers:
2853       add_statement ();
2854       break;
2855
2856     default:
2857       break;
2858     }
2859
2860   gfc_commit_symbols ();
2861   gfc_warning_check ();
2862   gfc_clear_new_st ();
2863 }
2864
2865
2866 /* Undo anything tentative that has been built for the current statement,
2867    except if a gfc_charlen structure has been added to current namespace's
2868    list of gfc_charlen structure.  */
2869
2870 static void
2871 reject_statement (void)
2872 {
2873   gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
2874   gfc_current_ns->equiv = gfc_current_ns->old_equiv;
2875
2876   gfc_reject_data (gfc_current_ns);
2877
2878   gfc_new_block = NULL;
2879   gfc_undo_symbols ();
2880   gfc_clear_warning ();
2881   undo_new_statement ();
2882 }
2883
2884
2885 /* Generic complaint about an out of order statement.  We also do
2886    whatever is necessary to clean up.  */
2887
2888 static void
2889 unexpected_statement (gfc_statement st)
2890 {
2891   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
2892
2893   reject_statement ();
2894 }
2895
2896
2897 /* Given the next statement seen by the matcher, make sure that it is
2898    in proper order with the last.  This subroutine is initialized by
2899    calling it with an argument of ST_NONE.  If there is a problem, we
2900    issue an error and return false.  Otherwise we return true.
2901
2902    Individual parsers need to verify that the statements seen are
2903    valid before calling here, i.e., ENTRY statements are not allowed in
2904    INTERFACE blocks.  The following diagram is taken from the standard:
2905
2906             +---------------------------------------+
2907             | program  subroutine  function  module |
2908             +---------------------------------------+
2909             |            use               |
2910             +---------------------------------------+
2911             |            import         |
2912             +---------------------------------------+
2913             |   |       implicit none    |
2914             |   +-----------+------------------+
2915             |   | parameter |  implicit |
2916             |   +-----------+------------------+
2917             | format |     |  derived type    |
2918             | entry  | parameter |  interface       |
2919             |   |   data    |  specification   |
2920             |   |          |  statement func  |
2921             |   +-----------+------------------+
2922             |   |   data    |    executable    |
2923             +--------+-----------+------------------+
2924             |           contains               |
2925             +---------------------------------------+
2926             |      internal module/subprogram       |
2927             +---------------------------------------+
2928             |              end           |
2929             +---------------------------------------+
2930
2931 */
2932
2933 enum state_order
2934 {
2935   ORDER_START,
2936   ORDER_USE,
2937   ORDER_IMPORT,
2938   ORDER_IMPLICIT_NONE,
2939   ORDER_IMPLICIT,
2940   ORDER_SPEC,
2941   ORDER_EXEC
2942 };
2943
2944 typedef struct
2945 {
2946   enum state_order state;
2947   gfc_statement last_statement;
2948   locus where;
2949 }
2950 st_state;
2951
2952 static bool
2953 verify_st_order (st_state *p, gfc_statement st, bool silent)
2954 {
2955
2956   switch (st)
2957     {
2958     case ST_NONE:
2959       p->state = ORDER_START;
2960       break;
2961
2962     case ST_USE:
2963       if (p->state > ORDER_USE)
2964         goto order;
2965       p->state = ORDER_USE;
2966       break;
2967
2968     case ST_IMPORT:
2969       if (p->state > ORDER_IMPORT)
2970         goto order;
2971       p->state = ORDER_IMPORT;
2972       break;
2973
2974     case ST_IMPLICIT_NONE:
2975       if (p->state > ORDER_IMPLICIT)
2976         goto order;
2977
2978       /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
2979          statement disqualifies a USE but not an IMPLICIT NONE.
2980          Duplicate IMPLICIT NONEs are caught when the implicit types
2981          are set.  */
2982
2983       p->state = ORDER_IMPLICIT_NONE;
2984       break;
2985
2986     case ST_IMPLICIT:
2987       if (p->state > ORDER_IMPLICIT)
2988         goto order;
2989       p->state = ORDER_IMPLICIT;
2990       break;
2991
2992     case ST_FORMAT:
2993     case ST_ENTRY:
2994       if (p->state < ORDER_IMPLICIT_NONE)
2995         p->state = ORDER_IMPLICIT_NONE;
2996       break;
2997
2998     case ST_PARAMETER:
2999       if (p->state >= ORDER_EXEC)
3000         goto order;
3001       if (p->state < ORDER_IMPLICIT)
3002         p->state = ORDER_IMPLICIT;
3003       break;
3004
3005     case ST_DATA:
3006       if (p->state < ORDER_SPEC)
3007         p->state = ORDER_SPEC;
3008       break;
3009
3010     case ST_PUBLIC:
3011     case ST_PRIVATE:
3012     case ST_STRUCTURE_DECL:
3013     case ST_DERIVED_DECL:
3014     case_decl:
3015       if (p->state >= ORDER_EXEC)
3016         goto order;
3017       if (p->state < ORDER_SPEC)
3018         p->state = ORDER_SPEC;
3019       break;
3020
3021     case_omp_decl:
3022       /* The OpenMP/OpenACC directives have to be somewhere in the specification
3023          part, but there are no further requirements on their ordering.
3024          Thus don't adjust p->state, just ignore them.  */
3025       if (p->state >= ORDER_EXEC)
3026         goto order;
3027       break;
3028
3029     case_executable:
3030     case_exec_markers:
3031       if (p->state < ORDER_EXEC)
3032         p->state = ORDER_EXEC;
3033       break;
3034
3035     default:
3036       return false;
3037     }
3038
3039   /* All is well, record the statement in case we need it next time.  */
3040   p->where = gfc_current_locus;
3041   p->last_statement = st;
3042   return true;
3043
3044 order:
3045   if (!silent)
3046     gfc_error ("%s statement at %C cannot follow %s statement at %L",
3047                gfc_ascii_statement (st),
3048                gfc_ascii_statement (p->last_statement), &p->where);
3049
3050   return false;
3051 }
3052
3053
3054 /* Handle an unexpected end of file.  This is a show-stopper...  */
3055
3056 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
3057
3058 static void
3059 unexpected_eof (void)
3060 {
3061   gfc_state_data *p;
3062
3063   gfc_error ("Unexpected end of file in %qs", gfc_source_file);
3064
3065   /* Memory cleanup.  Move to "second to last".  */
3066   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
3067        p = p->previous);
3068
3069   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
3070   gfc_done_2 ();
3071
3072   longjmp (eof_buf, 1);
3073
3074   /* Avoids build error on systems where longjmp is not declared noreturn.  */
3075   gcc_unreachable ();
3076 }
3077
3078
3079 /* Parse the CONTAINS section of a derived type definition.  */
3080
3081 gfc_access gfc_typebound_default_access;
3082
3083 static bool
3084 parse_derived_contains (void)
3085 {
3086   gfc_state_data s;
3087   bool seen_private = false;
3088   bool seen_comps = false;
3089   bool error_flag = false;
3090   bool to_finish;
3091
3092   gcc_assert (gfc_current_state () == COMP_DERIVED);
3093   gcc_assert (gfc_current_block ());
3094
3095   /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
3096      section.  */
3097   if (gfc_current_block ()->attr.sequence)
3098     gfc_error ("Derived-type %qs with SEQUENCE must not have a CONTAINS"
3099                " section at %C", gfc_current_block ()->name);
3100   if (gfc_current_block ()->attr.is_bind_c)
3101     gfc_error ("Derived-type %qs with BIND(C) must not have a CONTAINS"
3102                " section at %C", gfc_current_block ()->name);
3103
3104   accept_statement (ST_CONTAINS);
3105   push_state (&s, COMP_DERIVED_CONTAINS, NULL);
3106
3107   gfc_typebound_default_access = ACCESS_PUBLIC;
3108
3109   to_finish = false;
3110   while (!to_finish)
3111     {
3112       gfc_statement st;
3113       st = next_statement ();
3114       switch (st)
3115         {
3116         case ST_NONE:
3117           unexpected_eof ();
3118           break;
3119
3120         case ST_DATA_DECL:
3121           gfc_error ("Components in TYPE at %C must precede CONTAINS");
3122           goto error;
3123
3124         case ST_PROCEDURE:
3125           if (!gfc_notify_std (GFC_STD_F2003, "Type-bound procedure at %C"))
3126             goto error;
3127
3128           accept_statement (ST_PROCEDURE);
3129           seen_comps = true;
3130           break;
3131
3132         case ST_GENERIC:
3133           if (!gfc_notify_std (GFC_STD_F2003, "GENERIC binding at %C"))
3134             goto error;
3135
3136           accept_statement (ST_GENERIC);
3137           seen_comps = true;
3138           break;
3139
3140         case ST_FINAL:
3141           if (!gfc_notify_std (GFC_STD_F2003, "FINAL procedure declaration"
3142                                " at %C"))
3143             goto error;
3144
3145           accept_statement (ST_FINAL);
3146           seen_comps = true;
3147           break;
3148
3149         case ST_END_TYPE:
3150           to_finish = true;
3151
3152           if (!seen_comps
3153               && (!gfc_notify_std(GFC_STD_F2008, "Derived type definition "
3154                                   "at %C with empty CONTAINS section")))
3155             goto error;
3156
3157           /* ST_END_TYPE is accepted by parse_derived after return.  */
3158           break;
3159
3160         case ST_PRIVATE:
3161           if (!gfc_find_state (COMP_MODULE))
3162             {
3163               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3164                          "a MODULE");
3165               goto error;
3166             }
3167
3168           if (seen_comps)
3169             {
3170               gfc_error ("PRIVATE statement at %C must precede procedure"
3171                          " bindings");
3172               goto error;
3173             }
3174
3175           if (seen_private)
3176             {
3177               gfc_error ("Duplicate PRIVATE statement at %C");
3178               goto error;
3179             }
3180
3181           accept_statement (ST_PRIVATE);
3182           gfc_typebound_default_access = ACCESS_PRIVATE;
3183           seen_private = true;
3184           break;
3185
3186         case ST_SEQUENCE:
3187           gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
3188           goto error;
3189
3190         case ST_CONTAINS:
3191           gfc_error ("Already inside a CONTAINS block at %C");
3192           goto error;
3193
3194         default:
3195           unexpected_statement (st);
3196           break;
3197         }
3198
3199       continue;
3200
3201 error:
3202       error_flag = true;
3203       reject_statement ();
3204     }
3205
3206   pop_state ();
3207   gcc_assert (gfc_current_state () == COMP_DERIVED);
3208
3209   return error_flag;
3210 }
3211
3212
3213 /* Set attributes for the parent symbol based on the attributes of a component
3214    and raise errors if conflicting attributes are found for the component.  */
3215
3216 static void
3217 check_component (gfc_symbol *sym, gfc_component *c, gfc_component **lockp,
3218     gfc_component **eventp)
3219 {
3220   bool coarray, lock_type, event_type, allocatable, pointer;
3221   coarray = lock_type = event_type = allocatable = pointer = false;
3222   gfc_component *lock_comp = NULL, *event_comp = NULL;
3223
3224   if (lockp) lock_comp = *lockp;
3225   if (eventp) event_comp = *eventp;
3226
3227   /* Look for allocatable components.  */
3228   if (c->attr.allocatable
3229       || (c->ts.type == BT_CLASS && c->attr.class_ok
3230           && CLASS_DATA (c)->attr.allocatable)
3231       || (c->ts.type == BT_DERIVED && !c->attr.pointer
3232           && c->ts.u.derived->attr.alloc_comp))
3233     {
3234       allocatable = true;
3235       sym->attr.alloc_comp = 1;
3236     }
3237
3238   /* Look for pointer components.  */
3239   if (c->attr.pointer
3240       || (c->ts.type == BT_CLASS && c->attr.class_ok
3241           && CLASS_DATA (c)->attr.class_pointer)
3242       || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
3243     {
3244       pointer = true;
3245       sym->attr.pointer_comp = 1;
3246     }
3247
3248   /* Look for procedure pointer components.  */
3249   if (c->attr.proc_pointer
3250       || (c->ts.type == BT_DERIVED
3251           && c->ts.u.derived->attr.proc_pointer_comp))
3252     sym->attr.proc_pointer_comp = 1;
3253
3254   /* Looking for coarray components.  */
3255   if (c->attr.codimension
3256       || (c->ts.type == BT_CLASS && c->attr.class_ok
3257           && CLASS_DATA (c)->attr.codimension))
3258     {
3259       coarray = true;
3260       sym->attr.coarray_comp = 1;
3261     }
3262
3263   if (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.coarray_comp
3264       && !c->attr.pointer)
3265     {
3266       coarray = true;
3267       sym->attr.coarray_comp = 1;
3268     }
3269
3270   /* Looking for lock_type components.  */
3271   if ((c->ts.type == BT_DERIVED
3272           && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3273           && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_LOCK_TYPE)
3274       || (c->ts.type == BT_CLASS && c->attr.class_ok
3275           && CLASS_DATA (c)->ts.u.derived->from_intmod
3276              == INTMOD_ISO_FORTRAN_ENV
3277           && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
3278              == ISOFORTRAN_LOCK_TYPE)
3279       || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.lock_comp
3280           && !allocatable && !pointer))
3281     {
3282       lock_type = 1;
3283       lock_comp = c;
3284       sym->attr.lock_comp = 1;
3285     }
3286
3287     /* Looking for event_type components.  */
3288     if ((c->ts.type == BT_DERIVED
3289             && c->ts.u.derived->from_intmod == INTMOD_ISO_FORTRAN_ENV
3290             && c->ts.u.derived->intmod_sym_id == ISOFORTRAN_EVENT_TYPE)
3291         || (c->ts.type == BT_CLASS && c->attr.class_ok
3292             && CLASS_DATA (c)->ts.u.derived->from_intmod
3293                == INTMOD_ISO_FORTRAN_ENV
3294             && CLASS_DATA (c)->ts.u.derived->intmod_sym_id
3295                == ISOFORTRAN_EVENT_TYPE)
3296         || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.event_comp
3297             && !allocatable && !pointer))
3298       {
3299         event_type = 1;
3300         event_comp = c;
3301         sym->attr.event_comp = 1;
3302       }
3303
3304   /* Check for F2008, C1302 - and recall that pointers may not be coarrays
3305      (5.3.14) and that subobjects of coarray are coarray themselves (2.4.7),
3306      unless there are nondirect [allocatable or pointer] components
3307      involved (cf. 1.3.33.1 and 1.3.33.3).  */
3308
3309   if (pointer && !coarray && lock_type)
3310     gfc_error ("Component %s at %L of type LOCK_TYPE must have a "
3311                "codimension or be a subcomponent of a coarray, "
3312                "which is not possible as the component has the "
3313                "pointer attribute", c->name, &c->loc);
3314   else if (pointer && !coarray && c->ts.type == BT_DERIVED
3315            && c->ts.u.derived->attr.lock_comp)
3316     gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3317                "of type LOCK_TYPE, which must have a codimension or be a "
3318                "subcomponent of a coarray", c->name, &c->loc);
3319
3320   if (lock_type && allocatable && !coarray)
3321     gfc_error ("Allocatable component %s at %L of type LOCK_TYPE must have "
3322                "a codimension", c->name, &c->loc);
3323   else if (lock_type && allocatable && c->ts.type == BT_DERIVED
3324            && c->ts.u.derived->attr.lock_comp)
3325     gfc_error ("Allocatable component %s at %L must have a codimension as "
3326                "it has a noncoarray subcomponent of type LOCK_TYPE",
3327                c->name, &c->loc);
3328
3329   if (sym->attr.coarray_comp && !coarray && lock_type)
3330     gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3331                "subcomponent of type LOCK_TYPE must have a codimension or "
3332                "be a subcomponent of a coarray. (Variables of type %s may "
3333                "not have a codimension as already a coarray "
3334                "subcomponent exists)", c->name, &c->loc, sym->name);
3335
3336   if (sym->attr.lock_comp && coarray && !lock_type)
3337     gfc_error ("Noncoarray component %s at %L of type LOCK_TYPE or with "
3338                "subcomponent of type LOCK_TYPE must have a codimension or "
3339                "be a subcomponent of a coarray. (Variables of type %s may "
3340                "not have a codimension as %s at %L has a codimension or a "
3341                "coarray subcomponent)", lock_comp->name, &lock_comp->loc,
3342                sym->name, c->name, &c->loc);
3343
3344   /* Similarly for EVENT TYPE.  */
3345
3346   if (pointer && !coarray && event_type)
3347     gfc_error ("Component %s at %L of type EVENT_TYPE must have a "
3348                "codimension or be a subcomponent of a coarray, "
3349                "which is not possible as the component has the "
3350                "pointer attribute", c->name, &c->loc);
3351   else if (pointer && !coarray && c->ts.type == BT_DERIVED
3352            && c->ts.u.derived->attr.event_comp)
3353     gfc_error ("Pointer component %s at %L has a noncoarray subcomponent "
3354                "of type EVENT_TYPE, which must have a codimension or be a "
3355                "subcomponent of a coarray", c->name, &c->loc);
3356
3357   if (event_type && allocatable && !coarray)
3358     gfc_error ("Allocatable component %s at %L of type EVENT_TYPE must have "
3359                "a codimension", c->name, &c->loc);
3360   else if (event_type && allocatable && c->ts.type == BT_DERIVED
3361            && c->ts.u.derived->attr.event_comp)
3362     gfc_error ("Allocatable component %s at %L must have a codimension as "
3363                "it has a noncoarray subcomponent of type EVENT_TYPE",
3364                c->name, &c->loc);
3365
3366   if (sym->attr.coarray_comp && !coarray && event_type)
3367     gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3368                "subcomponent of type EVENT_TYPE must have a codimension or "
3369                "be a subcomponent of a coarray. (Variables of type %s may "
3370                "not have a codimension as already a coarray "
3371                "subcomponent exists)", c->name, &c->loc, sym->name);
3372
3373   if (sym->attr.event_comp && coarray && !event_type)
3374     gfc_error ("Noncoarray component %s at %L of type EVENT_TYPE or with "
3375                "subcomponent of type EVENT_TYPE must have a codimension or "
3376                "be a subcomponent of a coarray. (Variables of type %s may "
3377                "not have a codimension as %s at %L has a codimension or a "
3378                "coarray subcomponent)", event_comp->name, &event_comp->loc,
3379                sym->name, c->name, &c->loc);
3380
3381   /* Look for private components.  */
3382   if (sym->component_access == ACCESS_PRIVATE
3383       || c->attr.access == ACCESS_PRIVATE
3384       || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
3385     sym->attr.private_comp = 1;
3386
3387   if (lockp) *lockp = lock_comp;
3388   if (eventp) *eventp = event_comp;
3389 }
3390
3391
3392 static void parse_struct_map (gfc_statement);
3393
3394 /* Parse a union component definition within a structure definition.  */
3395
3396 static void
3397 parse_union (void)
3398 {
3399   int compiling;
3400   gfc_statement st;
3401   gfc_state_data s;
3402   gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3403   gfc_symbol *un;
3404
3405   accept_statement(ST_UNION);
3406   push_state (&s, COMP_UNION, gfc_new_block);
3407   un = gfc_new_block;
3408
3409   compiling = 1;
3410
3411   while (compiling)
3412     {
3413       st = next_statement ();
3414       /* Only MAP declarations valid within a union. */
3415       switch (st)
3416         {
3417         case ST_NONE:
3418           unexpected_eof ();
3419
3420         case ST_MAP:
3421           accept_statement (ST_MAP);
3422           parse_struct_map (ST_MAP);
3423           /* Add a component to the union for each map. */
3424           if (!gfc_add_component (un, gfc_new_block->name, &c))
3425             {
3426               gfc_internal_error ("failed to create map component '%s'",
3427                   gfc_new_block->name);
3428               reject_statement ();
3429               return;
3430             }
3431           c->ts.type = BT_DERIVED;
3432           c->ts.u.derived = gfc_new_block;
3433           /* Normally components get their initialization expressions when they
3434              are created in decl.c (build_struct) so we can look through the
3435              flat component list for initializers during resolution. Unions and
3436              maps create components along with their type definitions so we
3437              have to generate initializers here. */
3438           c->initializer = gfc_default_initializer (&c->ts);
3439           break;
3440
3441         case ST_END_UNION:
3442           compiling = 0;
3443           accept_statement (ST_END_UNION);
3444           break;
3445
3446         default:
3447           unexpected_statement (st);
3448           break;
3449         }
3450     }
3451
3452   for (c = un->components; c; c = c->next)
3453     check_component (un, c, &lock_comp, &event_comp);
3454
3455   /* Add the union as a component in its parent structure.  */
3456   pop_state ();
3457   if (!gfc_add_component (gfc_current_block (), un->name, &c))
3458     {
3459       gfc_internal_error ("failed to create union component '%s'", un->name);
3460       reject_statement ();
3461       return;
3462     }
3463   c->ts.type = BT_UNION;
3464   c->ts.u.derived = un;
3465   c->initializer = gfc_default_initializer (&c->ts);
3466
3467   un->attr.zero_comp = un->components == NULL;
3468 }
3469
3470
3471 /* Parse a STRUCTURE or MAP.  */
3472
3473 static void
3474 parse_struct_map (gfc_statement block)
3475 {
3476   int compiling_type;
3477   gfc_statement st;
3478   gfc_state_data s;
3479   gfc_symbol *sym;
3480   gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3481   gfc_compile_state comp;
3482   gfc_statement ends;
3483
3484   if (block == ST_STRUCTURE_DECL)
3485     {
3486       comp = COMP_STRUCTURE;
3487       ends = ST_END_STRUCTURE;
3488     }
3489   else
3490     {
3491       gcc_assert (block == ST_MAP);
3492       comp = COMP_MAP;
3493       ends = ST_END_MAP;
3494     }
3495
3496   accept_statement(block);
3497   push_state (&s, comp, gfc_new_block);
3498
3499   gfc_new_block->component_access = ACCESS_PUBLIC;
3500   compiling_type = 1;
3501
3502   while (compiling_type)
3503     {
3504       st = next_statement ();
3505       switch (st)
3506         {
3507         case ST_NONE:
3508           unexpected_eof ();
3509
3510         /* Nested structure declarations will be captured as ST_DATA_DECL.  */
3511         case ST_STRUCTURE_DECL:
3512           /* Let a more specific error make it to decode_statement().  */
3513           if (gfc_error_check () == 0)
3514             gfc_error ("Syntax error in nested structure declaration at %C");
3515           reject_statement ();
3516           /* Skip the rest of this statement.  */
3517           gfc_error_recovery ();
3518           break;
3519
3520         case ST_UNION:
3521           accept_statement (ST_UNION);
3522           parse_union ();
3523           break;
3524
3525         case ST_DATA_DECL:
3526           /* The data declaration was a nested/ad-hoc STRUCTURE field.  */
3527           accept_statement (ST_DATA_DECL);
3528           if (gfc_new_block && gfc_new_block != gfc_current_block ()
3529                             && gfc_new_block->attr.flavor == FL_STRUCT)
3530               parse_struct_map (ST_STRUCTURE_DECL);
3531           break;
3532
3533         case ST_END_STRUCTURE:
3534         case ST_END_MAP:
3535           if (st == ends)
3536             {
3537               accept_statement (st);
3538               compiling_type = 0;
3539             }
3540           else
3541             unexpected_statement (st);
3542           break;
3543
3544         default:
3545           unexpected_statement (st);
3546           break;
3547         }
3548     }
3549
3550   /* Validate each component.  */
3551   sym = gfc_current_block ();
3552   for (c = sym->components; c; c = c->next)
3553     check_component (sym, c, &lock_comp, &event_comp);
3554
3555   sym->attr.zero_comp = (sym->components == NULL);
3556
3557   /* Allow parse_union to find this structure to add to its list of maps.  */
3558   if (block == ST_MAP)
3559     gfc_new_block = gfc_current_block ();
3560
3561   pop_state ();
3562 }
3563
3564
3565 /* Parse a derived type.  */
3566
3567 static void
3568 parse_derived (void)
3569 {
3570   int compiling_type, seen_private, seen_sequence, seen_component;
3571   gfc_statement st;
3572   gfc_state_data s;
3573   gfc_symbol *sym;
3574   gfc_component *c, *lock_comp = NULL, *event_comp = NULL;
3575
3576   accept_statement (ST_DERIVED_DECL);
3577   push_state (&s, COMP_DERIVED, gfc_new_block);
3578
3579   gfc_new_block->component_access = ACCESS_PUBLIC;
3580   seen_private = 0;
3581   seen_sequence = 0;
3582   seen_component = 0;
3583
3584   compiling_type = 1;
3585
3586   while (compiling_type)
3587     {
3588       st = next_statement ();
3589       switch (st)
3590         {
3591         case ST_NONE:
3592           unexpected_eof ();
3593
3594         case ST_DATA_DECL:
3595         case ST_PROCEDURE:
3596           accept_statement (st);
3597           seen_component = 1;
3598           break;
3599
3600         case ST_FINAL:
3601           gfc_error ("FINAL declaration at %C must be inside CONTAINS");
3602           break;
3603
3604         case ST_END_TYPE:
3605 endType:
3606           compiling_type = 0;
3607
3608           if (!seen_component)
3609             gfc_notify_std (GFC_STD_F2003, "Derived type "
3610                             "definition at %C without components");
3611
3612           accept_statement (ST_END_TYPE);
3613           break;
3614
3615         case ST_PRIVATE:
3616           if (!gfc_find_state (COMP_MODULE))
3617             {
3618               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
3619                          "a MODULE");
3620               break;
3621             }
3622
3623           if (seen_component)
3624             {
3625               gfc_error ("PRIVATE statement at %C must precede "
3626                          "structure components");
3627               break;
3628             }
3629
3630           if (seen_private)
3631             gfc_error ("Duplicate PRIVATE statement at %C");
3632
3633           s.sym->component_access = ACCESS_PRIVATE;
3634
3635           accept_statement (ST_PRIVATE);
3636           seen_private = 1;
3637           break;
3638
3639         case ST_SEQUENCE:
3640           if (seen_component)
3641             {
3642               gfc_error ("SEQUENCE statement at %C must precede "
3643                          "structure components");
3644               break;
3645             }
3646
3647           if (gfc_current_block ()->attr.sequence)
3648             gfc_warning (0, "SEQUENCE attribute at %C already specified in "
3649                          "TYPE statement");
3650
3651           if (seen_sequence)
3652             {
3653               gfc_error ("Duplicate SEQUENCE statement at %C");
3654             }
3655
3656           seen_sequence = 1;
3657           gfc_add_sequence (&gfc_current_block ()->attr,
3658                             gfc_current_block ()->name, NULL);
3659           break;
3660
3661         case ST_CONTAINS:
3662           gfc_notify_std (GFC_STD_F2003,
3663                           "CONTAINS block in derived type"
3664                           " definition at %C");
3665
3666           accept_statement (ST_CONTAINS);
3667           parse_derived_contains ();
3668           goto endType;
3669
3670         default:
3671           unexpected_statement (st);
3672           break;
3673         }
3674     }
3675
3676   /* need to verify that all fields of the derived type are
3677    * interoperable with C if the type is declared to be bind(c)
3678    */
3679   sym = gfc_current_block ();
3680   for (c = sym->components; c; c = c->next)
3681     check_component (sym, c, &lock_comp, &event_comp);
3682
3683   if (!seen_component)
3684     sym->attr.zero_comp = 1;
3685
3686   pop_state ();
3687 }
3688
3689
3690 /* Parse an ENUM.  */
3691
3692 static void
3693 parse_enum (void)
3694 {
3695   gfc_statement st;
3696   int compiling_enum;
3697   gfc_state_data s;
3698   int seen_enumerator = 0;
3699
3700   push_state (&s, COMP_ENUM, gfc_new_block);
3701
3702   compiling_enum = 1;
3703
3704   while (compiling_enum)
3705     {
3706       st = next_statement ();
3707       switch (st)
3708         {
3709         case ST_NONE:
3710           unexpected_eof ();
3711           break;
3712
3713         case ST_ENUMERATOR:
3714           seen_enumerator = 1;
3715           accept_statement (st);
3716           break;
3717
3718         case ST_END_ENUM:
3719           compiling_enum = 0;
3720           if (!seen_enumerator)
3721             gfc_error ("ENUM declaration at %C has no ENUMERATORS");
3722           accept_statement (st);
3723           break;
3724
3725         default:
3726           gfc_free_enum_history ();
3727           unexpected_statement (st);
3728           break;
3729         }
3730     }
3731   pop_state ();
3732 }
3733
3734
3735 /* Parse an interface.  We must be able to deal with the possibility
3736    of recursive interfaces.  The parse_spec() subroutine is mutually
3737    recursive with parse_interface().  */
3738
3739 static gfc_statement parse_spec (gfc_statement);
3740
3741 static void
3742 parse_interface (void)
3743 {
3744   gfc_compile_state new_state = COMP_NONE, current_state;
3745   gfc_symbol *prog_unit, *sym;
3746   gfc_interface_info save;
3747   gfc_state_data s1, s2;
3748   gfc_statement st;
3749
3750   accept_statement (ST_INTERFACE);
3751
3752   current_interface.ns = gfc_current_ns;
3753   save = current_interface;
3754
3755   sym = (current_interface.type == INTERFACE_GENERIC
3756          || current_interface.type == INTERFACE_USER_OP)
3757         ? gfc_new_block : NULL;
3758
3759   push_state (&s1, COMP_INTERFACE, sym);
3760   current_state = COMP_NONE;
3761
3762 loop:
3763   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
3764
3765   st = next_statement ();
3766   switch (st)
3767     {
3768     case ST_NONE:
3769       unexpected_eof ();
3770
3771     case ST_SUBROUTINE:
3772     case ST_FUNCTION:
3773       if (st == ST_SUBROUTINE)
3774         new_state = COMP_SUBROUTINE;
3775       else if (st == ST_FUNCTION)
3776         new_state = COMP_FUNCTION;
3777       if (gfc_new_block->attr.pointer)
3778         {
3779           gfc_new_block->attr.pointer = 0;
3780           gfc_new_block->attr.proc_pointer = 1;
3781         }
3782       if (!gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
3783                                        gfc_new_block->formal, NULL))
3784         {
3785           reject_statement ();
3786           gfc_free_namespace (gfc_current_ns);
3787           goto loop;
3788         }
3789       /* F2008 C1210 forbids the IMPORT statement in module procedure
3790          interface bodies and the flag is set to import symbols.  */
3791       if (gfc_new_block->attr.module_procedure)
3792         gfc_current_ns->has_import_set = 1;
3793       break;
3794
3795     case ST_PROCEDURE:
3796     case ST_MODULE_PROC:        /* The module procedure matcher makes
3797                                    sure the context is correct.  */
3798       accept_statement (st);
3799       gfc_free_namespace (gfc_current_ns);
3800       goto loop;
3801
3802     case ST_END_INTERFACE:
3803       gfc_free_namespace (gfc_current_ns);
3804       gfc_current_ns = current_interface.ns;
3805       goto done;
3806
3807     default:
3808       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
3809                  gfc_ascii_statement (st));
3810       reject_statement ();
3811       gfc_free_namespace (gfc_current_ns);
3812       goto loop;
3813     }
3814
3815
3816   /* Make sure that the generic name has the right attribute.  */
3817   if (current_interface.type == INTERFACE_GENERIC
3818       && current_state == COMP_NONE)
3819     {
3820       if (new_state == COMP_FUNCTION && sym)
3821         gfc_add_function (&sym->attr, sym->name, NULL);
3822       else if (new_state == COMP_SUBROUTINE && sym)
3823         gfc_add_subroutine (&sym->attr, sym->name, NULL);
3824
3825       current_state = new_state;
3826     }
3827
3828   if (current_interface.type == INTERFACE_ABSTRACT)
3829     {
3830       gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
3831       if (gfc_is_intrinsic_typename (gfc_new_block->name))
3832         gfc_error ("Name %qs of ABSTRACT INTERFACE at %C "
3833                    "cannot be the same as an intrinsic type",
3834                    gfc_new_block->name);
3835     }
3836
3837   push_state (&s2, new_state, gfc_new_block);
3838   accept_statement (st);
3839   prog_unit = gfc_new_block;
3840   prog_unit->formal_ns = gfc_current_ns;
3841   if (prog_unit == prog_unit->formal_ns->proc_name
3842       && prog_unit->ns != prog_unit->formal_ns)
3843     prog_unit->refs++;
3844
3845 decl:
3846   /* Read data declaration statements.  */
3847   st = parse_spec (ST_NONE);
3848   in_specification_block = true;
3849
3850   /* Since the interface block does not permit an IMPLICIT statement,
3851      the default type for the function or the result must be taken
3852      from the formal namespace.  */
3853   if (new_state == COMP_FUNCTION)
3854     {
3855         if (prog_unit->result == prog_unit
3856               && prog_unit->ts.type == BT_UNKNOWN)
3857           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
3858         else if (prog_unit->result != prog_unit
3859                    && prog_unit->result->ts.type == BT_UNKNOWN)
3860           gfc_set_default_type (prog_unit->result, 1,
3861                                 prog_unit->formal_ns);
3862     }
3863
3864   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
3865     {
3866       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
3867                  gfc_ascii_statement (st));
3868       reject_statement ();
3869       goto decl;
3870     }
3871
3872   /* Add EXTERNAL attribute to function or subroutine.  */
3873   if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
3874     gfc_add_external (&prog_unit->attr, &gfc_current_locus);
3875
3876   current_interface = save;
3877   gfc_add_interface (prog_unit);
3878   pop_state ();
3879
3880   if (current_interface.ns
3881         && current_interface.ns->proc_name
3882         && strcmp (current_interface.ns->proc_name->name,
3883                    prog_unit->name) == 0)
3884     gfc_error ("INTERFACE procedure %qs at %L has the same name as the "
3885                "enclosing procedure", prog_unit->name,
3886                &current_interface.ns->proc_name->declared_at);
3887
3888   goto loop;
3889
3890 done:
3891   pop_state ();
3892 }
3893
3894
3895 /* Associate function characteristics by going back to the function
3896    declaration and rematching the prefix.  */
3897
3898 static match
3899 match_deferred_characteristics (gfc_typespec * ts)
3900 {
3901   locus loc;
3902   match m = MATCH_ERROR;
3903   char name[GFC_MAX_SYMBOL_LEN + 1];
3904
3905   loc = gfc_current_locus;
3906
3907   gfc_current_locus = gfc_current_block ()->declared_at;
3908
3909   gfc_clear_error ();
3910   gfc_buffer_error (true);
3911   m = gfc_match_prefix (ts);
3912   gfc_buffer_error (false);
3913
3914   if (ts->type == BT_DERIVED)
3915     {
3916       ts->kind = 0;
3917
3918       if (!ts->u.derived)
3919         m = MATCH_ERROR;
3920     }
3921
3922   /* Only permit one go at the characteristic association.  */
3923   if (ts->kind == -1)
3924     ts->kind = 0;
3925
3926   /* Set the function locus correctly.  If we have not found the
3927      function name, there is an error.  */
3928   if (m == MATCH_YES
3929       && gfc_match ("function% %n", name) == MATCH_YES
3930       && strcmp (name, gfc_current_block ()->name) == 0)
3931     {
3932       gfc_current_block ()->declared_at = gfc_current_locus;
3933       gfc_commit_symbols ();
3934     }
3935   else
3936     {
3937       gfc_error_check ();
3938       gfc_undo_symbols ();
3939     }
3940
3941   gfc_current_locus =loc;
3942   return m;
3943 }
3944
3945
3946 /* Check specification-expressions in the function result of the currently
3947    parsed block and ensure they are typed (give an IMPLICIT type if necessary).
3948    For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
3949    scope are not yet parsed so this has to be delayed up to parse_spec.  */
3950
3951 static void
3952 check_function_result_typed (void)
3953 {
3954   gfc_typespec ts;
3955
3956   gcc_assert (gfc_current_state () == COMP_FUNCTION);
3957
3958   if (!gfc_current_ns->proc_name->result) return;
3959
3960   ts = gfc_current_ns->proc_name->result->ts;
3961
3962   /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
3963   /* TODO:  Extend when KIND type parameters are implemented.  */
3964   if (ts.type == BT_CHARACTER && ts.u.cl && ts.u.cl->length)
3965     gfc_expr_check_typed (ts.u.cl->length, gfc_current_ns, true);
3966 }
3967
3968
3969 /* Parse a set of specification statements.  Returns the statement
3970    that doesn't fit.  */
3971
3972 static gfc_statement
3973 parse_spec (gfc_statement st)
3974 {
3975   st_state ss;
3976   bool function_result_typed = false;
3977   bool bad_characteristic = false;
3978   gfc_typespec *ts;
3979
3980   in_specification_block = true;
3981
3982   verify_st_order (&ss, ST_NONE, false);
3983   if (st == ST_NONE)
3984     st = next_statement ();
3985
3986   /* If we are not inside a function or don't have a result specified so far,
3987      do nothing special about it.  */
3988   if (gfc_current_state () != COMP_FUNCTION)
3989     function_result_typed = true;
3990   else
3991     {
3992       gfc_symbol* proc = gfc_current_ns->proc_name;
3993       gcc_assert (proc);
3994
3995       if (proc->result->ts.type == BT_UNKNOWN)
3996         function_result_typed = true;
3997     }
3998
3999 loop:
4000
4001   /* If we're inside a BLOCK construct, some statements are disallowed.
4002      Check this here.  Attribute declaration statements like INTENT, OPTIONAL
4003      or VALUE are also disallowed, but they don't have a particular ST_*
4004      key so we have to check for them individually in their matcher routine.  */
4005   if (gfc_current_state () == COMP_BLOCK)
4006     switch (st)
4007       {
4008         case ST_IMPLICIT:
4009         case ST_IMPLICIT_NONE:
4010         case ST_NAMELIST:
4011         case ST_COMMON:
4012         case ST_EQUIVALENCE:
4013         case ST_STATEMENT_FUNCTION:
4014           gfc_error ("%s statement is not allowed inside of BLOCK at %C",
4015                      gfc_ascii_statement (st));
4016           reject_statement ();
4017           break;
4018
4019         default:
4020           break;
4021       }
4022   else if (gfc_current_state () == COMP_BLOCK_DATA)
4023     /* Fortran 2008, C1116.  */
4024     switch (st)
4025       {
4026         case ST_ATTR_DECL:
4027         case ST_COMMON:
4028         case ST_DATA:
4029         case ST_DATA_DECL:
4030         case ST_DERIVED_DECL:
4031         case ST_END_BLOCK_DATA:
4032         case ST_EQUIVALENCE:
4033         case ST_IMPLICIT:
4034         case ST_IMPLICIT_NONE:
4035         case ST_OMP_THREADPRIVATE:
4036         case ST_PARAMETER:
4037         case ST_STRUCTURE_DECL:
4038         case ST_TYPE:
4039         case ST_USE:
4040           break;
4041
4042         case ST_NONE:
4043           break;
4044
4045         default:
4046           gfc_error ("%s statement is not allowed inside of BLOCK DATA at %C",
4047                      gfc_ascii_statement (st));
4048           reject_statement ();
4049           break;
4050       }
4051
4052   /* If we find a statement that cannot be followed by an IMPLICIT statement
4053      (and thus we can expect to see none any further), type the function result
4054      if it has not yet been typed.  Be careful not to give the END statement
4055      to verify_st_order!  */
4056   if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
4057     {
4058       bool verify_now = false;
4059
4060       if (st == ST_END_FUNCTION || st == ST_CONTAINS)
4061         verify_now = true;
4062       else
4063         {
4064           st_state dummyss;
4065           verify_st_order (&dummyss, ST_NONE, false);
4066           verify_st_order (&dummyss, st, false);
4067
4068           if (!verify_st_order (&dummyss, ST_IMPLICIT, true))
4069             verify_now = true;
4070         }
4071
4072       if (verify_now)
4073         {
4074           check_function_result_typed ();
4075           function_result_typed = true;
4076         }
4077     }
4078
4079   switch (st)
4080     {
4081     case ST_NONE:
4082       unexpected_eof ();
4083
4084     case ST_IMPLICIT_NONE:
4085     case ST_IMPLICIT:
4086       if (!function_result_typed)
4087         {
4088           check_function_result_typed ();
4089           function_result_typed = true;
4090         }
4091       goto declSt;
4092
4093     case ST_FORMAT:
4094     case ST_ENTRY:
4095     case ST_DATA:       /* Not allowed in interfaces */
4096       if (gfc_current_state () == COMP_INTERFACE)
4097         break;
4098
4099       /* Fall through */
4100
4101     case ST_USE:
4102     case ST_IMPORT:
4103     case ST_PARAMETER:
4104     case ST_PUBLIC:
4105     case ST_PRIVATE:
4106     case ST_STRUCTURE_DECL:
4107     case ST_DERIVED_DECL:
4108     case_decl:
4109     case_omp_decl:
4110 declSt:
4111       if (!verify_st_order (&ss, st, false))
4112         {
4113           reject_statement ();
4114           st = next_statement ();
4115           goto loop;
4116         }
4117
4118       switch (st)
4119         {
4120         case ST_INTERFACE:
4121           parse_interface ();
4122           break;
4123
4124         case ST_STRUCTURE_DECL:
4125           parse_struct_map (ST_STRUCTURE_DECL);
4126           break;
4127
4128         case ST_DERIVED_DECL:
4129           parse_derived ();
4130           break;
4131
4132         case ST_PUBLIC:
4133         case ST_PRIVATE:
4134           if (gfc_current_state () != COMP_MODULE)
4135             {
4136               gfc_error ("%s statement must appear in a MODULE",
4137                          gfc_ascii_statement (st));
4138               reject_statement ();
4139               break;
4140             }
4141
4142           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
4143             {
4144               gfc_error ("%s statement at %C follows another accessibility "
4145                          "specification", gfc_ascii_statement (st));
4146               reject_statement ();
4147               break;
4148             }
4149
4150           gfc_current_ns->default_access = (st == ST_PUBLIC)
4151             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
4152
4153           break;
4154
4155         case ST_STATEMENT_FUNCTION:
4156           if (gfc_current_state () == COMP_MODULE
4157               || gfc_current_state () == COMP_SUBMODULE)
4158             {
4159               unexpected_statement (st);
4160               break;
4161             }
4162
4163         default:
4164           break;
4165         }
4166
4167       accept_statement (st);
4168       st = next_statement ();
4169       goto loop;
4170
4171     case ST_ENUM:
4172       accept_statement (st);
4173       parse_enum();
4174       st = next_statement ();
4175       goto loop;
4176
4177     case ST_GET_FCN_CHARACTERISTICS:
4178       /* This statement triggers the association of a function's result
4179          characteristics.  */
4180       ts = &gfc_current_block ()->result->ts;
4181       if (match_deferred_characteristics (ts) != MATCH_YES)
4182         bad_characteristic = true;
4183
4184       st = next_statement ();
4185       goto loop;
4186
4187     default:
4188       break;
4189     }
4190
4191   /* If match_deferred_characteristics failed, then there is an error.  */
4192   if (bad_characteristic)
4193     {
4194       ts = &gfc_current_block ()->result->ts;
4195       if (ts->type != BT_DERIVED)
4196         gfc_error ("Bad kind expression for function %qs at %L",
4197                    gfc_current_block ()->name,
4198                    &gfc_current_block ()->declared_at);
4199       else
4200         gfc_error ("The type for function %qs at %L is not accessible",
4201                    gfc_current_block ()->name,
4202                    &gfc_current_block ()->declared_at);
4203
4204       gfc_current_block ()->ts.kind = 0;
4205       /* Keep the derived type; if it's bad, it will be discovered later.  */
4206       if (!(ts->type == BT_DERIVED && ts->u.derived))
4207         ts->type = BT_UNKNOWN;
4208     }
4209
4210   in_specification_block = false;
4211
4212   return st;
4213 }
4214
4215
4216 /* Parse a WHERE block, (not a simple WHERE statement).  */
4217
4218 static void
4219 parse_where_block (void)
4220 {
4221   int seen_empty_else;
4222   gfc_code *top, *d;
4223   gfc_state_data s;
4224   gfc_statement st;
4225
4226   accept_statement (ST_WHERE_BLOCK);
4227   top = gfc_state_stack->tail;
4228
4229   push_state (&s, COMP_WHERE, gfc_new_block);
4230
4231   d = add_statement ();
4232   d->expr1 = top->expr1;
4233   d->op = EXEC_WHERE;
4234
4235   top->expr1 = NULL;
4236   top->block = d;
4237
4238   seen_empty_else = 0;
4239
4240   do
4241     {
4242       st = next_statement ();
4243       switch (st)
4244         {
4245         case ST_NONE:
4246           unexpected_eof ();
4247
4248         case ST_WHERE_BLOCK:
4249           parse_where_block ();
4250           break;
4251
4252         case ST_ASSIGNMENT:
4253         case ST_WHERE:
4254           accept_statement (st);
4255           break;
4256
4257         case ST_ELSEWHERE:
4258           if (seen_empty_else)
4259             {
4260               gfc_error ("ELSEWHERE statement at %C follows previous "
4261                          "unmasked ELSEWHERE");
4262               reject_statement ();
4263               break;
4264             }
4265
4266           if (new_st.expr1 == NULL)
4267             seen_empty_else = 1;
4268
4269           d = new_level (gfc_state_stack->head);
4270           d->op = EXEC_WHERE;
4271           d->expr1 = new_st.expr1;
4272
4273           accept_statement (st);
4274
4275           break;
4276
4277         case ST_END_WHERE:
4278           accept_statement (st);
4279           break;
4280
4281         default:
4282           gfc_error ("Unexpected %s statement in WHERE block at %C",
4283                      gfc_ascii_statement (st));
4284           reject_statement ();
4285           break;
4286         }
4287     }
4288   while (st != ST_END_WHERE);
4289
4290   pop_state ();
4291 }
4292
4293
4294 /* Parse a FORALL block (not a simple FORALL statement).  */
4295
4296 static void
4297 parse_forall_block (void)
4298 {
4299   gfc_code *top, *d;
4300   gfc_state_data s;
4301   gfc_statement st;
4302
4303   accept_statement (ST_FORALL_BLOCK);
4304   top = gfc_state_stack->tail;
4305
4306   push_state (&s, COMP_FORALL, gfc_new_block);
4307
4308   d = add_statement ();
4309   d->op = EXEC_FORALL;
4310   top->block = d;
4311
4312   do
4313     {
4314       st = next_statement ();
4315       switch (st)
4316         {
4317
4318         case ST_ASSIGNMENT:
4319         case ST_POINTER_ASSIGNMENT:
4320         case ST_WHERE:
4321         case ST_FORALL:
4322           accept_statement (st);
4323           break;
4324
4325         case ST_WHERE_BLOCK:
4326           parse_where_block ();
4327           break;
4328
4329         case ST_FORALL_BLOCK:
4330           parse_forall_block ();
4331           break;
4332
4333         case ST_END_FORALL:
4334           accept_statement (st);
4335           break;
4336
4337         case ST_NONE:
4338           unexpected_eof ();
4339
4340         default:
4341           gfc_error ("Unexpected %s statement in FORALL block at %C",
4342                      gfc_ascii_statement (st));
4343
4344           reject_statement ();
4345           break;
4346         }
4347     }
4348   while (st != ST_END_FORALL);
4349
4350   pop_state ();
4351 }
4352
4353
4354 static gfc_statement parse_executable (gfc_statement);
4355
4356 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
4357
4358 static void
4359 parse_if_block (void)
4360 {
4361   gfc_code *top, *d;
4362   gfc_statement st;
4363   locus else_locus;
4364   gfc_state_data s;
4365   int seen_else;
4366
4367   seen_else = 0;
4368   accept_statement (ST_IF_BLOCK);
4369
4370   top = gfc_state_stack->tail;
4371   push_state (&s, COMP_IF, gfc_new_block);
4372
4373   new_st.op = EXEC_IF;
4374   d = add_statement ();
4375
4376   d->expr1 = top->expr1;
4377   top->expr1 = NULL;
4378   top->block = d;
4379
4380   do
4381     {
4382       st = parse_executable (ST_NONE);
4383
4384       switch (st)
4385         {
4386         case ST_NONE:
4387           unexpected_eof ();
4388
4389         case ST_ELSEIF:
4390           if (seen_else)
4391             {
4392               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
4393                          "statement at %L", &else_locus);
4394
4395               reject_statement ();
4396               break;
4397             }
4398
4399           d = new_level (gfc_state_stack->head);
4400           d->op = EXEC_IF;
4401           d->expr1 = new_st.expr1;
4402
4403           accept_statement (st);
4404
4405           break;
4406
4407         case ST_ELSE:
4408           if (seen_else)
4409             {
4410               gfc_error ("Duplicate ELSE statements at %L and %C",
4411                          &else_locus);
4412               reject_statement ();
4413               break;
4414             }
4415
4416           seen_else = 1;
4417           else_locus = gfc_current_locus;
4418
4419           d = new_level (gfc_state_stack->head);
4420           d->op = EXEC_IF;
4421
4422           accept_statement (st);
4423
4424           break;
4425
4426         case ST_ENDIF:
4427           break;
4428
4429         default:
4430           unexpected_statement (st);
4431           break;
4432         }
4433     }
4434   while (st != ST_ENDIF);
4435
4436   pop_state ();
4437   accept_statement (st);
4438 }
4439
4440
4441 /* Parse a SELECT block.  */
4442
4443 static void
4444 parse_select_block (void)
4445 {
4446   gfc_statement st;
4447   gfc_code *cp;
4448   gfc_state_data s;
4449
4450   accept_statement (ST_SELECT_CASE);
4451
4452   cp = gfc_state_stack->tail;
4453   push_state (&s, COMP_SELECT, gfc_new_block);
4454
4455   /* Make sure that the next statement is a CASE or END SELECT.  */
4456   for (;;)
4457     {
4458       st = next_statement ();
4459       if (st == ST_NONE)
4460         unexpected_eof ();
4461       if (st == ST_END_SELECT)
4462         {
4463           /* Empty SELECT CASE is OK.  */
4464           accept_statement (st);
4465           pop_state ();
4466           return;
4467         }
4468       if (st == ST_CASE)
4469         break;
4470
4471       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
4472                  "CASE at %C");
4473
4474       reject_statement ();
4475     }
4476
4477   /* At this point, we've got a nonempty select block.  */
4478   cp = new_level (cp);
4479   *cp = new_st;
4480
4481   accept_statement (st);
4482
4483   do
4484     {
4485       st = parse_executable (ST_NONE);
4486       switch (st)
4487         {
4488         case ST_NONE:
4489           unexpected_eof ();
4490
4491         case ST_CASE:
4492           cp = new_level (gfc_state_stack->head);
4493           *cp = new_st;
4494           gfc_clear_new_st ();
4495
4496           accept_statement (st);
4497           /* Fall through */
4498
4499         case ST_END_SELECT:
4500           break;
4501
4502         /* Can't have an executable statement because of
4503            parse_executable().  */
4504         default:
4505           unexpected_statement (st);
4506           break;
4507         }
4508     }
4509   while (st != ST_END_SELECT);
4510
4511   pop_state ();
4512   accept_statement (st);
4513 }
4514
4515
4516 /* Pop the current selector from the SELECT TYPE stack.  */
4517
4518 static void
4519 select_type_pop (void)
4520 {
4521   gfc_select_type_stack *old = select_type_stack;
4522   select_type_stack = old->prev;
4523   free (old);
4524 }
4525
4526
4527 /* Parse a SELECT TYPE construct (F03:R821).  */
4528
4529 static void
4530 parse_select_type_block (void)
4531 {
4532   gfc_statement st;
4533   gfc_code *cp;
4534   gfc_state_data s;
4535
4536   gfc_current_ns = new_st.ext.block.ns;
4537   accept_statement (ST_SELECT_TYPE);
4538
4539   cp = gfc_state_stack->tail;
4540   push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
4541
4542   /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
4543      or END SELECT.  */
4544   for (;;)
4545     {
4546       st = next_statement ();
4547       if (st == ST_NONE)
4548         unexpected_eof ();
4549       if (st == ST_END_SELECT)
4550         /* Empty SELECT CASE is OK.  */
4551         goto done;
4552       if (st == ST_TYPE_IS || st == ST_CLASS_IS)
4553         break;
4554
4555       gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
4556                  "following SELECT TYPE at %C");
4557
4558       reject_statement ();
4559     }
4560
4561   /* At this point, we've got a nonempty select block.  */
4562   cp = new_level (cp);
4563   *cp = new_st;
4564
4565   accept_statement (st);
4566
4567   do
4568     {
4569       st = parse_executable (ST_NONE);
4570       switch (st)
4571         {
4572         case ST_NONE:
4573           unexpected_eof ();
4574
4575         case ST_TYPE_IS:
4576         case ST_CLASS_IS:
4577           cp = new_level (gfc_state_stack->head);
4578           *cp = new_st;
4579           gfc_clear_new_st ();
4580
4581           accept_statement (st);
4582           /* Fall through */
4583
4584         case ST_END_SELECT:
4585           break;
4586
4587         /* Can't have an executable statement because of
4588            parse_executable().  */
4589         default:
4590           unexpected_statement (st);
4591           break;
4592         }
4593     }
4594   while (st != ST_END_SELECT);
4595
4596 done:
4597   pop_state ();
4598   accept_statement (st);
4599   gfc_current_ns = gfc_current_ns->parent;
4600   select_type_pop ();
4601 }
4602
4603
4604 /* Parse a SELECT RANK construct.  */
4605
4606 static void
4607 parse_select_rank_block (void)
4608 {
4609   gfc_statement st;
4610   gfc_code *cp;
4611   gfc_state_data s;
4612
4613   gfc_current_ns = new_st.ext.block.ns;
4614   accept_statement (ST_SELECT_RANK);
4615
4616   cp = gfc_state_stack->tail;
4617   push_state (&s, COMP_SELECT_RANK, gfc_new_block);
4618
4619   /* Make sure that the next statement is a RANK IS or RANK DEFAULT.  */
4620   for (;;)
4621     {
4622       st = next_statement ();
4623       if (st == ST_NONE)
4624         unexpected_eof ();
4625       if (st == ST_END_SELECT)
4626         /* Empty SELECT CASE is OK.  */
4627         goto done;
4628       if (st == ST_RANK)
4629         break;
4630
4631       gfc_error ("Expected RANK or RANK DEFAULT "
4632                  "following SELECT RANK at %C");
4633
4634       reject_statement ();
4635     }
4636
4637   /* At this point, we've got a nonempty select block.  */
4638   cp = new_level (cp);
4639   *cp = new_st;
4640
4641   accept_statement (st);
4642
4643   do
4644     {
4645       st = parse_executable (ST_NONE);
4646       switch (st)
4647         {
4648         case ST_NONE:
4649           unexpected_eof ();
4650
4651         case ST_RANK:
4652           cp = new_level (gfc_state_stack->head);
4653           *cp = new_st;
4654           gfc_clear_new_st ();
4655
4656           accept_statement (st);
4657           /* Fall through */
4658
4659         case ST_END_SELECT:
4660           break;
4661
4662         /* Can't have an executable statement because of
4663            parse_executable().  */
4664         default:
4665           unexpected_statement (st);
4666           break;
4667         }
4668     }
4669   while (st != ST_END_SELECT);
4670
4671 done:
4672   pop_state ();
4673   accept_statement (st);
4674   gfc_current_ns = gfc_current_ns->parent;
4675   select_type_pop ();
4676 }
4677
4678
4679 /* Given a symbol, make sure it is not an iteration variable for a DO
4680    statement.  This subroutine is called when the symbol is seen in a
4681    context that causes it to become redefined.  If the symbol is an
4682    iterator, we generate an error message and return nonzero.  */
4683
4684 int
4685 gfc_check_do_variable (gfc_symtree *st)
4686 {
4687   gfc_state_data *s;
4688
4689   if (!st)
4690     return 0;
4691
4692   for (s=gfc_state_stack; s; s = s->previous)
4693     if (s->do_variable == st)
4694       {
4695         gfc_error_now ("Variable %qs at %C cannot be redefined inside "
4696                        "loop beginning at %L", st->name, &s->head->loc);
4697         return 1;
4698       }
4699
4700   return 0;
4701 }
4702
4703
4704 /* Checks to see if the current statement label closes an enddo.
4705    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
4706    an error) if it incorrectly closes an ENDDO.  */
4707
4708 static int
4709 check_do_closure (void)
4710 {
4711   gfc_state_data *p;
4712
4713   if (gfc_statement_label == NULL)
4714     return 0;
4715
4716   for (p = gfc_state_stack; p; p = p->previous)
4717     if (p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
4718       break;
4719
4720   if (p == NULL)
4721     return 0;           /* No loops to close */
4722
4723   if (p->ext.end_do_label == gfc_statement_label)
4724     {
4725       if (p == gfc_state_stack)
4726         return 1;
4727
4728       gfc_error ("End of nonblock DO statement at %C is within another block");
4729       return 2;
4730     }
4731
4732   /* At this point, the label doesn't terminate the innermost loop.
4733      Make sure it doesn't terminate another one.  */
4734   for (; p; p = p->previous)
4735     if ((p->state == COMP_DO || p->state == COMP_DO_CONCURRENT)
4736         && p->ext.end_do_label == gfc_statement_label)
4737       {
4738         gfc_error ("End of nonblock DO statement at %C is interwoven "
4739                    "with another DO loop");
4740         return 2;
4741       }
4742
4743   return 0;
4744 }
4745
4746
4747 /* Parse a series of contained program units.  */
4748
4749 static void parse_progunit (gfc_statement);
4750
4751
4752 /* Parse a CRITICAL block.  */
4753
4754 static void
4755 parse_critical_block (void)
4756 {
4757   gfc_code *top, *d;
4758   gfc_state_data s, *sd;
4759   gfc_statement st;
4760
4761   for (sd = gfc_state_stack; sd; sd = sd->previous)
4762     if (sd->state == COMP_OMP_STRUCTURED_BLOCK)
4763       gfc_error_now (is_oacc (sd)
4764                      ? G_("CRITICAL block inside of OpenACC region at %C")
4765                      : G_("CRITICAL block inside of OpenMP region at %C"));
4766
4767   s.ext.end_do_label = new_st.label1;
4768
4769   accept_statement (ST_CRITICAL);
4770   top = gfc_state_stack->tail;
4771
4772   push_state (&s, COMP_CRITICAL, gfc_new_block);
4773
4774   d = add_statement ();
4775   d->op = EXEC_CRITICAL;
4776   top->block = d;
4777
4778   do
4779     {
4780       st = parse_executable (ST_NONE);
4781
4782       switch (st)
4783         {
4784           case ST_NONE:
4785             unexpected_eof ();
4786             break;
4787
4788           case ST_END_CRITICAL:
4789             if (s.ext.end_do_label != NULL
4790                 && s.ext.end_do_label != gfc_statement_label)
4791               gfc_error_now ("Statement label in END CRITICAL at %C does not "
4792                              "match CRITICAL label");
4793
4794             if (gfc_statement_label != NULL)
4795               {
4796                 new_st.op = EXEC_NOP;
4797                 add_statement ();
4798               }
4799             break;
4800
4801           default:
4802             unexpected_statement (st);
4803             break;
4804         }
4805     }
4806   while (st != ST_END_CRITICAL);
4807
4808   pop_state ();
4809   accept_statement (st);
4810 }
4811
4812
4813 /* Set up the local namespace for a BLOCK construct.  */
4814
4815 gfc_namespace*
4816 gfc_build_block_ns (gfc_namespace *parent_ns)
4817 {
4818   gfc_namespace* my_ns;
4819   static int numblock = 1;
4820
4821   my_ns = gfc_get_namespace (parent_ns, 1);
4822   my_ns->construct_entities = 1;
4823
4824   /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
4825      code generation (so it must not be NULL).
4826      We set its recursive argument if our container procedure is recursive, so
4827      that local variables are accordingly placed on the stack when it
4828      will be necessary.  */
4829   if (gfc_new_block)
4830     my_ns->proc_name = gfc_new_block;
4831   else
4832     {
4833       bool t;
4834       char buffer[20];  /* Enough to hold "block@2147483648\n".  */
4835
4836       snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
4837       gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
4838       t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
4839                           my_ns->proc_name->name, NULL);
4840       gcc_assert (t);
4841       gfc_commit_symbol (my_ns->proc_name);
4842     }
4843
4844   if (parent_ns->proc_name)
4845     my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
4846
4847   return my_ns;
4848 }
4849
4850
4851 /* Parse a BLOCK construct.  */
4852
4853 static void
4854 parse_block_construct (void)
4855 {
4856   gfc_namespace* my_ns;
4857   gfc_namespace* my_parent;
4858   gfc_state_data s;
4859
4860   gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
4861
4862   my_ns = gfc_build_block_ns (gfc_current_ns);
4863
4864   new_st.op = EXEC_BLOCK;
4865   new_st.ext.block.ns = my_ns;
4866   new_st.ext.block.assoc = NULL;
4867   accept_statement (ST_BLOCK);
4868
4869   push_state (&s, COMP_BLOCK, my_ns->proc_name);
4870   gfc_current_ns = my_ns;
4871   my_parent = my_ns->parent;
4872
4873   parse_progunit (ST_NONE);
4874
4875   /* Don't depend on the value of gfc_current_ns;  it might have been
4876      reset if the block had errors and was cleaned up.  */
4877   gfc_current_ns = my_parent;
4878
4879   pop_state ();
4880 }
4881
4882
4883 /* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
4884    behind the scenes with compiler-generated variables.  */
4885
4886 static void
4887 parse_associate (void)
4888 {
4889   gfc_namespace* my_ns;
4890   gfc_state_data s;
4891   gfc_statement st;
4892   gfc_association_list* a;
4893
4894   gfc_notify_std (GFC_STD_F2003, "ASSOCIATE construct at %C");
4895
4896   my_ns = gfc_build_block_ns (gfc_current_ns);
4897
4898   new_st.op = EXEC_BLOCK;
4899   new_st.ext.block.ns = my_ns;
4900   gcc_assert (new_st.ext.block.assoc);
4901
4902   /* Add all associate-names as BLOCK variables.  Creating them is enough
4903      for now, they'll get their values during trans-* phase.  */
4904   gfc_current_ns = my_ns;
4905   for (a = new_st.ext.block.assoc; a; a = a->next)
4906     {
4907       gfc_symbol* sym;
4908       gfc_ref *ref;
4909       gfc_array_ref *array_ref;
4910
4911       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
4912         gcc_unreachable ();
4913
4914       sym = a->st->n.sym;
4915       sym->attr.flavor = FL_VARIABLE;
4916       sym->assoc = a;
4917       sym->declared_at = a->where;
4918       gfc_set_sym_referenced (sym);
4919
4920       /* Initialize the typespec.  It is not available in all cases,
4921          however, as it may only be set on the target during resolution.
4922          Still, sometimes it helps to have it right now -- especially
4923          for parsing component references on the associate-name
4924          in case of association to a derived-type.  */
4925       sym->ts = a->target->ts;
4926
4927       /* Check if the target expression is array valued.  This cannot always
4928          be done by looking at target.rank, because that might not have been
4929          set yet.  Therefore traverse the chain of refs, looking for the last
4930          array ref and evaluate that.  */
4931       array_ref = NULL;
4932       for (ref = a->target->ref; ref; ref = ref->next)
4933         if (ref->type == REF_ARRAY)
4934           array_ref = &ref->u.ar;
4935       if (array_ref || a->target->rank)
4936         {
4937           gfc_array_spec *as;
4938           int dim, rank = 0;
4939           if (array_ref)
4940             {
4941               a->rankguessed = 1;
4942               /* Count the dimension, that have a non-scalar extend.  */
4943               for (dim = 0; dim < array_ref->dimen; ++dim)
4944                 if (array_ref->dimen_type[dim] != DIMEN_ELEMENT
4945                     && !(array_ref->dimen_type[dim] == DIMEN_UNKNOWN
4946                          && array_ref->end[dim] == NULL
4947                          && array_ref->start[dim] != NULL))
4948                   ++rank;
4949             }
4950           else
4951             rank = a->target->rank;
4952           /* When the rank is greater than zero then sym will be an array.  */
4953           if (sym->ts.type == BT_CLASS && CLASS_DATA (sym))
4954             {
4955               if ((!CLASS_DATA (sym)->as && rank != 0)
4956                   || (CLASS_DATA (sym)->as
4957                       && CLASS_DATA (sym)->as->rank != rank))
4958                 {
4959                   /* Don't just (re-)set the attr and as in the sym.ts,
4960                      because this modifies the target's attr and as.  Copy the
4961                      data and do a build_class_symbol.  */
4962                   symbol_attribute attr = CLASS_DATA (a->target)->attr;
4963                   int corank = gfc_get_corank (a->target);
4964                   gfc_typespec type;
4965
4966                   if (rank || corank)
4967                     {
4968                       as = gfc_get_array_spec ();
4969                       as->type = AS_DEFERRED;
4970                       as->rank = rank;
4971                       as->corank = corank;
4972                       attr.dimension = rank ? 1 : 0;
4973                       attr.codimension = corank ? 1 : 0;
4974                     }
4975                   else
4976                     {
4977                       as = NULL;
4978                       attr.dimension = attr.codimension = 0;
4979                     }
4980                   attr.class_ok = 0;
4981                   type = CLASS_DATA (sym)->ts;
4982                   if (!gfc_build_class_symbol (&type,
4983                                                &attr, &as))
4984                     gcc_unreachable ();
4985                   sym->ts = type;
4986                   sym->ts.type = BT_CLASS;
4987                   sym->attr.class_ok = 1;
4988                 }
4989               else
4990                 sym->attr.class_ok = 1;
4991             }
4992           else if ((!sym->as && rank != 0)
4993                    || (sym->as && sym->as->rank != rank))
4994             {
4995               as = gfc_get_array_spec ();
4996               as->type = AS_DEFERRED;
4997               as->rank = rank;
4998               as->corank = gfc_get_corank (a->target);
4999               sym->as = as;
5000               sym->attr.dimension = 1;
5001               if (as->corank)
5002                 sym->attr.codimension = 1;
5003             }
5004         }
5005     }
5006
5007   accept_statement (ST_ASSOCIATE);
5008   push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
5009
5010 loop:
5011   st = parse_executable (ST_NONE);
5012   switch (st)
5013     {
5014     case ST_NONE:
5015       unexpected_eof ();
5016
5017     case_end:
5018       accept_statement (st);
5019       my_ns->code = gfc_state_stack->head;
5020       break;
5021
5022     default:
5023       unexpected_statement (st);
5024       goto loop;
5025     }
5026
5027   gfc_current_ns = gfc_current_ns->parent;
5028   pop_state ();
5029 }
5030
5031
5032 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
5033    handled inside of parse_executable(), because they aren't really
5034    loop statements.  */
5035
5036 static void
5037 parse_do_block (void)
5038 {
5039   gfc_statement st;
5040   gfc_code *top;
5041   gfc_state_data s;
5042   gfc_symtree *stree;
5043   gfc_exec_op do_op;
5044
5045   do_op = new_st.op;
5046   s.ext.end_do_label = new_st.label1;
5047
5048   if (new_st.ext.iterator != NULL)
5049     {
5050       stree = new_st.ext.iterator->var->symtree;
5051       if (directive_unroll != -1)
5052         {
5053           new_st.ext.iterator->unroll = directive_unroll;
5054           directive_unroll = -1;
5055         }
5056       if (directive_ivdep)
5057         {
5058           new_st.ext.iterator->ivdep = directive_ivdep;
5059           directive_ivdep = false;
5060         }
5061       if (directive_vector)
5062         {
5063           new_st.ext.iterator->vector = directive_vector;
5064           directive_vector = false;
5065         }
5066       if (directive_novector)
5067         {
5068           new_st.ext.iterator->novector = directive_novector;
5069           directive_novector = false;
5070         }
5071     }
5072   else
5073     stree = NULL;
5074
5075   accept_statement (ST_DO);
5076
5077   top = gfc_state_stack->tail;
5078   push_state (&s, do_op == EXEC_DO_CONCURRENT ? COMP_DO_CONCURRENT : COMP_DO,
5079               gfc_new_block);
5080
5081   s.do_variable = stree;
5082
5083   top->block = new_level (top);
5084   top->block->op = EXEC_DO;
5085
5086 loop:
5087   st = parse_executable (ST_NONE);
5088
5089   switch (st)
5090     {
5091     case ST_NONE:
5092       unexpected_eof ();
5093
5094     case ST_ENDDO:
5095       if (s.ext.end_do_label != NULL
5096           && s.ext.end_do_label != gfc_statement_label)
5097         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
5098                        "DO label");
5099
5100       if (gfc_statement_label != NULL)
5101         {
5102           new_st.op = EXEC_NOP;
5103           add_statement ();
5104         }
5105       break;
5106
5107     case ST_IMPLIED_ENDDO:
5108      /* If the do-stmt of this DO construct has a do-construct-name,
5109         the corresponding end-do must be an end-do-stmt (with a matching
5110         name, but in that case we must have seen ST_ENDDO first).
5111         We only complain about this in pedantic mode.  */
5112      if (gfc_current_block () != NULL)
5113         gfc_error_now ("Named block DO at %L requires matching ENDDO name",
5114                        &gfc_current_block()->declared_at);
5115
5116       break;
5117
5118     default:
5119       unexpected_statement (st);
5120       goto loop;
5121     }
5122
5123   pop_state ();
5124   accept_statement (st);
5125 }
5126
5127
5128 /* Parse the statements of OpenMP do/parallel do.  */
5129
5130 static gfc_statement
5131 parse_omp_do (gfc_statement omp_st)
5132 {
5133   gfc_statement st;
5134   gfc_code *cp, *np;
5135   gfc_state_data s;
5136
5137   accept_statement (omp_st);
5138
5139   cp = gfc_state_stack->tail;
5140   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5141   np = new_level (cp);
5142   np->op = cp->op;
5143   np->block = NULL;
5144
5145   for (;;)
5146     {
5147       st = next_statement ();
5148       if (st == ST_NONE)
5149         unexpected_eof ();
5150       else if (st == ST_DO)
5151         break;
5152       else
5153         unexpected_statement (st);
5154     }
5155
5156   parse_do_block ();
5157   if (gfc_statement_label != NULL
5158       && gfc_state_stack->previous != NULL
5159       && gfc_state_stack->previous->state == COMP_DO
5160       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5161     {
5162       /* In
5163          DO 100 I=1,10
5164            !$OMP DO
5165              DO J=1,10
5166              ...
5167              100 CONTINUE
5168          there should be no !$OMP END DO.  */
5169       pop_state ();
5170       return ST_IMPLIED_ENDDO;
5171     }
5172
5173   check_do_closure ();
5174   pop_state ();
5175
5176   st = next_statement ();
5177   gfc_statement omp_end_st = ST_OMP_END_DO;
5178   switch (omp_st)
5179     {
5180     case ST_OMP_DISTRIBUTE: omp_end_st = ST_OMP_END_DISTRIBUTE; break;
5181     case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5182       omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO;
5183       break;
5184     case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5185       omp_end_st = ST_OMP_END_DISTRIBUTE_PARALLEL_DO_SIMD;
5186       break;
5187     case ST_OMP_DISTRIBUTE_SIMD:
5188       omp_end_st = ST_OMP_END_DISTRIBUTE_SIMD;
5189       break;
5190     case ST_OMP_DO: omp_end_st = ST_OMP_END_DO; break;
5191     case ST_OMP_DO_SIMD: omp_end_st = ST_OMP_END_DO_SIMD; break;
5192     case ST_OMP_LOOP: omp_end_st = ST_OMP_END_LOOP; break;
5193     case ST_OMP_PARALLEL_DO: omp_end_st = ST_OMP_END_PARALLEL_DO; break;
5194     case ST_OMP_PARALLEL_DO_SIMD:
5195       omp_end_st = ST_OMP_END_PARALLEL_DO_SIMD;
5196       break;
5197     case ST_OMP_PARALLEL_LOOP:
5198       omp_end_st = ST_OMP_END_PARALLEL_LOOP;
5199       break;
5200     case ST_OMP_SIMD: omp_end_st = ST_OMP_END_SIMD; break;
5201     case ST_OMP_TARGET_PARALLEL_DO:
5202       omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO;
5203       break;
5204     case ST_OMP_TARGET_PARALLEL_DO_SIMD:
5205       omp_end_st = ST_OMP_END_TARGET_PARALLEL_DO_SIMD;
5206       break;
5207     case ST_OMP_TARGET_PARALLEL_LOOP:
5208       omp_end_st = ST_OMP_END_TARGET_PARALLEL_LOOP;
5209       break;
5210     case ST_OMP_TARGET_SIMD: omp_end_st = ST_OMP_END_TARGET_SIMD; break;
5211     case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5212       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE;
5213       break;
5214     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5215       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO;
5216       break;
5217     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5218       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5219       break;
5220     case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5221       omp_end_st = ST_OMP_END_TARGET_TEAMS_DISTRIBUTE_SIMD;
5222       break;
5223     case ST_OMP_TARGET_TEAMS_LOOP:
5224       omp_end_st = ST_OMP_END_TARGET_TEAMS_LOOP;
5225       break;
5226     case ST_OMP_TASKLOOP: omp_end_st = ST_OMP_END_TASKLOOP; break;
5227     case ST_OMP_TASKLOOP_SIMD: omp_end_st = ST_OMP_END_TASKLOOP_SIMD; break;
5228     case ST_OMP_MASKED_TASKLOOP: omp_end_st = ST_OMP_END_MASKED_TASKLOOP; break;
5229     case ST_OMP_MASKED_TASKLOOP_SIMD:
5230       omp_end_st = ST_OMP_END_MASKED_TASKLOOP_SIMD;
5231       break;
5232     case ST_OMP_MASTER_TASKLOOP: omp_end_st = ST_OMP_END_MASTER_TASKLOOP; break;
5233     case ST_OMP_MASTER_TASKLOOP_SIMD:
5234       omp_end_st = ST_OMP_END_MASTER_TASKLOOP_SIMD;
5235       break;
5236     case ST_OMP_PARALLEL_MASKED_TASKLOOP:
5237       omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP;
5238       break;
5239     case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5240       omp_end_st = ST_OMP_END_PARALLEL_MASKED_TASKLOOP_SIMD;
5241       break;
5242     case ST_OMP_PARALLEL_MASTER_TASKLOOP:
5243       omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP;
5244       break;
5245     case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5246       omp_end_st = ST_OMP_END_PARALLEL_MASTER_TASKLOOP_SIMD;
5247       break;
5248     case ST_OMP_TEAMS_DISTRIBUTE:
5249       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
5250       break;
5251     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5252       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO;
5253       break;
5254     case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5255       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD;
5256       break;
5257     case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5258       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE_SIMD;
5259       break;
5260     case ST_OMP_TEAMS_LOOP:
5261       omp_end_st = ST_OMP_END_TEAMS_LOOP;
5262       break;
5263     default: gcc_unreachable ();
5264     }
5265   if (st == omp_end_st)
5266     {
5267       if (new_st.op == EXEC_OMP_END_NOWAIT)
5268         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
5269       else
5270         gcc_assert (new_st.op == EXEC_NOP);
5271       gfc_clear_new_st ();
5272       gfc_commit_symbols ();
5273       gfc_warning_check ();
5274       st = next_statement ();
5275     }
5276   return st;
5277 }
5278
5279
5280 /* Parse the statements of OpenMP atomic directive.  */
5281
5282 static gfc_statement
5283 parse_omp_oacc_atomic (bool omp_p)
5284 {
5285   gfc_statement st, st_atomic, st_end_atomic;
5286   gfc_code *cp, *np;
5287   gfc_state_data s;
5288   int count;
5289
5290   if (omp_p)
5291     {
5292       st_atomic = ST_OMP_ATOMIC;
5293       st_end_atomic = ST_OMP_END_ATOMIC;
5294     }
5295   else
5296     {
5297       st_atomic = ST_OACC_ATOMIC;
5298       st_end_atomic = ST_OACC_END_ATOMIC;
5299     }
5300   accept_statement (st_atomic);
5301
5302   cp = gfc_state_stack->tail;
5303   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5304   np = new_level (cp);
5305   np->op = cp->op;
5306   np->block = NULL;
5307   np->ext.omp_clauses = cp->ext.omp_clauses;
5308   cp->ext.omp_clauses = NULL;
5309   count = 1 + np->ext.omp_clauses->capture;
5310
5311   while (count)
5312     {
5313       st = next_statement ();
5314       if (st == ST_NONE)
5315         unexpected_eof ();
5316       else if (np->ext.omp_clauses->compare
5317                && (st == ST_SIMPLE_IF || st == ST_IF_BLOCK))
5318         {
5319           count--;
5320           if (st == ST_IF_BLOCK)
5321             {
5322               parse_if_block ();
5323               /* With else (or elseif).  */
5324               if (gfc_state_stack->tail->block->block)
5325                 count--;
5326             }
5327           accept_statement (st);
5328         }
5329       else if (st == ST_ASSIGNMENT
5330                && (!np->ext.omp_clauses->compare
5331                    || np->ext.omp_clauses->capture))
5332         {
5333           accept_statement (st);
5334           count--;
5335         }
5336       else
5337         unexpected_statement (st);
5338     }
5339
5340   pop_state ();
5341
5342   st = next_statement ();
5343   if (st == st_end_atomic)
5344     {
5345       gfc_clear_new_st ();
5346       gfc_commit_symbols ();
5347       gfc_warning_check ();
5348       st = next_statement ();
5349     }
5350   return st;
5351 }
5352
5353
5354 /* Parse the statements of an OpenACC structured block.  */
5355
5356 static void
5357 parse_oacc_structured_block (gfc_statement acc_st)
5358 {
5359   gfc_statement st, acc_end_st;
5360   gfc_code *cp, *np;
5361   gfc_state_data s, *sd;
5362
5363   for (sd = gfc_state_stack; sd; sd = sd->previous)
5364     if (sd->state == COMP_CRITICAL)
5365       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5366
5367   accept_statement (acc_st);
5368
5369   cp = gfc_state_stack->tail;
5370   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5371   np = new_level (cp);
5372   np->op = cp->op;
5373   np->block = NULL;
5374   switch (acc_st)
5375     {
5376     case ST_OACC_PARALLEL:
5377       acc_end_st = ST_OACC_END_PARALLEL;
5378       break;
5379     case ST_OACC_KERNELS:
5380       acc_end_st = ST_OACC_END_KERNELS;
5381       break;
5382     case ST_OACC_SERIAL:
5383       acc_end_st = ST_OACC_END_SERIAL;
5384       break;
5385     case ST_OACC_DATA:
5386       acc_end_st = ST_OACC_END_DATA;
5387       break;
5388     case ST_OACC_HOST_DATA:
5389       acc_end_st = ST_OACC_END_HOST_DATA;
5390       break;
5391     default:
5392       gcc_unreachable ();
5393     }
5394
5395   do
5396     {
5397       st = parse_executable (ST_NONE);
5398       if (st == ST_NONE)
5399         unexpected_eof ();
5400       else if (st != acc_end_st)
5401         {
5402           gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
5403           reject_statement ();
5404         }
5405     }
5406   while (st != acc_end_st);
5407
5408   gcc_assert (new_st.op == EXEC_NOP);
5409
5410   gfc_clear_new_st ();
5411   gfc_commit_symbols ();
5412   gfc_warning_check ();
5413   pop_state ();
5414 }
5415
5416 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'.  */
5417
5418 static gfc_statement
5419 parse_oacc_loop (gfc_statement acc_st)
5420 {
5421   gfc_statement st;
5422   gfc_code *cp, *np;
5423   gfc_state_data s, *sd;
5424
5425   for (sd = gfc_state_stack; sd; sd = sd->previous)
5426     if (sd->state == COMP_CRITICAL)
5427       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5428
5429   accept_statement (acc_st);
5430
5431   cp = gfc_state_stack->tail;
5432   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5433   np = new_level (cp);
5434   np->op = cp->op;
5435   np->block = NULL;
5436
5437   for (;;)
5438     {
5439       st = next_statement ();
5440       if (st == ST_NONE)
5441         unexpected_eof ();
5442       else if (st == ST_DO)
5443         break;
5444       else
5445         {
5446           gfc_error ("Expected DO loop at %C");
5447           reject_statement ();
5448         }
5449     }
5450
5451   parse_do_block ();
5452   if (gfc_statement_label != NULL
5453       && gfc_state_stack->previous != NULL
5454       && gfc_state_stack->previous->state == COMP_DO
5455       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5456     {
5457       pop_state ();
5458       return ST_IMPLIED_ENDDO;
5459     }
5460
5461   check_do_closure ();
5462   pop_state ();
5463
5464   st = next_statement ();
5465   if (st == ST_OACC_END_LOOP)
5466     gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5467   if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
5468       (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
5469       (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
5470       (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
5471     {
5472       gcc_assert (new_st.op == EXEC_NOP);
5473       gfc_clear_new_st ();
5474       gfc_commit_symbols ();
5475       gfc_warning_check ();
5476       st = next_statement ();
5477     }
5478   return st;
5479 }
5480
5481
5482 /* Parse the statements of an OpenMP structured block.  */
5483
5484 static gfc_statement
5485 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
5486 {
5487   gfc_statement st, omp_end_st;
5488   gfc_code *cp, *np;
5489   gfc_state_data s;
5490
5491   accept_statement (omp_st);
5492
5493   cp = gfc_state_stack->tail;
5494   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5495   np = new_level (cp);
5496   np->op = cp->op;
5497   np->block = NULL;
5498
5499   switch (omp_st)
5500     {
5501     case ST_OMP_PARALLEL:
5502       omp_end_st = ST_OMP_END_PARALLEL;
5503       break;
5504     case ST_OMP_PARALLEL_MASKED:
5505       omp_end_st = ST_OMP_END_PARALLEL_MASKED;
5506       break;
5507     case ST_OMP_PARALLEL_MASTER:
5508       omp_end_st = ST_OMP_END_PARALLEL_MASTER;
5509       break;
5510     case ST_OMP_PARALLEL_SECTIONS:
5511       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
5512       break;
5513     case ST_OMP_SCOPE:
5514       omp_end_st = ST_OMP_END_SCOPE;
5515       break;
5516     case ST_OMP_SECTIONS:
5517       omp_end_st = ST_OMP_END_SECTIONS;
5518       break;
5519     case ST_OMP_ORDERED:
5520       omp_end_st = ST_OMP_END_ORDERED;
5521       break;
5522     case ST_OMP_CRITICAL:
5523       omp_end_st = ST_OMP_END_CRITICAL;
5524       break;
5525     case ST_OMP_MASKED:
5526       omp_end_st = ST_OMP_END_MASKED;
5527       break;
5528     case ST_OMP_MASTER:
5529       omp_end_st = ST_OMP_END_MASTER;
5530       break;
5531     case ST_OMP_SINGLE:
5532       omp_end_st = ST_OMP_END_SINGLE;
5533       break;
5534     case ST_OMP_TARGET:
5535       omp_end_st = ST_OMP_END_TARGET;
5536       break;
5537     case ST_OMP_TARGET_DATA:
5538       omp_end_st = ST_OMP_END_TARGET_DATA;
5539       break;
5540     case ST_OMP_TARGET_PARALLEL:
5541       omp_end_st = ST_OMP_END_TARGET_PARALLEL;
5542       break;
5543     case ST_OMP_TARGET_TEAMS:
5544       omp_end_st = ST_OMP_END_TARGET_TEAMS;
5545       break;
5546     case ST_OMP_TASK:
5547       omp_end_st = ST_OMP_END_TASK;
5548       break;
5549     case ST_OMP_TASKGROUP:
5550       omp_end_st = ST_OMP_END_TASKGROUP;
5551       break;
5552     case ST_OMP_TEAMS:
5553       omp_end_st = ST_OMP_END_TEAMS;
5554       break;
5555     case ST_OMP_TEAMS_DISTRIBUTE:
5556       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
5557       break;
5558     case ST_OMP_DISTRIBUTE:
5559       omp_end_st = ST_OMP_END_DISTRIBUTE;
5560       break;
5561     case ST_OMP_WORKSHARE:
5562       omp_end_st = ST_OMP_END_WORKSHARE;
5563       break;
5564     case ST_OMP_PARALLEL_WORKSHARE:
5565       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
5566       break;
5567     default:
5568       gcc_unreachable ();
5569     }
5570
5571   bool block_construct = false;
5572   gfc_namespace *my_ns = NULL;
5573   gfc_namespace *my_parent = NULL;
5574
5575   st = next_statement ();
5576
5577   if (st == ST_BLOCK)
5578     {
5579       /* Adjust state to a strictly-structured block, now that we found that
5580          the body starts with a BLOCK construct.  */
5581       s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
5582
5583       block_construct = true;
5584       gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
5585
5586       my_ns = gfc_build_block_ns (gfc_current_ns);
5587       gfc_current_ns = my_ns;
5588       my_parent = my_ns->parent;
5589
5590       new_st.op = EXEC_BLOCK;
5591       new_st.ext.block.ns = my_ns;
5592       new_st.ext.block.assoc = NULL;
5593       accept_statement (ST_BLOCK);
5594       st = parse_spec (ST_NONE);
5595     }
5596
5597   do
5598     {
5599       if (workshare_stmts_only)
5600         {
5601           /* Inside of !$omp workshare, only
5602              scalar assignments
5603              array assignments
5604              where statements and constructs
5605              forall statements and constructs
5606              !$omp atomic
5607              !$omp critical
5608              !$omp parallel
5609              are allowed.  For !$omp critical these
5610              restrictions apply recursively.  */
5611           bool cycle = true;
5612
5613           for (;;)
5614             {
5615               switch (st)
5616                 {
5617                 case ST_NONE:
5618                   unexpected_eof ();
5619
5620                 case ST_ASSIGNMENT:
5621                 case ST_WHERE:
5622                 case ST_FORALL:
5623                   accept_statement (st);
5624                   break;
5625
5626                 case ST_WHERE_BLOCK:
5627                   parse_where_block ();
5628                   break;
5629
5630                 case ST_FORALL_BLOCK:
5631                   parse_forall_block ();
5632                   break;
5633
5634                 case ST_OMP_PARALLEL:
5635                 case ST_OMP_PARALLEL_MASKED:
5636                 case ST_OMP_PARALLEL_MASTER:
5637                 case ST_OMP_PARALLEL_SECTIONS:
5638                   st = parse_omp_structured_block (st, false);
5639                   continue;
5640
5641                 case ST_OMP_PARALLEL_WORKSHARE:
5642                 case ST_OMP_CRITICAL:
5643                   st = parse_omp_structured_block (st, true);
5644                   continue;
5645
5646                 case ST_OMP_PARALLEL_DO:
5647                 case ST_OMP_PARALLEL_DO_SIMD:
5648                   st = parse_omp_do (st);
5649                   continue;
5650
5651                 case ST_OMP_ATOMIC:
5652                   st = parse_omp_oacc_atomic (true);
5653                   continue;
5654
5655                 default:
5656                   cycle = false;
5657                   break;
5658                 }
5659
5660               if (!cycle)
5661                 break;
5662
5663               st = next_statement ();
5664             }
5665         }
5666       else
5667         st = parse_executable (st);
5668       if (st == ST_NONE)
5669         unexpected_eof ();
5670       else if (st == ST_OMP_SECTION
5671                && (omp_st == ST_OMP_SECTIONS
5672                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
5673         {
5674           np = new_level (np);
5675           np->op = cp->op;
5676           np->block = NULL;
5677           st = next_statement ();
5678         }
5679       else if (block_construct && st == ST_END_BLOCK)
5680         {
5681           accept_statement (st);
5682           gfc_current_ns = my_parent;
5683           pop_state ();
5684
5685           st = next_statement ();
5686           if (st == omp_end_st)
5687             {
5688               accept_statement (st);
5689               st = next_statement ();
5690             }
5691           return st;
5692         }
5693       else if (st != omp_end_st)
5694         {
5695           unexpected_statement (st);
5696           st = next_statement ();
5697         }
5698     }
5699   while (st != omp_end_st);
5700
5701   switch (new_st.op)
5702     {
5703     case EXEC_OMP_END_NOWAIT:
5704       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
5705       break;
5706     case EXEC_OMP_END_CRITICAL:
5707       if (((cp->ext.omp_clauses->critical_name == NULL)
5708             ^ (new_st.ext.omp_name == NULL))
5709           || (new_st.ext.omp_name != NULL
5710               && strcmp (cp->ext.omp_clauses->critical_name,
5711                          new_st.ext.omp_name) != 0))
5712         gfc_error ("Name after !$omp critical and !$omp end critical does "
5713                    "not match at %C");
5714       free (CONST_CAST (char *, new_st.ext.omp_name));
5715       new_st.ext.omp_name = NULL;
5716       break;
5717     case EXEC_OMP_END_SINGLE:
5718       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
5719         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
5720       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
5721       gfc_free_omp_clauses (new_st.ext.omp_clauses);
5722       break;
5723     case EXEC_NOP:
5724       break;
5725     default:
5726       gcc_unreachable ();
5727     }
5728
5729   gfc_clear_new_st ();
5730   gfc_commit_symbols ();
5731   gfc_warning_check ();
5732   pop_state ();
5733   st = next_statement ();
5734   return st;
5735 }
5736
5737
5738 /* Accept a series of executable statements.  We return the first
5739    statement that doesn't fit to the caller.  Any block statements are
5740    passed on to the correct handler, which usually passes the buck
5741    right back here.  */
5742
5743 static gfc_statement
5744 parse_executable (gfc_statement st)
5745 {
5746   int close_flag;
5747
5748   if (st == ST_NONE)
5749     st = next_statement ();
5750
5751   for (;;)
5752     {
5753       close_flag = check_do_closure ();
5754       if (close_flag)
5755         switch (st)
5756           {
5757           case ST_GOTO:
5758           case ST_END_PROGRAM:
5759           case ST_RETURN:
5760           case ST_EXIT:
5761           case ST_END_FUNCTION:
5762           case ST_CYCLE:
5763           case ST_PAUSE:
5764           case ST_STOP:
5765           case ST_ERROR_STOP:
5766           case ST_END_SUBROUTINE:
5767
5768           case ST_DO:
5769           case ST_FORALL:
5770           case ST_WHERE:
5771           case ST_SELECT_CASE:
5772             gfc_error ("%s statement at %C cannot terminate a non-block "
5773                        "DO loop", gfc_ascii_statement (st));
5774             break;
5775
5776           default:
5777             break;
5778           }
5779
5780       switch (st)
5781         {
5782         case ST_NONE:
5783           unexpected_eof ();
5784
5785         case ST_DATA:
5786           gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
5787                           "first executable statement");
5788           /* Fall through.  */
5789
5790         case ST_FORMAT:
5791         case ST_ENTRY:
5792         case_executable:
5793           accept_statement (st);
5794           if (close_flag == 1)
5795             return ST_IMPLIED_ENDDO;
5796           break;
5797
5798         case ST_BLOCK:
5799           parse_block_construct ();
5800           break;
5801
5802         case ST_ASSOCIATE:
5803           parse_associate ();
5804           break;
5805
5806         case ST_IF_BLOCK:
5807           parse_if_block ();
5808           break;
5809
5810         case ST_SELECT_CASE:
5811           parse_select_block ();
5812           break;
5813
5814         case ST_SELECT_TYPE:
5815           parse_select_type_block ();
5816           break;
5817
5818         case ST_SELECT_RANK:
5819           parse_select_rank_block ();
5820           break;
5821
5822         case ST_DO:
5823           parse_do_block ();
5824           if (check_do_closure () == 1)
5825             return ST_IMPLIED_ENDDO;
5826           break;
5827
5828         case ST_CRITICAL:
5829           parse_critical_block ();
5830           break;
5831
5832         case ST_WHERE_BLOCK:
5833           parse_where_block ();
5834           break;
5835
5836         case ST_FORALL_BLOCK:
5837           parse_forall_block ();
5838           break;
5839
5840         case ST_OACC_PARALLEL_LOOP:
5841         case ST_OACC_KERNELS_LOOP:
5842         case ST_OACC_SERIAL_LOOP:
5843         case ST_OACC_LOOP:
5844           st = parse_oacc_loop (st);
5845           if (st == ST_IMPLIED_ENDDO)
5846             return st;
5847           continue;
5848
5849         case ST_OACC_PARALLEL:
5850         case ST_OACC_KERNELS:
5851         case ST_OACC_SERIAL:
5852         case ST_OACC_DATA:
5853         case ST_OACC_HOST_DATA:
5854           parse_oacc_structured_block (st);
5855           break;
5856
5857         case ST_OMP_PARALLEL:
5858         case ST_OMP_PARALLEL_MASKED:
5859         case ST_OMP_PARALLEL_MASTER:
5860         case ST_OMP_PARALLEL_SECTIONS:
5861         case ST_OMP_ORDERED:
5862         case ST_OMP_CRITICAL:
5863         case ST_OMP_MASKED:
5864         case ST_OMP_MASTER:
5865         case ST_OMP_SCOPE:
5866         case ST_OMP_SECTIONS:
5867         case ST_OMP_SINGLE:
5868         case ST_OMP_TARGET:
5869         case ST_OMP_TARGET_DATA:
5870         case ST_OMP_TARGET_PARALLEL:
5871         case ST_OMP_TARGET_TEAMS:
5872         case ST_OMP_TEAMS:
5873         case ST_OMP_TASK:
5874         case ST_OMP_TASKGROUP:
5875           st = parse_omp_structured_block (st, false);
5876           continue;
5877
5878         case ST_OMP_WORKSHARE:
5879         case ST_OMP_PARALLEL_WORKSHARE:
5880           st = parse_omp_structured_block (st, true);
5881           continue;
5882
5883         case ST_OMP_DISTRIBUTE:
5884         case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5885         case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5886         case ST_OMP_DISTRIBUTE_SIMD:
5887         case ST_OMP_DO:
5888         case ST_OMP_DO_SIMD:
5889         case ST_OMP_LOOP:
5890         case ST_OMP_PARALLEL_DO:
5891         case ST_OMP_PARALLEL_DO_SIMD:
5892         case ST_OMP_PARALLEL_LOOP:
5893         case ST_OMP_PARALLEL_MASKED_TASKLOOP:
5894         case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5895         case ST_OMP_PARALLEL_MASTER_TASKLOOP:
5896         case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5897         case ST_OMP_MASKED_TASKLOOP:
5898         case ST_OMP_MASKED_TASKLOOP_SIMD:
5899         case ST_OMP_MASTER_TASKLOOP:
5900         case ST_OMP_MASTER_TASKLOOP_SIMD:
5901         case ST_OMP_SIMD:
5902         case ST_OMP_TARGET_PARALLEL_DO:
5903         case ST_OMP_TARGET_PARALLEL_DO_SIMD:
5904         case ST_OMP_TARGET_PARALLEL_LOOP:
5905         case ST_OMP_TARGET_SIMD:
5906         case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5907         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5908         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5909         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5910         case ST_OMP_TARGET_TEAMS_LOOP:
5911         case ST_OMP_TASKLOOP:
5912         case ST_OMP_TASKLOOP_SIMD:
5913         case ST_OMP_TEAMS_DISTRIBUTE:
5914         case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5915         case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5916         case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5917         case ST_OMP_TEAMS_LOOP:
5918           st = parse_omp_do (st);
5919           if (st == ST_IMPLIED_ENDDO)
5920             return st;
5921           continue;
5922
5923         case ST_OACC_ATOMIC:
5924           st = parse_omp_oacc_atomic (false);
5925           continue;
5926
5927         case ST_OMP_ATOMIC:
5928           st = parse_omp_oacc_atomic (true);
5929           continue;
5930
5931         default:
5932           return st;
5933         }
5934
5935       if (directive_unroll != -1)
5936         gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
5937
5938       if (directive_ivdep)
5939         gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
5940
5941       if (directive_vector)
5942         gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
5943
5944       if (directive_novector)
5945         gfc_error ("%<GCC novector%> "
5946                    "directive not at the start of a loop at %C");
5947
5948       st = next_statement ();
5949     }
5950 }
5951
5952
5953 /* Fix the symbols for sibling functions.  These are incorrectly added to
5954    the child namespace as the parser didn't know about this procedure.  */
5955
5956 static void
5957 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
5958 {
5959   gfc_namespace *ns;
5960   gfc_symtree *st;
5961   gfc_symbol *old_sym;
5962
5963   for (ns = siblings; ns; ns = ns->sibling)
5964     {
5965       st = gfc_find_symtree (ns->sym_root, sym->name);
5966
5967       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
5968         goto fixup_contained;
5969
5970       if ((st->n.sym->attr.flavor == FL_DERIVED
5971            && sym->attr.generic && sym->attr.function)
5972           ||(sym->attr.flavor == FL_DERIVED
5973              && st->n.sym->attr.generic && st->n.sym->attr.function))
5974         goto fixup_contained;
5975
5976       old_sym = st->n.sym;
5977       if (old_sym->ns == ns
5978             && !old_sym->attr.contained
5979
5980             /* By 14.6.1.3, host association should be excluded
5981                for the following.  */
5982             && !(old_sym->attr.external
5983                   || (old_sym->ts.type != BT_UNKNOWN
5984                         && !old_sym->attr.implicit_type)
5985                   || old_sym->attr.flavor == FL_PARAMETER
5986                   || old_sym->attr.use_assoc
5987                   || old_sym->attr.in_common
5988                   || old_sym->attr.in_equivalence
5989                   || old_sym->attr.data
5990                   || old_sym->attr.dummy
5991                   || old_sym->attr.result
5992                   || old_sym->attr.dimension
5993                   || old_sym->attr.allocatable
5994                   || old_sym->attr.intrinsic
5995                   || old_sym->attr.generic
5996                   || old_sym->attr.flavor == FL_NAMELIST
5997                   || old_sym->attr.flavor == FL_LABEL
5998                   || old_sym->attr.proc == PROC_ST_FUNCTION))
5999         {
6000           /* Replace it with the symbol from the parent namespace.  */
6001           st->n.sym = sym;
6002           sym->refs++;
6003
6004           gfc_release_symbol (old_sym);
6005         }
6006
6007 fixup_contained:
6008       /* Do the same for any contained procedures.  */
6009       gfc_fixup_sibling_symbols (sym, ns->contained);
6010     }
6011 }
6012
6013 static void
6014 parse_contained (int module)
6015 {
6016   gfc_namespace *ns, *parent_ns, *tmp;
6017   gfc_state_data s1, s2;
6018   gfc_statement st;
6019   gfc_symbol *sym;
6020   gfc_entry_list *el;
6021   locus old_loc;
6022   int contains_statements = 0;
6023   int seen_error = 0;
6024
6025   push_state (&s1, COMP_CONTAINS, NULL);
6026   parent_ns = gfc_current_ns;
6027
6028   do
6029     {
6030       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
6031
6032       gfc_current_ns->sibling = parent_ns->contained;
6033       parent_ns->contained = gfc_current_ns;
6034
6035  next:
6036       /* Process the next available statement.  We come here if we got an error
6037          and rejected the last statement.  */
6038       old_loc = gfc_current_locus;
6039       st = next_statement ();
6040
6041       switch (st)
6042         {
6043         case ST_NONE:
6044           unexpected_eof ();
6045
6046         case ST_FUNCTION:
6047         case ST_SUBROUTINE:
6048           contains_statements = 1;
6049           accept_statement (st);
6050
6051           push_state (&s2,
6052                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
6053                       gfc_new_block);
6054
6055           /* For internal procedures, create/update the symbol in the
6056              parent namespace.  */
6057
6058           if (!module)
6059             {
6060               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
6061                 gfc_error ("Contained procedure %qs at %C is already "
6062                            "ambiguous", gfc_new_block->name);
6063               else
6064                 {
6065                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
6066                                          sym->name,
6067                                          &gfc_new_block->declared_at))
6068                     {
6069                       if (st == ST_FUNCTION)
6070                         gfc_add_function (&sym->attr, sym->name,
6071                                           &gfc_new_block->declared_at);
6072                       else
6073                         gfc_add_subroutine (&sym->attr, sym->name,
6074                                             &gfc_new_block->declared_at);
6075                     }
6076                 }
6077
6078               gfc_commit_symbols ();
6079             }
6080           else
6081             sym = gfc_new_block;
6082
6083           /* Mark this as a contained function, so it isn't replaced
6084              by other module functions.  */
6085           sym->attr.contained = 1;
6086
6087           /* Set implicit_pure so that it can be reset if any of the
6088              tests for purity fail.  This is used for some optimisation
6089              during translation.  */
6090           if (!sym->attr.pure)
6091             sym->attr.implicit_pure = 1;
6092
6093           parse_progunit (ST_NONE);
6094
6095           /* Fix up any sibling functions that refer to this one.  */
6096           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
6097           /* Or refer to any of its alternate entry points.  */
6098           for (el = gfc_current_ns->entries; el; el = el->next)
6099             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
6100
6101           gfc_current_ns->code = s2.head;
6102           gfc_current_ns = parent_ns;
6103
6104           pop_state ();
6105           break;
6106
6107         /* These statements are associated with the end of the host unit.  */
6108         case ST_END_FUNCTION:
6109         case ST_END_MODULE:
6110         case ST_END_SUBMODULE:
6111         case ST_END_PROGRAM:
6112         case ST_END_SUBROUTINE:
6113           accept_statement (st);
6114           gfc_current_ns->code = s1.head;
6115           break;
6116
6117         default:
6118           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
6119                      gfc_ascii_statement (st));
6120           reject_statement ();
6121           seen_error = 1;
6122           goto next;
6123           break;
6124         }
6125     }
6126   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
6127          && st != ST_END_MODULE && st != ST_END_SUBMODULE
6128          && st != ST_END_PROGRAM);
6129
6130   /* The first namespace in the list is guaranteed to not have
6131      anything (worthwhile) in it.  */
6132   tmp = gfc_current_ns;
6133   gfc_current_ns = parent_ns;
6134   if (seen_error && tmp->refs > 1)
6135     gfc_free_namespace (tmp);
6136
6137   ns = gfc_current_ns->contained;
6138   gfc_current_ns->contained = ns->sibling;
6139   gfc_free_namespace (ns);
6140
6141   pop_state ();
6142   if (!contains_statements)
6143     gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
6144                     "FUNCTION or SUBROUTINE statement at %L", &old_loc);
6145 }
6146
6147
6148 /* The result variable in a MODULE PROCEDURE needs to be created and
6149     its characteristics copied from the interface since it is neither
6150     declared in the procedure declaration nor in the specification
6151     part.  */
6152
6153 static void
6154 get_modproc_result (void)
6155 {
6156   gfc_symbol *proc;
6157   if (gfc_state_stack->previous
6158       && gfc_state_stack->previous->state == COMP_CONTAINS
6159       && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
6160     {
6161       proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
6162       if (proc != NULL
6163           && proc->attr.function
6164           && proc->tlink
6165           && proc->tlink->result
6166           && proc->tlink->result != proc->tlink)
6167         {
6168           gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
6169           gfc_set_sym_referenced (proc->result);
6170           proc->result->attr.if_source = IFSRC_DECL;
6171           gfc_commit_symbol (proc->result);
6172         }
6173     }
6174 }
6175
6176
6177 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
6178
6179 static void
6180 parse_progunit (gfc_statement st)
6181 {
6182   gfc_state_data *p;
6183   int n;
6184
6185   gfc_adjust_builtins ();
6186
6187   if (gfc_new_block
6188       && gfc_new_block->abr_modproc_decl
6189       && gfc_new_block->attr.function)
6190     get_modproc_result ();
6191
6192   st = parse_spec (st);
6193   switch (st)
6194     {
6195     case ST_NONE:
6196       unexpected_eof ();
6197
6198     case ST_CONTAINS:
6199       /* This is not allowed within BLOCK!  */
6200       if (gfc_current_state () != COMP_BLOCK)
6201         goto contains;
6202       break;
6203
6204     case_end:
6205       accept_statement (st);
6206       goto done;
6207
6208     default:
6209       break;
6210     }
6211
6212   if (gfc_current_state () == COMP_FUNCTION)
6213     gfc_check_function_type (gfc_current_ns);
6214
6215 loop:
6216   for (;;)
6217     {
6218       st = parse_executable (st);
6219
6220       switch (st)
6221         {
6222         case ST_NONE:
6223           unexpected_eof ();
6224
6225         case ST_CONTAINS:
6226           /* This is not allowed within BLOCK!  */
6227           if (gfc_current_state () != COMP_BLOCK)
6228             goto contains;
6229           break;
6230
6231         case_end:
6232           accept_statement (st);
6233           goto done;
6234
6235         default:
6236           break;
6237         }
6238
6239       unexpected_statement (st);
6240       reject_statement ();
6241       st = next_statement ();
6242     }
6243
6244 contains:
6245   n = 0;
6246
6247   for (p = gfc_state_stack; p; p = p->previous)
6248     if (p->state == COMP_CONTAINS)
6249       n++;
6250
6251   if (gfc_find_state (COMP_MODULE) == true
6252       || gfc_find_state (COMP_SUBMODULE) == true)
6253     n--;
6254
6255   if (n > 0)
6256     {
6257       gfc_error ("CONTAINS statement at %C is already in a contained "
6258                  "program unit");
6259       reject_statement ();
6260       st = next_statement ();
6261       goto loop;
6262     }
6263
6264   parse_contained (0);
6265
6266 done:
6267   gfc_current_ns->code = gfc_state_stack->head;
6268 }
6269
6270
6271 /* Come here to complain about a global symbol already in use as
6272    something else.  */
6273
6274 void
6275 gfc_global_used (gfc_gsymbol *sym, locus *where)
6276 {
6277   const char *name;
6278
6279   if (where == NULL)
6280     where = &gfc_current_locus;
6281
6282   switch(sym->type)
6283     {
6284     case GSYM_PROGRAM:
6285       name = "PROGRAM";
6286       break;
6287     case GSYM_FUNCTION:
6288       name = "FUNCTION";
6289       break;
6290     case GSYM_SUBROUTINE:
6291       name = "SUBROUTINE";
6292       break;
6293     case GSYM_COMMON:
6294       name = "COMMON";
6295       break;
6296     case GSYM_BLOCK_DATA:
6297       name = "BLOCK DATA";
6298       break;
6299     case GSYM_MODULE:
6300       name = "MODULE";
6301       break;
6302     default:
6303       name = NULL;
6304     }
6305
6306   if (name)
6307     {
6308       if (sym->binding_label)
6309         gfc_error ("Global binding name %qs at %L is already being used "
6310                    "as a %s at %L", sym->binding_label, where, name,
6311                    &sym->where);
6312       else
6313         gfc_error ("Global name %qs at %L is already being used as "
6314                    "a %s at %L", sym->name, where, name, &sym->where);
6315     }
6316   else
6317     {
6318       if (sym->binding_label)
6319         gfc_error ("Global binding name %qs at %L is already being used "
6320                    "at %L", sym->binding_label, where, &sym->where);
6321       else
6322         gfc_error ("Global name %qs at %L is already being used at %L",
6323                    sym->name, where, &sym->where);
6324     }
6325 }
6326
6327
6328 /* Parse a block data program unit.  */
6329
6330 static void
6331 parse_block_data (void)
6332 {
6333   gfc_statement st;
6334   static locus blank_locus;
6335   static int blank_block=0;
6336   gfc_gsymbol *s;
6337
6338   gfc_current_ns->proc_name = gfc_new_block;
6339   gfc_current_ns->is_block_data = 1;
6340
6341   if (gfc_new_block == NULL)
6342     {
6343       if (blank_block)
6344        gfc_error ("Blank BLOCK DATA at %C conflicts with "
6345                   "prior BLOCK DATA at %L", &blank_locus);
6346       else
6347        {
6348          blank_block = 1;
6349          blank_locus = gfc_current_locus;
6350        }
6351     }
6352   else
6353     {
6354       s = gfc_get_gsymbol (gfc_new_block->name, false);
6355       if (s->defined
6356           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
6357        gfc_global_used (s, &gfc_new_block->declared_at);
6358       else
6359        {
6360          s->type = GSYM_BLOCK_DATA;
6361          s->where = gfc_new_block->declared_at;
6362          s->defined = 1;
6363        }
6364     }
6365
6366   st = parse_spec (ST_NONE);
6367
6368   while (st != ST_END_BLOCK_DATA)
6369     {
6370       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6371                  gfc_ascii_statement (st));
6372       reject_statement ();
6373       st = next_statement ();
6374     }
6375 }
6376
6377
6378 /* Following the association of the ancestor (sub)module symbols, they
6379    must be set host rather than use associated and all must be public.
6380    They are flagged up by 'used_in_submodule' so that they can be set
6381    DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl).  Otherwise the
6382    linker chokes on multiple symbol definitions.  */
6383
6384 static void
6385 set_syms_host_assoc (gfc_symbol *sym)
6386 {
6387   gfc_component *c;
6388   const char dot[2] = ".";
6389   /* Symbols take the form module.submodule_ or module.name_. */
6390   char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
6391   char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
6392
6393   if (sym == NULL)
6394     return;
6395
6396   if (sym->attr.module_procedure)
6397     sym->attr.external = 0;
6398
6399   sym->attr.use_assoc = 0;
6400   sym->attr.host_assoc = 1;
6401   sym->attr.used_in_submodule =1;
6402
6403   if (sym->attr.flavor == FL_DERIVED)
6404     {
6405       /* Derived types with PRIVATE components that are declared in
6406          modules other than the parent module must not be changed to be
6407          PUBLIC. The 'use-assoc' attribute must be reset so that the
6408          test in symbol.c(gfc_find_component) works correctly. This is
6409          not necessary for PRIVATE symbols since they are not read from
6410          the module.  */
6411       memset(parent1, '\0', sizeof(parent1));
6412       memset(parent2, '\0', sizeof(parent2));
6413       strcpy (parent1, gfc_new_block->name);
6414       strcpy (parent2, sym->module);
6415       if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
6416         {
6417           for (c = sym->components; c; c = c->next)
6418             c->attr.access = ACCESS_PUBLIC;
6419         }
6420       else
6421         {
6422           sym->attr.use_assoc = 1;
6423           sym->attr.host_assoc = 0;
6424         }
6425     }
6426 }
6427
6428 /* Parse a module subprogram.  */
6429
6430 static void
6431 parse_module (void)
6432 {
6433   gfc_statement st;
6434   gfc_gsymbol *s;
6435   bool error;
6436
6437   s = gfc_get_gsymbol (gfc_new_block->name, false);
6438   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
6439     gfc_global_used (s, &gfc_new_block->declared_at);
6440   else
6441     {
6442       s->type = GSYM_MODULE;
6443       s->where = gfc_new_block->declared_at;
6444       s->defined = 1;
6445     }
6446
6447   /* Something is nulling the module_list after this point. This is good
6448      since it allows us to 'USE' the parent modules that the submodule
6449      inherits and to set (most) of the symbols as host associated.  */
6450   if (gfc_current_state () == COMP_SUBMODULE)
6451     {
6452       use_modules ();
6453       gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
6454     }
6455
6456   st = parse_spec (ST_NONE);
6457
6458   error = false;
6459 loop:
6460   switch (st)
6461     {
6462     case ST_NONE:
6463       unexpected_eof ();
6464
6465     case ST_CONTAINS:
6466       parse_contained (1);
6467       break;
6468
6469     case ST_END_MODULE:
6470     case ST_END_SUBMODULE:
6471       accept_statement (st);
6472       break;
6473
6474     default:
6475       gfc_error ("Unexpected %s statement in MODULE at %C",
6476                  gfc_ascii_statement (st));
6477
6478       error = true;
6479       reject_statement ();
6480       st = next_statement ();
6481       goto loop;
6482     }
6483
6484   /* Make sure not to free the namespace twice on error.  */
6485   if (!error)
6486     s->ns = gfc_current_ns;
6487 }
6488
6489
6490 /* Add a procedure name to the global symbol table.  */
6491
6492 static void
6493 add_global_procedure (bool sub)
6494 {
6495   gfc_gsymbol *s;
6496
6497   /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6498      name is a global identifier.  */
6499   if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
6500     {
6501       s = gfc_get_gsymbol (gfc_new_block->name, false);
6502
6503       if (s->defined
6504           || (s->type != GSYM_UNKNOWN
6505               && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6506         {
6507           gfc_global_used (s, &gfc_new_block->declared_at);
6508           /* Silence follow-up errors.  */
6509           gfc_new_block->binding_label = NULL;
6510         }
6511       else
6512         {
6513           s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6514           s->sym_name = gfc_new_block->name;
6515           s->where = gfc_new_block->declared_at;
6516           s->defined = 1;
6517           s->ns = gfc_current_ns;
6518         }
6519     }
6520
6521   /* Don't add the symbol multiple times.  */
6522   if (gfc_new_block->binding_label
6523       && (!gfc_notification_std (GFC_STD_F2008)
6524           || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
6525     {
6526       s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
6527
6528       if (s->defined
6529           || (s->type != GSYM_UNKNOWN
6530               && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6531         {
6532           gfc_global_used (s, &gfc_new_block->declared_at);
6533           /* Silence follow-up errors.  */
6534           gfc_new_block->binding_label = NULL;
6535         }
6536       else
6537         {
6538           s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6539           s->sym_name = gfc_new_block->name;
6540           s->binding_label = gfc_new_block->binding_label;
6541           s->where = gfc_new_block->declared_at;
6542           s->defined = 1;
6543           s->ns = gfc_current_ns;
6544         }
6545     }
6546 }
6547
6548
6549 /* Add a program to the global symbol table.  */
6550
6551 static void
6552 add_global_program (void)
6553 {
6554   gfc_gsymbol *s;
6555
6556   if (gfc_new_block == NULL)
6557     return;
6558   s = gfc_get_gsymbol (gfc_new_block->name, false);
6559
6560   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
6561     gfc_global_used (s, &gfc_new_block->declared_at);
6562   else
6563     {
6564       s->type = GSYM_PROGRAM;
6565       s->where = gfc_new_block->declared_at;
6566       s->defined = 1;
6567       s->ns = gfc_current_ns;
6568     }
6569 }
6570
6571
6572 /* Resolve all the program units.  */
6573 static void
6574 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
6575 {
6576   gfc_derived_types = NULL;
6577   gfc_current_ns = gfc_global_ns_list;
6578   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6579     {
6580       if (gfc_current_ns->proc_name
6581           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6582         continue; /* Already resolved.  */
6583
6584       if (gfc_current_ns->proc_name)
6585         gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6586       gfc_resolve (gfc_current_ns);
6587       gfc_current_ns->derived_types = gfc_derived_types;
6588       gfc_derived_types = NULL;
6589     }
6590 }
6591
6592
6593 static void
6594 clean_up_modules (gfc_gsymbol *&gsym)
6595 {
6596   if (gsym == NULL)
6597     return;
6598
6599   clean_up_modules (gsym->left);
6600   clean_up_modules (gsym->right);
6601
6602   if (gsym->type != GSYM_MODULE)
6603     return;
6604
6605   if (gsym->ns)
6606     {
6607       gfc_current_ns = gsym->ns;
6608       gfc_derived_types = gfc_current_ns->derived_types;
6609       gfc_done_2 ();
6610       gsym->ns = NULL;
6611     }
6612   free (gsym);
6613   gsym = NULL;
6614 }
6615
6616
6617 /* Translate all the program units. This could be in a different order
6618    to resolution if there are forward references in the file.  */
6619 static void
6620 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
6621 {
6622   int errors;
6623
6624   gfc_current_ns = gfc_global_ns_list;
6625   gfc_get_errors (NULL, &errors);
6626
6627   /* We first translate all modules to make sure that later parts
6628      of the program can use the decl. Then we translate the nonmodules.  */
6629
6630   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6631     {
6632       if (!gfc_current_ns->proc_name
6633           || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6634         continue;
6635
6636       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6637       gfc_derived_types = gfc_current_ns->derived_types;
6638       gfc_generate_module_code (gfc_current_ns);
6639       gfc_current_ns->translated = 1;
6640     }
6641
6642   gfc_current_ns = gfc_global_ns_list;
6643   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6644     {
6645       if (gfc_current_ns->proc_name
6646           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6647         continue;
6648
6649       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6650       gfc_derived_types = gfc_current_ns->derived_types;
6651       gfc_generate_code (gfc_current_ns);
6652       gfc_current_ns->translated = 1;
6653     }
6654
6655   /* Clean up all the namespaces after translation.  */
6656   gfc_current_ns = gfc_global_ns_list;
6657   for (;gfc_current_ns;)
6658     {
6659       gfc_namespace *ns;
6660
6661       if (gfc_current_ns->proc_name
6662           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6663         {
6664           gfc_current_ns = gfc_current_ns->sibling;
6665           continue;
6666         }
6667
6668       ns = gfc_current_ns->sibling;
6669       gfc_derived_types = gfc_current_ns->derived_types;
6670       gfc_done_2 ();
6671       gfc_current_ns = ns;
6672     }
6673
6674   clean_up_modules (gfc_gsym_root);
6675 }
6676
6677
6678 /* Top level parser.  */
6679
6680 bool
6681 gfc_parse_file (void)
6682 {
6683   int seen_program, errors_before, errors;
6684   gfc_state_data top, s;
6685   gfc_statement st;
6686   locus prog_locus;
6687   gfc_namespace *next;
6688
6689   gfc_start_source_files ();
6690
6691   top.state = COMP_NONE;
6692   top.sym = NULL;
6693   top.previous = NULL;
6694   top.head = top.tail = NULL;
6695   top.do_variable = NULL;
6696
6697   gfc_state_stack = &top;
6698
6699   gfc_clear_new_st ();
6700
6701   gfc_statement_label = NULL;
6702
6703   if (setjmp (eof_buf))
6704     return false;       /* Come here on unexpected EOF */
6705
6706   /* Prepare the global namespace that will contain the
6707      program units.  */
6708   gfc_global_ns_list = next = NULL;
6709
6710   seen_program = 0;
6711   errors_before = 0;
6712
6713   /* Exit early for empty files.  */
6714   if (gfc_at_eof ())
6715     goto done;
6716
6717   in_specification_block = true;
6718 loop:
6719   gfc_init_2 ();
6720   st = next_statement ();
6721   switch (st)
6722     {
6723     case ST_NONE:
6724       gfc_done_2 ();
6725       goto done;
6726
6727     case ST_PROGRAM:
6728       if (seen_program)
6729         goto duplicate_main;
6730       seen_program = 1;
6731       prog_locus = gfc_current_locus;
6732
6733       push_state (&s, COMP_PROGRAM, gfc_new_block);
6734       main_program_symbol (gfc_current_ns, gfc_new_block->name);
6735       accept_statement (st);
6736       add_global_program ();
6737       parse_progunit (ST_NONE);
6738       goto prog_units;
6739
6740     case ST_SUBROUTINE:
6741       add_global_procedure (true);
6742       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
6743       accept_statement (st);
6744       parse_progunit (ST_NONE);
6745       goto prog_units;
6746
6747     case ST_FUNCTION:
6748       add_global_procedure (false);
6749       push_state (&s, COMP_FUNCTION, gfc_new_block);
6750       accept_statement (st);
6751       parse_progunit (ST_NONE);
6752       goto prog_units;
6753
6754     case ST_BLOCK_DATA:
6755       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
6756       accept_statement (st);
6757       parse_block_data ();
6758       break;
6759
6760     case ST_MODULE:
6761       push_state (&s, COMP_MODULE, gfc_new_block);
6762       accept_statement (st);
6763
6764       gfc_get_errors (NULL, &errors_before);
6765       parse_module ();
6766       break;
6767
6768     case ST_SUBMODULE:
6769       push_state (&s, COMP_SUBMODULE, gfc_new_block);
6770       accept_statement (st);
6771
6772       gfc_get_errors (NULL, &errors_before);
6773       parse_module ();
6774       break;
6775
6776     /* Anything else starts a nameless main program block.  */
6777     default:
6778       if (seen_program)
6779         goto duplicate_main;
6780       seen_program = 1;
6781       prog_locus = gfc_current_locus;
6782
6783       push_state (&s, COMP_PROGRAM, gfc_new_block);
6784       main_program_symbol (gfc_current_ns, "MAIN__");
6785       parse_progunit (st);
6786       goto prog_units;
6787     }
6788
6789   /* Handle the non-program units.  */
6790   gfc_current_ns->code = s.head;
6791
6792   gfc_resolve (gfc_current_ns);
6793
6794   /* Fix the implicit_pure attribute for those procedures who should
6795      not have it.  */
6796   while (gfc_fix_implicit_pure (gfc_current_ns))
6797     ;
6798
6799   /* Dump the parse tree if requested.  */
6800   if (flag_dump_fortran_original)
6801     gfc_dump_parse_tree (gfc_current_ns, stdout);
6802
6803   gfc_get_errors (NULL, &errors);
6804   if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
6805     {
6806       gfc_dump_module (s.sym->name, errors_before == errors);
6807       gfc_current_ns->derived_types = gfc_derived_types;
6808       gfc_derived_types = NULL;
6809       goto prog_units;
6810     }
6811   else
6812     {
6813       if (errors == 0)
6814         gfc_generate_code (gfc_current_ns);
6815       pop_state ();
6816       gfc_done_2 ();
6817     }
6818
6819   goto loop;
6820
6821 prog_units:
6822   /* The main program and non-contained procedures are put
6823      in the global namespace list, so that they can be processed
6824      later and all their interfaces resolved.  */
6825   gfc_current_ns->code = s.head;
6826   if (next)
6827     {
6828       for (; next->sibling; next = next->sibling)
6829         ;
6830       next->sibling = gfc_current_ns;
6831     }
6832   else
6833     gfc_global_ns_list = gfc_current_ns;
6834
6835   next = gfc_current_ns;
6836
6837   pop_state ();
6838   goto loop;
6839
6840 done:
6841   /* Do the resolution.  */
6842   resolve_all_program_units (gfc_global_ns_list);
6843
6844   /* Go through all top-level namespaces and unset the implicit_pure
6845      attribute for any procedures that call something not pure or
6846      implicit_pure.  Because the a procedure marked as not implicit_pure
6847      in one sweep may be called by another routine, we repeat this
6848      process until there are no more changes.  */
6849   bool changed;
6850   do
6851     {
6852       changed = false;
6853       for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6854            gfc_current_ns = gfc_current_ns->sibling)
6855         {
6856           if (gfc_fix_implicit_pure (gfc_current_ns))
6857             changed = true;
6858         }
6859     }
6860   while (changed);
6861
6862   /* Fixup for external procedures and resolve 'omp requires'.  */
6863   int omp_requires;
6864   omp_requires = 0;
6865   for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6866        gfc_current_ns = gfc_current_ns->sibling)
6867     {
6868       omp_requires |= gfc_current_ns->omp_requires;
6869       gfc_check_externals (gfc_current_ns);
6870     }
6871   for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6872        gfc_current_ns = gfc_current_ns->sibling)
6873     gfc_check_omp_requires (gfc_current_ns, omp_requires);
6874
6875   /* Populate omp_requires_mask (needed for resolving OpenMP
6876      metadirectives and declare variant).  */
6877   switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6878     {
6879     case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
6880       omp_requires_mask
6881         = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
6882       break;
6883     case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
6884       omp_requires_mask
6885         = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
6886       break;
6887     case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
6888       omp_requires_mask
6889         = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
6890       break;
6891     }
6892
6893   /* Do the parse tree dump.  */
6894   gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
6895
6896   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6897     if (!gfc_current_ns->proc_name
6898         || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6899       {
6900         gfc_dump_parse_tree (gfc_current_ns, stdout);
6901         fputs ("------------------------------------------\n\n", stdout);
6902       }
6903
6904   /* Dump C prototypes.  */
6905   if (flag_c_prototypes || flag_c_prototypes_external)
6906     {
6907       fprintf (stdout,
6908                "#include <stddef.h>\n"
6909                "#ifdef __cplusplus\n"
6910                "#include <complex>\n"
6911                "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
6912                "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
6913                "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
6914                "extern \"C\" {\n"
6915                "#else\n"
6916                "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
6917                "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
6918                "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
6919                "#endif\n\n");
6920     }
6921
6922   /* First dump BIND(C) prototypes.  */
6923   if (flag_c_prototypes)
6924     {
6925       for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6926            gfc_current_ns = gfc_current_ns->sibling)
6927         gfc_dump_c_prototypes (gfc_current_ns, stdout);
6928     }
6929
6930   /* Dump external prototypes.  */
6931   if (flag_c_prototypes_external)
6932     gfc_dump_external_c_prototypes (stdout);
6933
6934   if (flag_c_prototypes || flag_c_prototypes_external)
6935     fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
6936
6937   /* Do the translation.  */
6938   translate_all_program_units (gfc_global_ns_list);
6939
6940   /* Dump the global symbol ist.  We only do this here because part
6941      of it is generated after mangling the identifiers in
6942      trans-decl.c.  */
6943
6944   if (flag_dump_fortran_global)
6945     gfc_dump_global_symbols (stdout);
6946
6947   gfc_end_source_files ();
6948   return true;
6949
6950 duplicate_main:
6951   /* If we see a duplicate main program, shut down.  If the second
6952      instance is an implied main program, i.e. data decls or executable
6953      statements, we're in for lots of errors.  */
6954   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
6955   reject_statement ();
6956   gfc_done_2 ();
6957   return true;
6958 }
6959
6960 /* Return true if this state data represents an OpenACC region.  */
6961 bool
6962 is_oacc (gfc_state_data *sd)
6963 {
6964   switch (sd->construct->op)
6965     {
6966     case EXEC_OACC_PARALLEL_LOOP:
6967     case EXEC_OACC_PARALLEL:
6968     case EXEC_OACC_KERNELS_LOOP:
6969     case EXEC_OACC_KERNELS:
6970     case EXEC_OACC_SERIAL_LOOP:
6971     case EXEC_OACC_SERIAL:
6972     case EXEC_OACC_DATA:
6973     case EXEC_OACC_HOST_DATA:
6974     case EXEC_OACC_LOOP:
6975     case EXEC_OACC_UPDATE:
6976     case EXEC_OACC_WAIT:
6977     case EXEC_OACC_CACHE:
6978     case EXEC_OACC_ENTER_DATA:
6979     case EXEC_OACC_EXIT_DATA:
6980     case EXEC_OACC_ATOMIC:
6981     case EXEC_OACC_ROUTINE:
6982       return true;
6983
6984     default:
6985       return false;
6986     }
6987 }