gcc/fortran/parse.c

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