gcc/fortran/parse.c

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