gcc/fortran/parse.c

   1 /* Main parser.
   2    Copyright (C) 2000-2021 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 (st == ST_ASSIGNMENT)
5317         {
5318           accept_statement (st);
5319           count--;
5320         }
5321       else
5322         unexpected_statement (st);
5323     }
5324
5325   pop_state ();
5326
5327   st = next_statement ();
5328   if (st == st_end_atomic)
5329     {
5330       gfc_clear_new_st ();
5331       gfc_commit_symbols ();
5332       gfc_warning_check ();
5333       st = next_statement ();
5334     }
5335   else if (np->ext.omp_clauses->capture)
5336     gfc_error ("Missing !$OMP END ATOMIC after !$OMP ATOMIC CAPTURE at %C");
5337   return st;
5338 }
5339
5340
5341 /* Parse the statements of an OpenACC structured block.  */
5342
5343 static void
5344 parse_oacc_structured_block (gfc_statement acc_st)
5345 {
5346   gfc_statement st, acc_end_st;
5347   gfc_code *cp, *np;
5348   gfc_state_data s, *sd;
5349
5350   for (sd = gfc_state_stack; sd; sd = sd->previous)
5351     if (sd->state == COMP_CRITICAL)
5352       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5353
5354   accept_statement (acc_st);
5355
5356   cp = gfc_state_stack->tail;
5357   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5358   np = new_level (cp);
5359   np->op = cp->op;
5360   np->block = NULL;
5361   switch (acc_st)
5362     {
5363     case ST_OACC_PARALLEL:
5364       acc_end_st = ST_OACC_END_PARALLEL;
5365       break;
5366     case ST_OACC_KERNELS:
5367       acc_end_st = ST_OACC_END_KERNELS;
5368       break;
5369     case ST_OACC_SERIAL:
5370       acc_end_st = ST_OACC_END_SERIAL;
5371       break;
5372     case ST_OACC_DATA:
5373       acc_end_st = ST_OACC_END_DATA;
5374       break;
5375     case ST_OACC_HOST_DATA:
5376       acc_end_st = ST_OACC_END_HOST_DATA;
5377       break;
5378     default:
5379       gcc_unreachable ();
5380     }
5381
5382   do
5383     {
5384       st = parse_executable (ST_NONE);
5385       if (st == ST_NONE)
5386         unexpected_eof ();
5387       else if (st != acc_end_st)
5388         {
5389           gfc_error ("Expecting %s at %C", gfc_ascii_statement (acc_end_st));
5390           reject_statement ();
5391         }
5392     }
5393   while (st != acc_end_st);
5394
5395   gcc_assert (new_st.op == EXEC_NOP);
5396
5397   gfc_clear_new_st ();
5398   gfc_commit_symbols ();
5399   gfc_warning_check ();
5400   pop_state ();
5401 }
5402
5403 /* Parse the statements of OpenACC 'loop', or combined compute 'loop'.  */
5404
5405 static gfc_statement
5406 parse_oacc_loop (gfc_statement acc_st)
5407 {
5408   gfc_statement st;
5409   gfc_code *cp, *np;
5410   gfc_state_data s, *sd;
5411
5412   for (sd = gfc_state_stack; sd; sd = sd->previous)
5413     if (sd->state == COMP_CRITICAL)
5414       gfc_error_now ("OpenACC directive inside of CRITICAL block at %C");
5415
5416   accept_statement (acc_st);
5417
5418   cp = gfc_state_stack->tail;
5419   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5420   np = new_level (cp);
5421   np->op = cp->op;
5422   np->block = NULL;
5423
5424   for (;;)
5425     {
5426       st = next_statement ();
5427       if (st == ST_NONE)
5428         unexpected_eof ();
5429       else if (st == ST_DO)
5430         break;
5431       else
5432         {
5433           gfc_error ("Expected DO loop at %C");
5434           reject_statement ();
5435         }
5436     }
5437
5438   parse_do_block ();
5439   if (gfc_statement_label != NULL
5440       && gfc_state_stack->previous != NULL
5441       && gfc_state_stack->previous->state == COMP_DO
5442       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
5443     {
5444       pop_state ();
5445       return ST_IMPLIED_ENDDO;
5446     }
5447
5448   check_do_closure ();
5449   pop_state ();
5450
5451   st = next_statement ();
5452   if (st == ST_OACC_END_LOOP)
5453     gfc_warning (0, "Redundant !$ACC END LOOP at %C");
5454   if ((acc_st == ST_OACC_PARALLEL_LOOP && st == ST_OACC_END_PARALLEL_LOOP) ||
5455       (acc_st == ST_OACC_KERNELS_LOOP && st == ST_OACC_END_KERNELS_LOOP) ||
5456       (acc_st == ST_OACC_SERIAL_LOOP && st == ST_OACC_END_SERIAL_LOOP) ||
5457       (acc_st == ST_OACC_LOOP && st == ST_OACC_END_LOOP))
5458     {
5459       gcc_assert (new_st.op == EXEC_NOP);
5460       gfc_clear_new_st ();
5461       gfc_commit_symbols ();
5462       gfc_warning_check ();
5463       st = next_statement ();
5464     }
5465   return st;
5466 }
5467
5468
5469 /* Parse the statements of an OpenMP structured block.  */
5470
5471 static gfc_statement
5472 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
5473 {
5474   gfc_statement st, omp_end_st;
5475   gfc_code *cp, *np;
5476   gfc_state_data s;
5477
5478   accept_statement (omp_st);
5479
5480   cp = gfc_state_stack->tail;
5481   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
5482   np = new_level (cp);
5483   np->op = cp->op;
5484   np->block = NULL;
5485
5486   switch (omp_st)
5487     {
5488     case ST_OMP_PARALLEL:
5489       omp_end_st = ST_OMP_END_PARALLEL;
5490       break;
5491     case ST_OMP_PARALLEL_MASKED:
5492       omp_end_st = ST_OMP_END_PARALLEL_MASKED;
5493       break;
5494     case ST_OMP_PARALLEL_MASTER:
5495       omp_end_st = ST_OMP_END_PARALLEL_MASTER;
5496       break;
5497     case ST_OMP_PARALLEL_SECTIONS:
5498       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
5499       break;
5500     case ST_OMP_SCOPE:
5501       omp_end_st = ST_OMP_END_SCOPE;
5502       break;
5503     case ST_OMP_SECTIONS:
5504       omp_end_st = ST_OMP_END_SECTIONS;
5505       break;
5506     case ST_OMP_ORDERED:
5507       omp_end_st = ST_OMP_END_ORDERED;
5508       break;
5509     case ST_OMP_CRITICAL:
5510       omp_end_st = ST_OMP_END_CRITICAL;
5511       break;
5512     case ST_OMP_MASKED:
5513       omp_end_st = ST_OMP_END_MASKED;
5514       break;
5515     case ST_OMP_MASTER:
5516       omp_end_st = ST_OMP_END_MASTER;
5517       break;
5518     case ST_OMP_SINGLE:
5519       omp_end_st = ST_OMP_END_SINGLE;
5520       break;
5521     case ST_OMP_TARGET:
5522       omp_end_st = ST_OMP_END_TARGET;
5523       break;
5524     case ST_OMP_TARGET_DATA:
5525       omp_end_st = ST_OMP_END_TARGET_DATA;
5526       break;
5527     case ST_OMP_TARGET_PARALLEL:
5528       omp_end_st = ST_OMP_END_TARGET_PARALLEL;
5529       break;
5530     case ST_OMP_TARGET_TEAMS:
5531       omp_end_st = ST_OMP_END_TARGET_TEAMS;
5532       break;
5533     case ST_OMP_TASK:
5534       omp_end_st = ST_OMP_END_TASK;
5535       break;
5536     case ST_OMP_TASKGROUP:
5537       omp_end_st = ST_OMP_END_TASKGROUP;
5538       break;
5539     case ST_OMP_TEAMS:
5540       omp_end_st = ST_OMP_END_TEAMS;
5541       break;
5542     case ST_OMP_TEAMS_DISTRIBUTE:
5543       omp_end_st = ST_OMP_END_TEAMS_DISTRIBUTE;
5544       break;
5545     case ST_OMP_DISTRIBUTE:
5546       omp_end_st = ST_OMP_END_DISTRIBUTE;
5547       break;
5548     case ST_OMP_WORKSHARE:
5549       omp_end_st = ST_OMP_END_WORKSHARE;
5550       break;
5551     case ST_OMP_PARALLEL_WORKSHARE:
5552       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
5553       break;
5554     default:
5555       gcc_unreachable ();
5556     }
5557
5558   bool block_construct = false;
5559   gfc_namespace *my_ns = NULL;
5560   gfc_namespace *my_parent = NULL;
5561
5562   st = next_statement ();
5563
5564   if (st == ST_BLOCK)
5565     {
5566       /* Adjust state to a strictly-structured block, now that we found that
5567          the body starts with a BLOCK construct.  */
5568       s.state = COMP_OMP_STRICTLY_STRUCTURED_BLOCK;
5569
5570       block_construct = true;
5571       gfc_notify_std (GFC_STD_F2008, "BLOCK construct at %C");
5572
5573       my_ns = gfc_build_block_ns (gfc_current_ns);
5574       gfc_current_ns = my_ns;
5575       my_parent = my_ns->parent;
5576
5577       new_st.op = EXEC_BLOCK;
5578       new_st.ext.block.ns = my_ns;
5579       new_st.ext.block.assoc = NULL;
5580       accept_statement (ST_BLOCK);
5581       st = parse_spec (ST_NONE);
5582     }
5583
5584   do
5585     {
5586       if (workshare_stmts_only)
5587         {
5588           /* Inside of !$omp workshare, only
5589              scalar assignments
5590              array assignments
5591              where statements and constructs
5592              forall statements and constructs
5593              !$omp atomic
5594              !$omp critical
5595              !$omp parallel
5596              are allowed.  For !$omp critical these
5597              restrictions apply recursively.  */
5598           bool cycle = true;
5599
5600           for (;;)
5601             {
5602               switch (st)
5603                 {
5604                 case ST_NONE:
5605                   unexpected_eof ();
5606
5607                 case ST_ASSIGNMENT:
5608                 case ST_WHERE:
5609                 case ST_FORALL:
5610                   accept_statement (st);
5611                   break;
5612
5613                 case ST_WHERE_BLOCK:
5614                   parse_where_block ();
5615                   break;
5616
5617                 case ST_FORALL_BLOCK:
5618                   parse_forall_block ();
5619                   break;
5620
5621                 case ST_OMP_PARALLEL:
5622                 case ST_OMP_PARALLEL_MASKED:
5623                 case ST_OMP_PARALLEL_MASTER:
5624                 case ST_OMP_PARALLEL_SECTIONS:
5625                   st = parse_omp_structured_block (st, false);
5626                   continue;
5627
5628                 case ST_OMP_PARALLEL_WORKSHARE:
5629                 case ST_OMP_CRITICAL:
5630                   st = parse_omp_structured_block (st, true);
5631                   continue;
5632
5633                 case ST_OMP_PARALLEL_DO:
5634                 case ST_OMP_PARALLEL_DO_SIMD:
5635                   st = parse_omp_do (st);
5636                   continue;
5637
5638                 case ST_OMP_ATOMIC:
5639                   st = parse_omp_oacc_atomic (true);
5640                   continue;
5641
5642                 default:
5643                   cycle = false;
5644                   break;
5645                 }
5646
5647               if (!cycle)
5648                 break;
5649
5650               st = next_statement ();
5651             }
5652         }
5653       else
5654         st = parse_executable (st);
5655       if (st == ST_NONE)
5656         unexpected_eof ();
5657       else if (st == ST_OMP_SECTION
5658                && (omp_st == ST_OMP_SECTIONS
5659                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
5660         {
5661           np = new_level (np);
5662           np->op = cp->op;
5663           np->block = NULL;
5664           st = next_statement ();
5665         }
5666       else if (block_construct && st == ST_END_BLOCK)
5667         {
5668           accept_statement (st);
5669           gfc_current_ns = my_parent;
5670           pop_state ();
5671
5672           st = next_statement ();
5673           if (st == omp_end_st)
5674             {
5675               accept_statement (st);
5676               st = next_statement ();
5677             }
5678           return st;
5679         }
5680       else if (st != omp_end_st)
5681         {
5682           unexpected_statement (st);
5683           st = next_statement ();
5684         }
5685     }
5686   while (st != omp_end_st);
5687
5688   switch (new_st.op)
5689     {
5690     case EXEC_OMP_END_NOWAIT:
5691       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
5692       break;
5693     case EXEC_OMP_END_CRITICAL:
5694       if (((cp->ext.omp_clauses->critical_name == NULL)
5695             ^ (new_st.ext.omp_name == NULL))
5696           || (new_st.ext.omp_name != NULL
5697               && strcmp (cp->ext.omp_clauses->critical_name,
5698                          new_st.ext.omp_name) != 0))
5699         gfc_error ("Name after !$omp critical and !$omp end critical does "
5700                    "not match at %C");
5701       free (CONST_CAST (char *, new_st.ext.omp_name));
5702       new_st.ext.omp_name = NULL;
5703       break;
5704     case EXEC_OMP_END_SINGLE:
5705       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
5706         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
5707       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
5708       gfc_free_omp_clauses (new_st.ext.omp_clauses);
5709       break;
5710     case EXEC_NOP:
5711       break;
5712     default:
5713       gcc_unreachable ();
5714     }
5715
5716   gfc_clear_new_st ();
5717   gfc_commit_symbols ();
5718   gfc_warning_check ();
5719   pop_state ();
5720   st = next_statement ();
5721   return st;
5722 }
5723
5724
5725 /* Accept a series of executable statements.  We return the first
5726    statement that doesn't fit to the caller.  Any block statements are
5727    passed on to the correct handler, which usually passes the buck
5728    right back here.  */
5729
5730 static gfc_statement
5731 parse_executable (gfc_statement st)
5732 {
5733   int close_flag;
5734
5735   if (st == ST_NONE)
5736     st = next_statement ();
5737
5738   for (;;)
5739     {
5740       close_flag = check_do_closure ();
5741       if (close_flag)
5742         switch (st)
5743           {
5744           case ST_GOTO:
5745           case ST_END_PROGRAM:
5746           case ST_RETURN:
5747           case ST_EXIT:
5748           case ST_END_FUNCTION:
5749           case ST_CYCLE:
5750           case ST_PAUSE:
5751           case ST_STOP:
5752           case ST_ERROR_STOP:
5753           case ST_END_SUBROUTINE:
5754
5755           case ST_DO:
5756           case ST_FORALL:
5757           case ST_WHERE:
5758           case ST_SELECT_CASE:
5759             gfc_error ("%s statement at %C cannot terminate a non-block "
5760                        "DO loop", gfc_ascii_statement (st));
5761             break;
5762
5763           default:
5764             break;
5765           }
5766
5767       switch (st)
5768         {
5769         case ST_NONE:
5770           unexpected_eof ();
5771
5772         case ST_DATA:
5773           gfc_notify_std (GFC_STD_F95_OBS, "DATA statement at %C after the "
5774                           "first executable statement");
5775           /* Fall through.  */
5776
5777         case ST_FORMAT:
5778         case ST_ENTRY:
5779         case_executable:
5780           accept_statement (st);
5781           if (close_flag == 1)
5782             return ST_IMPLIED_ENDDO;
5783           break;
5784
5785         case ST_BLOCK:
5786           parse_block_construct ();
5787           break;
5788
5789         case ST_ASSOCIATE:
5790           parse_associate ();
5791           break;
5792
5793         case ST_IF_BLOCK:
5794           parse_if_block ();
5795           break;
5796
5797         case ST_SELECT_CASE:
5798           parse_select_block ();
5799           break;
5800
5801         case ST_SELECT_TYPE:
5802           parse_select_type_block ();
5803           break;
5804
5805         case ST_SELECT_RANK:
5806           parse_select_rank_block ();
5807           break;
5808
5809         case ST_DO:
5810           parse_do_block ();
5811           if (check_do_closure () == 1)
5812             return ST_IMPLIED_ENDDO;
5813           break;
5814
5815         case ST_CRITICAL:
5816           parse_critical_block ();
5817           break;
5818
5819         case ST_WHERE_BLOCK:
5820           parse_where_block ();
5821           break;
5822
5823         case ST_FORALL_BLOCK:
5824           parse_forall_block ();
5825           break;
5826
5827         case ST_OACC_PARALLEL_LOOP:
5828         case ST_OACC_KERNELS_LOOP:
5829         case ST_OACC_SERIAL_LOOP:
5830         case ST_OACC_LOOP:
5831           st = parse_oacc_loop (st);
5832           if (st == ST_IMPLIED_ENDDO)
5833             return st;
5834           continue;
5835
5836         case ST_OACC_PARALLEL:
5837         case ST_OACC_KERNELS:
5838         case ST_OACC_SERIAL:
5839         case ST_OACC_DATA:
5840         case ST_OACC_HOST_DATA:
5841           parse_oacc_structured_block (st);
5842           break;
5843
5844         case ST_OMP_PARALLEL:
5845         case ST_OMP_PARALLEL_MASKED:
5846         case ST_OMP_PARALLEL_MASTER:
5847         case ST_OMP_PARALLEL_SECTIONS:
5848         case ST_OMP_ORDERED:
5849         case ST_OMP_CRITICAL:
5850         case ST_OMP_MASKED:
5851         case ST_OMP_MASTER:
5852         case ST_OMP_SCOPE:
5853         case ST_OMP_SECTIONS:
5854         case ST_OMP_SINGLE:
5855         case ST_OMP_TARGET:
5856         case ST_OMP_TARGET_DATA:
5857         case ST_OMP_TARGET_PARALLEL:
5858         case ST_OMP_TARGET_TEAMS:
5859         case ST_OMP_TEAMS:
5860         case ST_OMP_TASK:
5861         case ST_OMP_TASKGROUP:
5862           st = parse_omp_structured_block (st, false);
5863           continue;
5864
5865         case ST_OMP_WORKSHARE:
5866         case ST_OMP_PARALLEL_WORKSHARE:
5867           st = parse_omp_structured_block (st, true);
5868           continue;
5869
5870         case ST_OMP_DISTRIBUTE:
5871         case ST_OMP_DISTRIBUTE_PARALLEL_DO:
5872         case ST_OMP_DISTRIBUTE_PARALLEL_DO_SIMD:
5873         case ST_OMP_DISTRIBUTE_SIMD:
5874         case ST_OMP_DO:
5875         case ST_OMP_DO_SIMD:
5876         case ST_OMP_LOOP:
5877         case ST_OMP_PARALLEL_DO:
5878         case ST_OMP_PARALLEL_DO_SIMD:
5879         case ST_OMP_PARALLEL_LOOP:
5880         case ST_OMP_PARALLEL_MASKED_TASKLOOP:
5881         case ST_OMP_PARALLEL_MASKED_TASKLOOP_SIMD:
5882         case ST_OMP_PARALLEL_MASTER_TASKLOOP:
5883         case ST_OMP_PARALLEL_MASTER_TASKLOOP_SIMD:
5884         case ST_OMP_MASKED_TASKLOOP:
5885         case ST_OMP_MASKED_TASKLOOP_SIMD:
5886         case ST_OMP_MASTER_TASKLOOP:
5887         case ST_OMP_MASTER_TASKLOOP_SIMD:
5888         case ST_OMP_SIMD:
5889         case ST_OMP_TARGET_PARALLEL_DO:
5890         case ST_OMP_TARGET_PARALLEL_DO_SIMD:
5891         case ST_OMP_TARGET_PARALLEL_LOOP:
5892         case ST_OMP_TARGET_SIMD:
5893         case ST_OMP_TARGET_TEAMS_DISTRIBUTE:
5894         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO:
5895         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5896         case ST_OMP_TARGET_TEAMS_DISTRIBUTE_SIMD:
5897         case ST_OMP_TARGET_TEAMS_LOOP:
5898         case ST_OMP_TASKLOOP:
5899         case ST_OMP_TASKLOOP_SIMD:
5900         case ST_OMP_TEAMS_DISTRIBUTE:
5901         case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO:
5902         case ST_OMP_TEAMS_DISTRIBUTE_PARALLEL_DO_SIMD:
5903         case ST_OMP_TEAMS_DISTRIBUTE_SIMD:
5904         case ST_OMP_TEAMS_LOOP:
5905           st = parse_omp_do (st);
5906           if (st == ST_IMPLIED_ENDDO)
5907             return st;
5908           continue;
5909
5910         case ST_OACC_ATOMIC:
5911           st = parse_omp_oacc_atomic (false);
5912           continue;
5913
5914         case ST_OMP_ATOMIC:
5915           st = parse_omp_oacc_atomic (true);
5916           continue;
5917
5918         default:
5919           return st;
5920         }
5921
5922       if (directive_unroll != -1)
5923         gfc_error ("%<GCC unroll%> directive not at the start of a loop at %C");
5924
5925       if (directive_ivdep)
5926         gfc_error ("%<GCC ivdep%> directive not at the start of a loop at %C");
5927
5928       if (directive_vector)
5929         gfc_error ("%<GCC vector%> directive not at the start of a loop at %C");
5930
5931       if (directive_novector)
5932         gfc_error ("%<GCC novector%> "
5933                    "directive not at the start of a loop at %C");
5934
5935       st = next_statement ();
5936     }
5937 }
5938
5939
5940 /* Fix the symbols for sibling functions.  These are incorrectly added to
5941    the child namespace as the parser didn't know about this procedure.  */
5942
5943 static void
5944 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
5945 {
5946   gfc_namespace *ns;
5947   gfc_symtree *st;
5948   gfc_symbol *old_sym;
5949
5950   for (ns = siblings; ns; ns = ns->sibling)
5951     {
5952       st = gfc_find_symtree (ns->sym_root, sym->name);
5953
5954       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
5955         goto fixup_contained;
5956
5957       if ((st->n.sym->attr.flavor == FL_DERIVED
5958            && sym->attr.generic && sym->attr.function)
5959           ||(sym->attr.flavor == FL_DERIVED
5960              && st->n.sym->attr.generic && st->n.sym->attr.function))
5961         goto fixup_contained;
5962
5963       old_sym = st->n.sym;
5964       if (old_sym->ns == ns
5965             && !old_sym->attr.contained
5966
5967             /* By 14.6.1.3, host association should be excluded
5968                for the following.  */
5969             && !(old_sym->attr.external
5970                   || (old_sym->ts.type != BT_UNKNOWN
5971                         && !old_sym->attr.implicit_type)
5972                   || old_sym->attr.flavor == FL_PARAMETER
5973                   || old_sym->attr.use_assoc
5974                   || old_sym->attr.in_common
5975                   || old_sym->attr.in_equivalence
5976                   || old_sym->attr.data
5977                   || old_sym->attr.dummy
5978                   || old_sym->attr.result
5979                   || old_sym->attr.dimension
5980                   || old_sym->attr.allocatable
5981                   || old_sym->attr.intrinsic
5982                   || old_sym->attr.generic
5983                   || old_sym->attr.flavor == FL_NAMELIST
5984                   || old_sym->attr.flavor == FL_LABEL
5985                   || old_sym->attr.proc == PROC_ST_FUNCTION))
5986         {
5987           /* Replace it with the symbol from the parent namespace.  */
5988           st->n.sym = sym;
5989           sym->refs++;
5990
5991           gfc_release_symbol (old_sym);
5992         }
5993
5994 fixup_contained:
5995       /* Do the same for any contained procedures.  */
5996       gfc_fixup_sibling_symbols (sym, ns->contained);
5997     }
5998 }
5999
6000 static void
6001 parse_contained (int module)
6002 {
6003   gfc_namespace *ns, *parent_ns, *tmp;
6004   gfc_state_data s1, s2;
6005   gfc_statement st;
6006   gfc_symbol *sym;
6007   gfc_entry_list *el;
6008   locus old_loc;
6009   int contains_statements = 0;
6010   int seen_error = 0;
6011
6012   push_state (&s1, COMP_CONTAINS, NULL);
6013   parent_ns = gfc_current_ns;
6014
6015   do
6016     {
6017       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
6018
6019       gfc_current_ns->sibling = parent_ns->contained;
6020       parent_ns->contained = gfc_current_ns;
6021
6022  next:
6023       /* Process the next available statement.  We come here if we got an error
6024          and rejected the last statement.  */
6025       old_loc = gfc_current_locus;
6026       st = next_statement ();
6027
6028       switch (st)
6029         {
6030         case ST_NONE:
6031           unexpected_eof ();
6032
6033         case ST_FUNCTION:
6034         case ST_SUBROUTINE:
6035           contains_statements = 1;
6036           accept_statement (st);
6037
6038           push_state (&s2,
6039                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
6040                       gfc_new_block);
6041
6042           /* For internal procedures, create/update the symbol in the
6043              parent namespace.  */
6044
6045           if (!module)
6046             {
6047               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
6048                 gfc_error ("Contained procedure %qs at %C is already "
6049                            "ambiguous", gfc_new_block->name);
6050               else
6051                 {
6052                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL,
6053                                          sym->name,
6054                                          &gfc_new_block->declared_at))
6055                     {
6056                       if (st == ST_FUNCTION)
6057                         gfc_add_function (&sym->attr, sym->name,
6058                                           &gfc_new_block->declared_at);
6059                       else
6060                         gfc_add_subroutine (&sym->attr, sym->name,
6061                                             &gfc_new_block->declared_at);
6062                     }
6063                 }
6064
6065               gfc_commit_symbols ();
6066             }
6067           else
6068             sym = gfc_new_block;
6069
6070           /* Mark this as a contained function, so it isn't replaced
6071              by other module functions.  */
6072           sym->attr.contained = 1;
6073
6074           /* Set implicit_pure so that it can be reset if any of the
6075              tests for purity fail.  This is used for some optimisation
6076              during translation.  */
6077           if (!sym->attr.pure)
6078             sym->attr.implicit_pure = 1;
6079
6080           parse_progunit (ST_NONE);
6081
6082           /* Fix up any sibling functions that refer to this one.  */
6083           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
6084           /* Or refer to any of its alternate entry points.  */
6085           for (el = gfc_current_ns->entries; el; el = el->next)
6086             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
6087
6088           gfc_current_ns->code = s2.head;
6089           gfc_current_ns = parent_ns;
6090
6091           pop_state ();
6092           break;
6093
6094         /* These statements are associated with the end of the host unit.  */
6095         case ST_END_FUNCTION:
6096         case ST_END_MODULE:
6097         case ST_END_SUBMODULE:
6098         case ST_END_PROGRAM:
6099         case ST_END_SUBROUTINE:
6100           accept_statement (st);
6101           gfc_current_ns->code = s1.head;
6102           break;
6103
6104         default:
6105           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
6106                      gfc_ascii_statement (st));
6107           reject_statement ();
6108           seen_error = 1;
6109           goto next;
6110           break;
6111         }
6112     }
6113   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
6114          && st != ST_END_MODULE && st != ST_END_SUBMODULE
6115          && st != ST_END_PROGRAM);
6116
6117   /* The first namespace in the list is guaranteed to not have
6118      anything (worthwhile) in it.  */
6119   tmp = gfc_current_ns;
6120   gfc_current_ns = parent_ns;
6121   if (seen_error && tmp->refs > 1)
6122     gfc_free_namespace (tmp);
6123
6124   ns = gfc_current_ns->contained;
6125   gfc_current_ns->contained = ns->sibling;
6126   gfc_free_namespace (ns);
6127
6128   pop_state ();
6129   if (!contains_statements)
6130     gfc_notify_std (GFC_STD_F2008, "CONTAINS statement without "
6131                     "FUNCTION or SUBROUTINE statement at %L", &old_loc);
6132 }
6133
6134
6135 /* The result variable in a MODULE PROCEDURE needs to be created and
6136     its characteristics copied from the interface since it is neither
6137     declared in the procedure declaration nor in the specification
6138     part.  */
6139
6140 static void
6141 get_modproc_result (void)
6142 {
6143   gfc_symbol *proc;
6144   if (gfc_state_stack->previous
6145       && gfc_state_stack->previous->state == COMP_CONTAINS
6146       && gfc_state_stack->previous->previous->state == COMP_SUBMODULE)
6147     {
6148       proc = gfc_current_ns->proc_name ? gfc_current_ns->proc_name : NULL;
6149       if (proc != NULL
6150           && proc->attr.function
6151           && proc->tlink
6152           && proc->tlink->result
6153           && proc->tlink->result != proc->tlink)
6154         {
6155           gfc_copy_dummy_sym (&proc->result, proc->tlink->result, 1);
6156           gfc_set_sym_referenced (proc->result);
6157           proc->result->attr.if_source = IFSRC_DECL;
6158           gfc_commit_symbol (proc->result);
6159         }
6160     }
6161 }
6162
6163
6164 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
6165
6166 static void
6167 parse_progunit (gfc_statement st)
6168 {
6169   gfc_state_data *p;
6170   int n;
6171
6172   gfc_adjust_builtins ();
6173
6174   if (gfc_new_block
6175       && gfc_new_block->abr_modproc_decl
6176       && gfc_new_block->attr.function)
6177     get_modproc_result ();
6178
6179   st = parse_spec (st);
6180   switch (st)
6181     {
6182     case ST_NONE:
6183       unexpected_eof ();
6184
6185     case ST_CONTAINS:
6186       /* This is not allowed within BLOCK!  */
6187       if (gfc_current_state () != COMP_BLOCK)
6188         goto contains;
6189       break;
6190
6191     case_end:
6192       accept_statement (st);
6193       goto done;
6194
6195     default:
6196       break;
6197     }
6198
6199   if (gfc_current_state () == COMP_FUNCTION)
6200     gfc_check_function_type (gfc_current_ns);
6201
6202 loop:
6203   for (;;)
6204     {
6205       st = parse_executable (st);
6206
6207       switch (st)
6208         {
6209         case ST_NONE:
6210           unexpected_eof ();
6211
6212         case ST_CONTAINS:
6213           /* This is not allowed within BLOCK!  */
6214           if (gfc_current_state () != COMP_BLOCK)
6215             goto contains;
6216           break;
6217
6218         case_end:
6219           accept_statement (st);
6220           goto done;
6221
6222         default:
6223           break;
6224         }
6225
6226       unexpected_statement (st);
6227       reject_statement ();
6228       st = next_statement ();
6229     }
6230
6231 contains:
6232   n = 0;
6233
6234   for (p = gfc_state_stack; p; p = p->previous)
6235     if (p->state == COMP_CONTAINS)
6236       n++;
6237
6238   if (gfc_find_state (COMP_MODULE) == true
6239       || gfc_find_state (COMP_SUBMODULE) == true)
6240     n--;
6241
6242   if (n > 0)
6243     {
6244       gfc_error ("CONTAINS statement at %C is already in a contained "
6245                  "program unit");
6246       reject_statement ();
6247       st = next_statement ();
6248       goto loop;
6249     }
6250
6251   parse_contained (0);
6252
6253 done:
6254   gfc_current_ns->code = gfc_state_stack->head;
6255 }
6256
6257
6258 /* Come here to complain about a global symbol already in use as
6259    something else.  */
6260
6261 void
6262 gfc_global_used (gfc_gsymbol *sym, locus *where)
6263 {
6264   const char *name;
6265
6266   if (where == NULL)
6267     where = &gfc_current_locus;
6268
6269   switch(sym->type)
6270     {
6271     case GSYM_PROGRAM:
6272       name = "PROGRAM";
6273       break;
6274     case GSYM_FUNCTION:
6275       name = "FUNCTION";
6276       break;
6277     case GSYM_SUBROUTINE:
6278       name = "SUBROUTINE";
6279       break;
6280     case GSYM_COMMON:
6281       name = "COMMON";
6282       break;
6283     case GSYM_BLOCK_DATA:
6284       name = "BLOCK DATA";
6285       break;
6286     case GSYM_MODULE:
6287       name = "MODULE";
6288       break;
6289     default:
6290       name = NULL;
6291     }
6292
6293   if (name)
6294     {
6295       if (sym->binding_label)
6296         gfc_error ("Global binding name %qs at %L is already being used "
6297                    "as a %s at %L", sym->binding_label, where, name,
6298                    &sym->where);
6299       else
6300         gfc_error ("Global name %qs at %L is already being used as "
6301                    "a %s at %L", sym->name, where, name, &sym->where);
6302     }
6303   else
6304     {
6305       if (sym->binding_label)
6306         gfc_error ("Global binding name %qs at %L is already being used "
6307                    "at %L", sym->binding_label, where, &sym->where);
6308       else
6309         gfc_error ("Global name %qs at %L is already being used at %L",
6310                    sym->name, where, &sym->where);
6311     }
6312 }
6313
6314
6315 /* Parse a block data program unit.  */
6316
6317 static void
6318 parse_block_data (void)
6319 {
6320   gfc_statement st;
6321   static locus blank_locus;
6322   static int blank_block=0;
6323   gfc_gsymbol *s;
6324
6325   gfc_current_ns->proc_name = gfc_new_block;
6326   gfc_current_ns->is_block_data = 1;
6327
6328   if (gfc_new_block == NULL)
6329     {
6330       if (blank_block)
6331        gfc_error ("Blank BLOCK DATA at %C conflicts with "
6332                   "prior BLOCK DATA at %L", &blank_locus);
6333       else
6334        {
6335          blank_block = 1;
6336          blank_locus = gfc_current_locus;
6337        }
6338     }
6339   else
6340     {
6341       s = gfc_get_gsymbol (gfc_new_block->name, false);
6342       if (s->defined
6343           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
6344        gfc_global_used (s, &gfc_new_block->declared_at);
6345       else
6346        {
6347          s->type = GSYM_BLOCK_DATA;
6348          s->where = gfc_new_block->declared_at;
6349          s->defined = 1;
6350        }
6351     }
6352
6353   st = parse_spec (ST_NONE);
6354
6355   while (st != ST_END_BLOCK_DATA)
6356     {
6357       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
6358                  gfc_ascii_statement (st));
6359       reject_statement ();
6360       st = next_statement ();
6361     }
6362 }
6363
6364
6365 /* Following the association of the ancestor (sub)module symbols, they
6366    must be set host rather than use associated and all must be public.
6367    They are flagged up by 'used_in_submodule' so that they can be set
6368    DECL_EXTERNAL in trans_decl.c(gfc_finish_var_decl).  Otherwise the
6369    linker chokes on multiple symbol definitions.  */
6370
6371 static void
6372 set_syms_host_assoc (gfc_symbol *sym)
6373 {
6374   gfc_component *c;
6375   const char dot[2] = ".";
6376   /* Symbols take the form module.submodule_ or module.name_. */
6377   char parent1[2 * GFC_MAX_SYMBOL_LEN + 2];
6378   char parent2[2 * GFC_MAX_SYMBOL_LEN + 2];
6379
6380   if (sym == NULL)
6381     return;
6382
6383   if (sym->attr.module_procedure)
6384     sym->attr.external = 0;
6385
6386   sym->attr.use_assoc = 0;
6387   sym->attr.host_assoc = 1;
6388   sym->attr.used_in_submodule =1;
6389
6390   if (sym->attr.flavor == FL_DERIVED)
6391     {
6392       /* Derived types with PRIVATE components that are declared in
6393          modules other than the parent module must not be changed to be
6394          PUBLIC. The 'use-assoc' attribute must be reset so that the
6395          test in symbol.c(gfc_find_component) works correctly. This is
6396          not necessary for PRIVATE symbols since they are not read from
6397          the module.  */
6398       memset(parent1, '\0', sizeof(parent1));
6399       memset(parent2, '\0', sizeof(parent2));
6400       strcpy (parent1, gfc_new_block->name);
6401       strcpy (parent2, sym->module);
6402       if (strcmp (strtok (parent1, dot), strtok (parent2, dot)) == 0)
6403         {
6404           for (c = sym->components; c; c = c->next)
6405             c->attr.access = ACCESS_PUBLIC;
6406         }
6407       else
6408         {
6409           sym->attr.use_assoc = 1;
6410           sym->attr.host_assoc = 0;
6411         }
6412     }
6413 }
6414
6415 /* Parse a module subprogram.  */
6416
6417 static void
6418 parse_module (void)
6419 {
6420   gfc_statement st;
6421   gfc_gsymbol *s;
6422   bool error;
6423
6424   s = gfc_get_gsymbol (gfc_new_block->name, false);
6425   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
6426     gfc_global_used (s, &gfc_new_block->declared_at);
6427   else
6428     {
6429       s->type = GSYM_MODULE;
6430       s->where = gfc_new_block->declared_at;
6431       s->defined = 1;
6432     }
6433
6434   /* Something is nulling the module_list after this point. This is good
6435      since it allows us to 'USE' the parent modules that the submodule
6436      inherits and to set (most) of the symbols as host associated.  */
6437   if (gfc_current_state () == COMP_SUBMODULE)
6438     {
6439       use_modules ();
6440       gfc_traverse_ns (gfc_current_ns, set_syms_host_assoc);
6441     }
6442
6443   st = parse_spec (ST_NONE);
6444
6445   error = false;
6446 loop:
6447   switch (st)
6448     {
6449     case ST_NONE:
6450       unexpected_eof ();
6451
6452     case ST_CONTAINS:
6453       parse_contained (1);
6454       break;
6455
6456     case ST_END_MODULE:
6457     case ST_END_SUBMODULE:
6458       accept_statement (st);
6459       break;
6460
6461     default:
6462       gfc_error ("Unexpected %s statement in MODULE at %C",
6463                  gfc_ascii_statement (st));
6464
6465       error = true;
6466       reject_statement ();
6467       st = next_statement ();
6468       goto loop;
6469     }
6470
6471   /* Make sure not to free the namespace twice on error.  */
6472   if (!error)
6473     s->ns = gfc_current_ns;
6474 }
6475
6476
6477 /* Add a procedure name to the global symbol table.  */
6478
6479 static void
6480 add_global_procedure (bool sub)
6481 {
6482   gfc_gsymbol *s;
6483
6484   /* Only in Fortran 2003: For procedures with a binding label also the Fortran
6485      name is a global identifier.  */
6486   if (!gfc_new_block->binding_label || gfc_notification_std (GFC_STD_F2008))
6487     {
6488       s = gfc_get_gsymbol (gfc_new_block->name, false);
6489
6490       if (s->defined
6491           || (s->type != GSYM_UNKNOWN
6492               && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6493         {
6494           gfc_global_used (s, &gfc_new_block->declared_at);
6495           /* Silence follow-up errors.  */
6496           gfc_new_block->binding_label = NULL;
6497         }
6498       else
6499         {
6500           s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6501           s->sym_name = gfc_new_block->name;
6502           s->where = gfc_new_block->declared_at;
6503           s->defined = 1;
6504           s->ns = gfc_current_ns;
6505         }
6506     }
6507
6508   /* Don't add the symbol multiple times.  */
6509   if (gfc_new_block->binding_label
6510       && (!gfc_notification_std (GFC_STD_F2008)
6511           || strcmp (gfc_new_block->name, gfc_new_block->binding_label) != 0))
6512     {
6513       s = gfc_get_gsymbol (gfc_new_block->binding_label, true);
6514
6515       if (s->defined
6516           || (s->type != GSYM_UNKNOWN
6517               && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
6518         {
6519           gfc_global_used (s, &gfc_new_block->declared_at);
6520           /* Silence follow-up errors.  */
6521           gfc_new_block->binding_label = NULL;
6522         }
6523       else
6524         {
6525           s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
6526           s->sym_name = gfc_new_block->name;
6527           s->binding_label = gfc_new_block->binding_label;
6528           s->where = gfc_new_block->declared_at;
6529           s->defined = 1;
6530           s->ns = gfc_current_ns;
6531         }
6532     }
6533 }
6534
6535
6536 /* Add a program to the global symbol table.  */
6537
6538 static void
6539 add_global_program (void)
6540 {
6541   gfc_gsymbol *s;
6542
6543   if (gfc_new_block == NULL)
6544     return;
6545   s = gfc_get_gsymbol (gfc_new_block->name, false);
6546
6547   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
6548     gfc_global_used (s, &gfc_new_block->declared_at);
6549   else
6550     {
6551       s->type = GSYM_PROGRAM;
6552       s->where = gfc_new_block->declared_at;
6553       s->defined = 1;
6554       s->ns = gfc_current_ns;
6555     }
6556 }
6557
6558
6559 /* Resolve all the program units.  */
6560 static void
6561 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
6562 {
6563   gfc_derived_types = NULL;
6564   gfc_current_ns = gfc_global_ns_list;
6565   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6566     {
6567       if (gfc_current_ns->proc_name
6568           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6569         continue; /* Already resolved.  */
6570
6571       if (gfc_current_ns->proc_name)
6572         gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6573       gfc_resolve (gfc_current_ns);
6574       gfc_current_ns->derived_types = gfc_derived_types;
6575       gfc_derived_types = NULL;
6576     }
6577 }
6578
6579
6580 static void
6581 clean_up_modules (gfc_gsymbol *&gsym)
6582 {
6583   if (gsym == NULL)
6584     return;
6585
6586   clean_up_modules (gsym->left);
6587   clean_up_modules (gsym->right);
6588
6589   if (gsym->type != GSYM_MODULE)
6590     return;
6591
6592   if (gsym->ns)
6593     {
6594       gfc_current_ns = gsym->ns;
6595       gfc_derived_types = gfc_current_ns->derived_types;
6596       gfc_done_2 ();
6597       gsym->ns = NULL;
6598     }
6599   free (gsym);
6600   gsym = NULL;
6601 }
6602
6603
6604 /* Translate all the program units. This could be in a different order
6605    to resolution if there are forward references in the file.  */
6606 static void
6607 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
6608 {
6609   int errors;
6610
6611   gfc_current_ns = gfc_global_ns_list;
6612   gfc_get_errors (NULL, &errors);
6613
6614   /* We first translate all modules to make sure that later parts
6615      of the program can use the decl. Then we translate the nonmodules.  */
6616
6617   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6618     {
6619       if (!gfc_current_ns->proc_name
6620           || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6621         continue;
6622
6623       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
6624       gfc_derived_types = gfc_current_ns->derived_types;
6625       gfc_generate_module_code (gfc_current_ns);
6626       gfc_current_ns->translated = 1;
6627     }
6628
6629   gfc_current_ns = gfc_global_ns_list;
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_code (gfc_current_ns);
6639       gfc_current_ns->translated = 1;
6640     }
6641
6642   /* Clean up all the namespaces after translation.  */
6643   gfc_current_ns = gfc_global_ns_list;
6644   for (;gfc_current_ns;)
6645     {
6646       gfc_namespace *ns;
6647
6648       if (gfc_current_ns->proc_name
6649           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
6650         {
6651           gfc_current_ns = gfc_current_ns->sibling;
6652           continue;
6653         }
6654
6655       ns = gfc_current_ns->sibling;
6656       gfc_derived_types = gfc_current_ns->derived_types;
6657       gfc_done_2 ();
6658       gfc_current_ns = ns;
6659     }
6660
6661   clean_up_modules (gfc_gsym_root);
6662 }
6663
6664
6665 /* Top level parser.  */
6666
6667 bool
6668 gfc_parse_file (void)
6669 {
6670   int seen_program, errors_before, errors;
6671   gfc_state_data top, s;
6672   gfc_statement st;
6673   locus prog_locus;
6674   gfc_namespace *next;
6675
6676   gfc_start_source_files ();
6677
6678   top.state = COMP_NONE;
6679   top.sym = NULL;
6680   top.previous = NULL;
6681   top.head = top.tail = NULL;
6682   top.do_variable = NULL;
6683
6684   gfc_state_stack = &top;
6685
6686   gfc_clear_new_st ();
6687
6688   gfc_statement_label = NULL;
6689
6690   if (setjmp (eof_buf))
6691     return false;       /* Come here on unexpected EOF */
6692
6693   /* Prepare the global namespace that will contain the
6694      program units.  */
6695   gfc_global_ns_list = next = NULL;
6696
6697   seen_program = 0;
6698   errors_before = 0;
6699
6700   /* Exit early for empty files.  */
6701   if (gfc_at_eof ())
6702     goto done;
6703
6704   in_specification_block = true;
6705 loop:
6706   gfc_init_2 ();
6707   st = next_statement ();
6708   switch (st)
6709     {
6710     case ST_NONE:
6711       gfc_done_2 ();
6712       goto done;
6713
6714     case ST_PROGRAM:
6715       if (seen_program)
6716         goto duplicate_main;
6717       seen_program = 1;
6718       prog_locus = gfc_current_locus;
6719
6720       push_state (&s, COMP_PROGRAM, gfc_new_block);
6721       main_program_symbol (gfc_current_ns, gfc_new_block->name);
6722       accept_statement (st);
6723       add_global_program ();
6724       parse_progunit (ST_NONE);
6725       goto prog_units;
6726
6727     case ST_SUBROUTINE:
6728       add_global_procedure (true);
6729       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
6730       accept_statement (st);
6731       parse_progunit (ST_NONE);
6732       goto prog_units;
6733
6734     case ST_FUNCTION:
6735       add_global_procedure (false);
6736       push_state (&s, COMP_FUNCTION, gfc_new_block);
6737       accept_statement (st);
6738       parse_progunit (ST_NONE);
6739       goto prog_units;
6740
6741     case ST_BLOCK_DATA:
6742       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
6743       accept_statement (st);
6744       parse_block_data ();
6745       break;
6746
6747     case ST_MODULE:
6748       push_state (&s, COMP_MODULE, gfc_new_block);
6749       accept_statement (st);
6750
6751       gfc_get_errors (NULL, &errors_before);
6752       parse_module ();
6753       break;
6754
6755     case ST_SUBMODULE:
6756       push_state (&s, COMP_SUBMODULE, gfc_new_block);
6757       accept_statement (st);
6758
6759       gfc_get_errors (NULL, &errors_before);
6760       parse_module ();
6761       break;
6762
6763     /* Anything else starts a nameless main program block.  */
6764     default:
6765       if (seen_program)
6766         goto duplicate_main;
6767       seen_program = 1;
6768       prog_locus = gfc_current_locus;
6769
6770       push_state (&s, COMP_PROGRAM, gfc_new_block);
6771       main_program_symbol (gfc_current_ns, "MAIN__");
6772       parse_progunit (st);
6773       goto prog_units;
6774     }
6775
6776   /* Handle the non-program units.  */
6777   gfc_current_ns->code = s.head;
6778
6779   gfc_resolve (gfc_current_ns);
6780
6781   /* Fix the implicit_pure attribute for those procedures who should
6782      not have it.  */
6783   while (gfc_fix_implicit_pure (gfc_current_ns))
6784     ;
6785
6786   /* Dump the parse tree if requested.  */
6787   if (flag_dump_fortran_original)
6788     gfc_dump_parse_tree (gfc_current_ns, stdout);
6789
6790   gfc_get_errors (NULL, &errors);
6791   if (s.state == COMP_MODULE || s.state == COMP_SUBMODULE)
6792     {
6793       gfc_dump_module (s.sym->name, errors_before == errors);
6794       gfc_current_ns->derived_types = gfc_derived_types;
6795       gfc_derived_types = NULL;
6796       goto prog_units;
6797     }
6798   else
6799     {
6800       if (errors == 0)
6801         gfc_generate_code (gfc_current_ns);
6802       pop_state ();
6803       gfc_done_2 ();
6804     }
6805
6806   goto loop;
6807
6808 prog_units:
6809   /* The main program and non-contained procedures are put
6810      in the global namespace list, so that they can be processed
6811      later and all their interfaces resolved.  */
6812   gfc_current_ns->code = s.head;
6813   if (next)
6814     {
6815       for (; next->sibling; next = next->sibling)
6816         ;
6817       next->sibling = gfc_current_ns;
6818     }
6819   else
6820     gfc_global_ns_list = gfc_current_ns;
6821
6822   next = gfc_current_ns;
6823
6824   pop_state ();
6825   goto loop;
6826
6827 done:
6828   /* Do the resolution.  */
6829   resolve_all_program_units (gfc_global_ns_list);
6830
6831   /* Go through all top-level namespaces and unset the implicit_pure
6832      attribute for any procedures that call something not pure or
6833      implicit_pure.  Because the a procedure marked as not implicit_pure
6834      in one sweep may be called by another routine, we repeat this
6835      process until there are no more changes.  */
6836   bool changed;
6837   do
6838     {
6839       changed = false;
6840       for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6841            gfc_current_ns = gfc_current_ns->sibling)
6842         {
6843           if (gfc_fix_implicit_pure (gfc_current_ns))
6844             changed = true;
6845         }
6846     }
6847   while (changed);
6848
6849   /* Fixup for external procedures and resolve 'omp requires'.  */
6850   int omp_requires;
6851   omp_requires = 0;
6852   for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6853        gfc_current_ns = gfc_current_ns->sibling)
6854     {
6855       omp_requires |= gfc_current_ns->omp_requires;
6856       gfc_check_externals (gfc_current_ns);
6857     }
6858   for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6859        gfc_current_ns = gfc_current_ns->sibling)
6860     gfc_check_omp_requires (gfc_current_ns, omp_requires);
6861
6862   /* Populate omp_requires_mask (needed for resolving OpenMP
6863      metadirectives and declare variant).  */
6864   switch (omp_requires & OMP_REQ_ATOMIC_MEM_ORDER_MASK)
6865     {
6866     case OMP_REQ_ATOMIC_MEM_ORDER_SEQ_CST:
6867       omp_requires_mask
6868         = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_SEQ_CST);
6869       break;
6870     case OMP_REQ_ATOMIC_MEM_ORDER_ACQ_REL:
6871       omp_requires_mask
6872         = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_ACQ_REL);
6873       break;
6874     case OMP_REQ_ATOMIC_MEM_ORDER_RELAXED:
6875       omp_requires_mask
6876         = (enum omp_requires) (omp_requires_mask | OMP_MEMORY_ORDER_RELAXED);
6877       break;
6878     }
6879
6880   /* Do the parse tree dump.  */
6881   gfc_current_ns = flag_dump_fortran_original ? gfc_global_ns_list : NULL;
6882
6883   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
6884     if (!gfc_current_ns->proc_name
6885         || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
6886       {
6887         gfc_dump_parse_tree (gfc_current_ns, stdout);
6888         fputs ("------------------------------------------\n\n", stdout);
6889       }
6890
6891   /* Dump C prototypes.  */
6892   if (flag_c_prototypes || flag_c_prototypes_external)
6893     {
6894       fprintf (stdout,
6895                "#include <stddef.h>\n"
6896                "#ifdef __cplusplus\n"
6897                "#include <complex>\n"
6898                "#define __GFORTRAN_FLOAT_COMPLEX std::complex<float>\n"
6899                "#define __GFORTRAN_DOUBLE_COMPLEX std::complex<double>\n"
6900                "#define __GFORTRAN_LONG_DOUBLE_COMPLEX std::complex<long double>\n"
6901                "extern \"C\" {\n"
6902                "#else\n"
6903                "#define __GFORTRAN_FLOAT_COMPLEX float _Complex\n"
6904                "#define __GFORTRAN_DOUBLE_COMPLEX double _Complex\n"
6905                "#define __GFORTRAN_LONG_DOUBLE_COMPLEX long double _Complex\n"
6906                "#endif\n\n");
6907     }
6908
6909   /* First dump BIND(C) prototypes.  */
6910   if (flag_c_prototypes)
6911     {
6912       for (gfc_current_ns = gfc_global_ns_list; gfc_current_ns;
6913            gfc_current_ns = gfc_current_ns->sibling)
6914         gfc_dump_c_prototypes (gfc_current_ns, stdout);
6915     }
6916
6917   /* Dump external prototypes.  */
6918   if (flag_c_prototypes_external)
6919     gfc_dump_external_c_prototypes (stdout);
6920
6921   if (flag_c_prototypes || flag_c_prototypes_external)
6922     fprintf (stdout, "\n#ifdef __cplusplus\n}\n#endif\n");
6923
6924   /* Do the translation.  */
6925   translate_all_program_units (gfc_global_ns_list);
6926
6927   /* Dump the global symbol ist.  We only do this here because part
6928      of it is generated after mangling the identifiers in
6929      trans-decl.c.  */
6930
6931   if (flag_dump_fortran_global)
6932     gfc_dump_global_symbols (stdout);
6933
6934   gfc_end_source_files ();
6935   return true;
6936
6937 duplicate_main:
6938   /* If we see a duplicate main program, shut down.  If the second
6939      instance is an implied main program, i.e. data decls or executable
6940      statements, we're in for lots of errors.  */
6941   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
6942   reject_statement ();
6943   gfc_done_2 ();
6944   return true;
6945 }
6946
6947 /* Return true if this state data represents an OpenACC region.  */
6948 bool
6949 is_oacc (gfc_state_data *sd)
6950 {
6951   switch (sd->construct->op)
6952     {
6953     case EXEC_OACC_PARALLEL_LOOP:
6954     case EXEC_OACC_PARALLEL:
6955     case EXEC_OACC_KERNELS_LOOP:
6956     case EXEC_OACC_KERNELS:
6957     case EXEC_OACC_SERIAL_LOOP:
6958     case EXEC_OACC_SERIAL:
6959     case EXEC_OACC_DATA:
6960     case EXEC_OACC_HOST_DATA:
6961     case EXEC_OACC_LOOP:
6962     case EXEC_OACC_UPDATE:
6963     case EXEC_OACC_WAIT:
6964     case EXEC_OACC_CACHE:
6965     case EXEC_OACC_ENTER_DATA:
6966     case EXEC_OACC_EXIT_DATA:
6967     case EXEC_OACC_ATOMIC:
6968     case EXEC_OACC_ROUTINE:
6969       return true;
6970
6971     default:
6972       return false;
6973     }
6974 }