gcc/fortran/parse.c

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