gcc/fortran/parse.cc

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