gcc/fortran/parse.c

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