gcc/fortran/parse.c

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