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;
1972   gfc_statement st;
1973   gfc_state_data s;
1974   gfc_symbol *sym;
1975   gfc_component *c;
1976
1977   accept_statement (ST_DERIVED_DECL);
1978   push_state (&s, COMP_DERIVED, gfc_new_block);
1979
1980   gfc_new_block->component_access = ACCESS_PUBLIC;
1981   seen_private = 0;
1982   seen_sequence = 0;
1983   seen_component = 0;
1984
1985   compiling_type = 1;
1986
1987   while (compiling_type)
1988     {
1989       st = next_statement ();
1990       switch (st)
1991         {
1992         case ST_NONE:
1993           unexpected_eof ();
1994
1995         case ST_DATA_DECL:
1996         case ST_PROCEDURE:
1997           accept_statement (st);
1998           seen_component = 1;
1999           break;
2000
2001         case ST_FINAL:
2002           gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2003           break;
2004
2005         case ST_END_TYPE:
2006 endType:
2007           compiling_type = 0;
2008
2009           if (!seen_component)
2010             gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
2011                             "definition at %C without components");
2012
2013           accept_statement (ST_END_TYPE);
2014           break;
2015
2016         case ST_PRIVATE:
2017           if (gfc_find_state (COMP_MODULE) == FAILURE)
2018             {
2019               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2020                          "a MODULE");
2021               break;
2022             }
2023
2024           if (seen_component)
2025             {
2026               gfc_error ("PRIVATE statement at %C must precede "
2027                          "structure components");
2028               break;
2029             }
2030
2031           if (seen_private)
2032             gfc_error ("Duplicate PRIVATE statement at %C");
2033
2034           s.sym->component_access = ACCESS_PRIVATE;
2035
2036           accept_statement (ST_PRIVATE);
2037           seen_private = 1;
2038           break;
2039
2040         case ST_SEQUENCE:
2041           if (seen_component)
2042             {
2043               gfc_error ("SEQUENCE statement at %C must precede "
2044                          "structure components");
2045               break;
2046             }
2047
2048           if (gfc_current_block ()->attr.sequence)
2049             gfc_warning ("SEQUENCE attribute at %C already specified in "
2050                          "TYPE statement");
2051
2052           if (seen_sequence)
2053             {
2054               gfc_error ("Duplicate SEQUENCE statement at %C");
2055             }
2056
2057           seen_sequence = 1;
2058           gfc_add_sequence (&gfc_current_block ()->attr,
2059                             gfc_current_block ()->name, NULL);
2060           break;
2061
2062         case ST_CONTAINS:
2063           gfc_notify_std (GFC_STD_F2003,
2064                           "Fortran 2003:  CONTAINS block in derived type"
2065                           " definition at %C");
2066
2067           accept_statement (ST_CONTAINS);
2068           parse_derived_contains ();
2069           goto endType;
2070
2071         default:
2072           unexpected_statement (st);
2073           break;
2074         }
2075     }
2076
2077   /* need to verify that all fields of the derived type are
2078    * interoperable with C if the type is declared to be bind(c)
2079    */
2080   sym = gfc_current_block ();
2081   for (c = sym->components; c; c = c->next)
2082     {
2083       /* Look for allocatable components.  */
2084       if (c->attr.allocatable
2085           || (c->ts.type == BT_CLASS
2086               && c->ts.u.derived->components->attr.allocatable)
2087           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
2088         sym->attr.alloc_comp = 1;
2089
2090       /* Look for pointer components.  */
2091       if (c->attr.pointer
2092           || (c->ts.type == BT_CLASS
2093               && c->ts.u.derived->components->attr.pointer)
2094           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2095         sym->attr.pointer_comp = 1;
2096
2097       /* Look for procedure pointer components.  */
2098       if (c->attr.proc_pointer
2099           || (c->ts.type == BT_DERIVED
2100               && c->ts.u.derived->attr.proc_pointer_comp))
2101         sym->attr.proc_pointer_comp = 1;
2102
2103       /* Looking for coarray components.  */
2104       if (c->attr.codimension
2105           || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
2106         sym->attr.coarray_comp = 1;
2107
2108       /* Look for private components.  */
2109       if (sym->component_access == ACCESS_PRIVATE
2110           || c->attr.access == ACCESS_PRIVATE
2111           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2112         sym->attr.private_comp = 1;
2113     }
2114
2115   if (!seen_component)
2116     sym->attr.zero_comp = 1;
2117
2118   pop_state ();
2119 }
2120
2121
2122 /* Parse an ENUM.  */
2123
2124 static void
2125 parse_enum (void)
2126 {
2127   gfc_statement st;
2128   int compiling_enum;
2129   gfc_state_data s;
2130   int seen_enumerator = 0;
2131
2132   push_state (&s, COMP_ENUM, gfc_new_block);
2133
2134   compiling_enum = 1;
2135
2136   while (compiling_enum)
2137     {
2138       st = next_statement ();
2139       switch (st)
2140         {
2141         case ST_NONE:
2142           unexpected_eof ();
2143           break;
2144
2145         case ST_ENUMERATOR:
2146           seen_enumerator = 1;
2147           accept_statement (st);
2148           break;
2149
2150         case ST_END_ENUM:
2151           compiling_enum = 0;
2152           if (!seen_enumerator)
2153             gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2154           accept_statement (st);
2155           break;
2156
2157         default:
2158           gfc_free_enum_history ();
2159           unexpected_statement (st);
2160           break;
2161         }
2162     }
2163   pop_state ();
2164 }
2165
2166
2167 /* Parse an interface.  We must be able to deal with the possibility
2168    of recursive interfaces.  The parse_spec() subroutine is mutually
2169    recursive with parse_interface().  */
2170
2171 static gfc_statement parse_spec (gfc_statement);
2172
2173 static void
2174 parse_interface (void)
2175 {
2176   gfc_compile_state new_state = COMP_NONE, current_state;
2177   gfc_symbol *prog_unit, *sym;
2178   gfc_interface_info save;
2179   gfc_state_data s1, s2;
2180   gfc_statement st;
2181   locus proc_locus;
2182
2183   accept_statement (ST_INTERFACE);
2184
2185   current_interface.ns = gfc_current_ns;
2186   save = current_interface;
2187
2188   sym = (current_interface.type == INTERFACE_GENERIC
2189          || current_interface.type == INTERFACE_USER_OP)
2190         ? gfc_new_block : NULL;
2191
2192   push_state (&s1, COMP_INTERFACE, sym);
2193   current_state = COMP_NONE;
2194
2195 loop:
2196   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2197
2198   st = next_statement ();
2199   switch (st)
2200     {
2201     case ST_NONE:
2202       unexpected_eof ();
2203
2204     case ST_SUBROUTINE:
2205     case ST_FUNCTION:
2206       if (st == ST_SUBROUTINE)
2207         new_state = COMP_SUBROUTINE;
2208       else if (st == ST_FUNCTION)
2209         new_state = COMP_FUNCTION;
2210       if (gfc_new_block->attr.pointer)
2211         {
2212           gfc_new_block->attr.pointer = 0;
2213           gfc_new_block->attr.proc_pointer = 1;
2214         }
2215       if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2216                                   gfc_new_block->formal, NULL) == FAILURE)
2217         {
2218           reject_statement ();
2219           gfc_free_namespace (gfc_current_ns);
2220           goto loop;
2221         }
2222       break;
2223
2224     case ST_PROCEDURE:
2225     case ST_MODULE_PROC:        /* The module procedure matcher makes
2226                                    sure the context is correct.  */
2227       accept_statement (st);
2228       gfc_free_namespace (gfc_current_ns);
2229       goto loop;
2230
2231     case ST_END_INTERFACE:
2232       gfc_free_namespace (gfc_current_ns);
2233       gfc_current_ns = current_interface.ns;
2234       goto done;
2235
2236     default:
2237       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2238                  gfc_ascii_statement (st));
2239       reject_statement ();
2240       gfc_free_namespace (gfc_current_ns);
2241       goto loop;
2242     }
2243
2244
2245   /* Make sure that a generic interface has only subroutines or
2246      functions and that the generic name has the right attribute.  */
2247   if (current_interface.type == INTERFACE_GENERIC)
2248     {
2249       if (current_state == COMP_NONE)
2250         {
2251           if (new_state == COMP_FUNCTION && sym)
2252             gfc_add_function (&sym->attr, sym->name, NULL);
2253           else if (new_state == COMP_SUBROUTINE && sym)
2254             gfc_add_subroutine (&sym->attr, sym->name, NULL);
2255
2256           current_state = new_state;
2257         }
2258       else
2259         {
2260           if (new_state != current_state)
2261             {
2262               if (new_state == COMP_SUBROUTINE)
2263                 gfc_error ("SUBROUTINE at %C does not belong in a "
2264                            "generic function interface");
2265
2266               if (new_state == COMP_FUNCTION)
2267                 gfc_error ("FUNCTION at %C does not belong in a "
2268                            "generic subroutine interface");
2269             }
2270         }
2271     }
2272
2273   if (current_interface.type == INTERFACE_ABSTRACT)
2274     {
2275       gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2276       if (gfc_is_intrinsic_typename (gfc_new_block->name))
2277         gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2278                    "cannot be the same as an intrinsic type",
2279                    gfc_new_block->name);
2280     }
2281
2282   push_state (&s2, new_state, gfc_new_block);
2283   accept_statement (st);
2284   prog_unit = gfc_new_block;
2285   prog_unit->formal_ns = gfc_current_ns;
2286   proc_locus = gfc_current_locus;
2287
2288 decl:
2289   /* Read data declaration statements.  */
2290   st = parse_spec (ST_NONE);
2291
2292   /* Since the interface block does not permit an IMPLICIT statement,
2293      the default type for the function or the result must be taken
2294      from the formal namespace.  */
2295   if (new_state == COMP_FUNCTION)
2296     {
2297         if (prog_unit->result == prog_unit
2298               && prog_unit->ts.type == BT_UNKNOWN)
2299           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2300         else if (prog_unit->result != prog_unit
2301                    && prog_unit->result->ts.type == BT_UNKNOWN)
2302           gfc_set_default_type (prog_unit->result, 1,
2303                                 prog_unit->formal_ns);
2304     }
2305
2306   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2307     {
2308       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2309                  gfc_ascii_statement (st));
2310       reject_statement ();
2311       goto decl;
2312     }
2313
2314   /* Add EXTERNAL attribute to function or subroutine.  */
2315   if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2316     gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2317
2318   current_interface = save;
2319   gfc_add_interface (prog_unit);
2320   pop_state ();
2321
2322   if (current_interface.ns
2323         && current_interface.ns->proc_name
2324         && strcmp (current_interface.ns->proc_name->name,
2325                    prog_unit->name) == 0)
2326     gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2327                "enclosing procedure", prog_unit->name, &proc_locus);
2328
2329   goto loop;
2330
2331 done:
2332   pop_state ();
2333 }
2334
2335
2336 /* Associate function characteristics by going back to the function
2337    declaration and rematching the prefix.  */
2338
2339 static match
2340 match_deferred_characteristics (gfc_typespec * ts)
2341 {
2342   locus loc;
2343   match m = MATCH_ERROR;
2344   char name[GFC_MAX_SYMBOL_LEN + 1];
2345
2346   loc = gfc_current_locus;
2347
2348   gfc_current_locus = gfc_current_block ()->declared_at;
2349
2350   gfc_clear_error ();
2351   gfc_buffer_error (1);
2352   m = gfc_match_prefix (ts);
2353   gfc_buffer_error (0);
2354
2355   if (ts->type == BT_DERIVED)
2356     {
2357       ts->kind = 0;
2358
2359       if (!ts->u.derived)
2360         m = MATCH_ERROR;
2361     }
2362
2363   /* Only permit one go at the characteristic association.  */
2364   if (ts->kind == -1)
2365     ts->kind = 0;
2366
2367   /* Set the function locus correctly.  If we have not found the
2368      function name, there is an error.  */
2369   if (m == MATCH_YES
2370       && gfc_match ("function% %n", name) == MATCH_YES
2371       && strcmp (name, gfc_current_block ()->name) == 0)
2372     {
2373       gfc_current_block ()->declared_at = gfc_current_locus;
2374       gfc_commit_symbols ();
2375     }
2376   else
2377     gfc_error_check ();
2378
2379   gfc_current_locus =loc;
2380   return m;
2381 }
2382
2383
2384 /* Check specification-expressions in the function result of the currently
2385    parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2386    For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2387    scope are not yet parsed so this has to be delayed up to parse_spec.  */
2388
2389 static void
2390 check_function_result_typed (void)
2391 {
2392   gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2393
2394   gcc_assert (gfc_current_state () == COMP_FUNCTION);
2395   gcc_assert (ts->type != BT_UNKNOWN);
2396
2397   /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
2398   /* TODO:  Extend when KIND type parameters are implemented.  */
2399   if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2400     gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2401 }
2402
2403
2404 /* Parse a set of specification statements.  Returns the statement
2405    that doesn't fit.  */
2406
2407 static gfc_statement
2408 parse_spec (gfc_statement st)
2409 {
2410   st_state ss;
2411   bool function_result_typed = false;
2412   bool bad_characteristic = false;
2413   gfc_typespec *ts;
2414
2415   verify_st_order (&ss, ST_NONE, false);
2416   if (st == ST_NONE)
2417     st = next_statement ();
2418
2419   /* If we are not inside a function or don't have a result specified so far,
2420      do nothing special about it.  */
2421   if (gfc_current_state () != COMP_FUNCTION)
2422     function_result_typed = true;
2423   else
2424     {
2425       gfc_symbol* proc = gfc_current_ns->proc_name;
2426       gcc_assert (proc);
2427
2428       if (proc->result->ts.type == BT_UNKNOWN)
2429         function_result_typed = true;
2430     }
2431
2432 loop:
2433
2434   /* If we're inside a BLOCK construct, some statements are disallowed.
2435      Check this here.  Attribute declaration statements like INTENT, OPTIONAL
2436      or VALUE are also disallowed, but they don't have a particular ST_*
2437      key so we have to check for them individually in their matcher routine.  */
2438   if (gfc_current_state () == COMP_BLOCK)
2439     switch (st)
2440       {
2441         case ST_IMPLICIT:
2442         case ST_IMPLICIT_NONE:
2443         case ST_NAMELIST:
2444         case ST_COMMON:
2445         case ST_EQUIVALENCE:
2446         case ST_STATEMENT_FUNCTION:
2447           gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2448                      gfc_ascii_statement (st));
2449           break;
2450
2451         default:
2452           break;
2453       }
2454
2455   /* If we find a statement that can not be followed by an IMPLICIT statement
2456      (and thus we can expect to see none any further), type the function result
2457      if it has not yet been typed.  Be careful not to give the END statement
2458      to verify_st_order!  */
2459   if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2460     {
2461       bool verify_now = false;
2462
2463       if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2464         verify_now = true;
2465       else
2466         {
2467           st_state dummyss;
2468           verify_st_order (&dummyss, ST_NONE, false);
2469           verify_st_order (&dummyss, st, false);
2470
2471           if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2472             verify_now = true;
2473         }
2474
2475       if (verify_now)
2476         {
2477           check_function_result_typed ();
2478           function_result_typed = true;
2479         }
2480     }
2481
2482   switch (st)
2483     {
2484     case ST_NONE:
2485       unexpected_eof ();
2486
2487     case ST_IMPLICIT_NONE:
2488     case ST_IMPLICIT:
2489       if (!function_result_typed)
2490         {
2491           check_function_result_typed ();
2492           function_result_typed = true;
2493         }
2494       goto declSt;
2495
2496     case ST_FORMAT:
2497     case ST_ENTRY:
2498     case ST_DATA:       /* Not allowed in interfaces */
2499       if (gfc_current_state () == COMP_INTERFACE)
2500         break;
2501
2502       /* Fall through */
2503
2504     case ST_USE:
2505     case ST_IMPORT:
2506     case ST_PARAMETER:
2507     case ST_PUBLIC:
2508     case ST_PRIVATE:
2509     case ST_DERIVED_DECL:
2510     case_decl:
2511 declSt:
2512       if (verify_st_order (&ss, st, false) == FAILURE)
2513         {
2514           reject_statement ();
2515           st = next_statement ();
2516           goto loop;
2517         }
2518
2519       switch (st)
2520         {
2521         case ST_INTERFACE:
2522           parse_interface ();
2523           break;
2524
2525         case ST_DERIVED_DECL:
2526           parse_derived ();
2527           break;
2528
2529         case ST_PUBLIC:
2530         case ST_PRIVATE:
2531           if (gfc_current_state () != COMP_MODULE)
2532             {
2533               gfc_error ("%s statement must appear in a MODULE",
2534                          gfc_ascii_statement (st));
2535               break;
2536             }
2537
2538           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2539             {
2540               gfc_error ("%s statement at %C follows another accessibility "
2541                          "specification", gfc_ascii_statement (st));
2542               break;
2543             }
2544
2545           gfc_current_ns->default_access = (st == ST_PUBLIC)
2546             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2547
2548           break;
2549
2550         case ST_STATEMENT_FUNCTION:
2551           if (gfc_current_state () == COMP_MODULE)
2552             {
2553               unexpected_statement (st);
2554               break;
2555             }
2556
2557         default:
2558           break;
2559         }
2560
2561       accept_statement (st);
2562       st = next_statement ();
2563       goto loop;
2564
2565     case ST_ENUM:
2566       accept_statement (st);
2567       parse_enum();
2568       st = next_statement ();
2569       goto loop;
2570
2571     case ST_GET_FCN_CHARACTERISTICS:
2572       /* This statement triggers the association of a function's result
2573          characteristics.  */
2574       ts = &gfc_current_block ()->result->ts;
2575       if (match_deferred_characteristics (ts) != MATCH_YES)
2576         bad_characteristic = true;
2577
2578       st = next_statement ();
2579       goto loop;
2580
2581     default:
2582       break;
2583     }
2584
2585   /* If match_deferred_characteristics failed, then there is an error. */
2586   if (bad_characteristic)
2587     {
2588       ts = &gfc_current_block ()->result->ts;
2589       if (ts->type != BT_DERIVED)
2590         gfc_error ("Bad kind expression for function '%s' at %L",
2591                    gfc_current_block ()->name,
2592                    &gfc_current_block ()->declared_at);
2593       else
2594         gfc_error ("The type for function '%s' at %L is not accessible",
2595                    gfc_current_block ()->name,
2596                    &gfc_current_block ()->declared_at);
2597
2598       gfc_current_block ()->ts.kind = 0;
2599       /* Keep the derived type; if it's bad, it will be discovered later.  */
2600       if (!(ts->type == BT_DERIVED && ts->u.derived))
2601         ts->type = BT_UNKNOWN;
2602     }
2603
2604   return st;
2605 }
2606
2607
2608 /* Parse a WHERE block, (not a simple WHERE statement).  */
2609
2610 static void
2611 parse_where_block (void)
2612 {
2613   int seen_empty_else;
2614   gfc_code *top, *d;
2615   gfc_state_data s;
2616   gfc_statement st;
2617
2618   accept_statement (ST_WHERE_BLOCK);
2619   top = gfc_state_stack->tail;
2620
2621   push_state (&s, COMP_WHERE, gfc_new_block);
2622
2623   d = add_statement ();
2624   d->expr1 = top->expr1;
2625   d->op = EXEC_WHERE;
2626
2627   top->expr1 = NULL;
2628   top->block = d;
2629
2630   seen_empty_else = 0;
2631
2632   do
2633     {
2634       st = next_statement ();
2635       switch (st)
2636         {
2637         case ST_NONE:
2638           unexpected_eof ();
2639
2640         case ST_WHERE_BLOCK:
2641           parse_where_block ();
2642           break;
2643
2644         case ST_ASSIGNMENT:
2645         case ST_WHERE:
2646           accept_statement (st);
2647           break;
2648
2649         case ST_ELSEWHERE:
2650           if (seen_empty_else)
2651             {
2652               gfc_error ("ELSEWHERE statement at %C follows previous "
2653                          "unmasked ELSEWHERE");
2654               break;
2655             }
2656
2657           if (new_st.expr1 == NULL)
2658             seen_empty_else = 1;
2659
2660           d = new_level (gfc_state_stack->head);
2661           d->op = EXEC_WHERE;
2662           d->expr1 = new_st.expr1;
2663
2664           accept_statement (st);
2665
2666           break;
2667
2668         case ST_END_WHERE:
2669           accept_statement (st);
2670           break;
2671
2672         default:
2673           gfc_error ("Unexpected %s statement in WHERE block at %C",
2674                      gfc_ascii_statement (st));
2675           reject_statement ();
2676           break;
2677         }
2678     }
2679   while (st != ST_END_WHERE);
2680
2681   pop_state ();
2682 }
2683
2684
2685 /* Parse a FORALL block (not a simple FORALL statement).  */
2686
2687 static void
2688 parse_forall_block (void)
2689 {
2690   gfc_code *top, *d;
2691   gfc_state_data s;
2692   gfc_statement st;
2693
2694   accept_statement (ST_FORALL_BLOCK);
2695   top = gfc_state_stack->tail;
2696
2697   push_state (&s, COMP_FORALL, gfc_new_block);
2698
2699   d = add_statement ();
2700   d->op = EXEC_FORALL;
2701   top->block = d;
2702
2703   do
2704     {
2705       st = next_statement ();
2706       switch (st)
2707         {
2708
2709         case ST_ASSIGNMENT:
2710         case ST_POINTER_ASSIGNMENT:
2711         case ST_WHERE:
2712         case ST_FORALL:
2713           accept_statement (st);
2714           break;
2715
2716         case ST_WHERE_BLOCK:
2717           parse_where_block ();
2718           break;
2719
2720         case ST_FORALL_BLOCK:
2721           parse_forall_block ();
2722           break;
2723
2724         case ST_END_FORALL:
2725           accept_statement (st);
2726           break;
2727
2728         case ST_NONE:
2729           unexpected_eof ();
2730
2731         default:
2732           gfc_error ("Unexpected %s statement in FORALL block at %C",
2733                      gfc_ascii_statement (st));
2734
2735           reject_statement ();
2736           break;
2737         }
2738     }
2739   while (st != ST_END_FORALL);
2740
2741   pop_state ();
2742 }
2743
2744
2745 static gfc_statement parse_executable (gfc_statement);
2746
2747 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2748
2749 static void
2750 parse_if_block (void)
2751 {
2752   gfc_code *top, *d;
2753   gfc_statement st;
2754   locus else_locus;
2755   gfc_state_data s;
2756   int seen_else;
2757
2758   seen_else = 0;
2759   accept_statement (ST_IF_BLOCK);
2760
2761   top = gfc_state_stack->tail;
2762   push_state (&s, COMP_IF, gfc_new_block);
2763
2764   new_st.op = EXEC_IF;
2765   d = add_statement ();
2766
2767   d->expr1 = top->expr1;
2768   top->expr1 = NULL;
2769   top->block = d;
2770
2771   do
2772     {
2773       st = parse_executable (ST_NONE);
2774
2775       switch (st)
2776         {
2777         case ST_NONE:
2778           unexpected_eof ();
2779
2780         case ST_ELSEIF:
2781           if (seen_else)
2782             {
2783               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2784                          "statement at %L", &else_locus);
2785
2786               reject_statement ();
2787               break;
2788             }
2789
2790           d = new_level (gfc_state_stack->head);
2791           d->op = EXEC_IF;
2792           d->expr1 = new_st.expr1;
2793
2794           accept_statement (st);
2795
2796           break;
2797
2798         case ST_ELSE:
2799           if (seen_else)
2800             {
2801               gfc_error ("Duplicate ELSE statements at %L and %C",
2802                          &else_locus);
2803               reject_statement ();
2804               break;
2805             }
2806
2807           seen_else = 1;
2808           else_locus = gfc_current_locus;
2809
2810           d = new_level (gfc_state_stack->head);
2811           d->op = EXEC_IF;
2812
2813           accept_statement (st);
2814
2815           break;
2816
2817         case ST_ENDIF:
2818           break;
2819
2820         default:
2821           unexpected_statement (st);
2822           break;
2823         }
2824     }
2825   while (st != ST_ENDIF);
2826
2827   pop_state ();
2828   accept_statement (st);
2829 }
2830
2831
2832 /* Parse a SELECT block.  */
2833
2834 static void
2835 parse_select_block (void)
2836 {
2837   gfc_statement st;
2838   gfc_code *cp;
2839   gfc_state_data s;
2840
2841   accept_statement (ST_SELECT_CASE);
2842
2843   cp = gfc_state_stack->tail;
2844   push_state (&s, COMP_SELECT, gfc_new_block);
2845
2846   /* Make sure that the next statement is a CASE or END SELECT.  */
2847   for (;;)
2848     {
2849       st = next_statement ();
2850       if (st == ST_NONE)
2851         unexpected_eof ();
2852       if (st == ST_END_SELECT)
2853         {
2854           /* Empty SELECT CASE is OK.  */
2855           accept_statement (st);
2856           pop_state ();
2857           return;
2858         }
2859       if (st == ST_CASE)
2860         break;
2861
2862       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2863                  "CASE at %C");
2864
2865       reject_statement ();
2866     }
2867
2868   /* At this point, we're got a nonempty select block.  */
2869   cp = new_level (cp);
2870   *cp = new_st;
2871
2872   accept_statement (st);
2873
2874   do
2875     {
2876       st = parse_executable (ST_NONE);
2877       switch (st)
2878         {
2879         case ST_NONE:
2880           unexpected_eof ();
2881
2882         case ST_CASE:
2883           cp = new_level (gfc_state_stack->head);
2884           *cp = new_st;
2885           gfc_clear_new_st ();
2886
2887           accept_statement (st);
2888           /* Fall through */
2889
2890         case ST_END_SELECT:
2891           break;
2892
2893         /* Can't have an executable statement because of
2894            parse_executable().  */
2895         default:
2896           unexpected_statement (st);
2897           break;
2898         }
2899     }
2900   while (st != ST_END_SELECT);
2901
2902   pop_state ();
2903   accept_statement (st);
2904 }
2905
2906
2907 /* Pop the current selector from the SELECT TYPE stack.  */
2908
2909 static void
2910 select_type_pop (void)
2911 {
2912   gfc_select_type_stack *old = select_type_stack;
2913   select_type_stack = old->prev;
2914   gfc_free (old);
2915 }
2916
2917
2918 /* Parse a SELECT TYPE construct (F03:R821).  */
2919
2920 static void
2921 parse_select_type_block (void)
2922 {
2923   gfc_statement st;
2924   gfc_code *cp;
2925   gfc_state_data s;
2926
2927   accept_statement (ST_SELECT_TYPE);
2928
2929   cp = gfc_state_stack->tail;
2930   push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
2931
2932   /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
2933      or END SELECT.  */
2934   for (;;)
2935     {
2936       st = next_statement ();
2937       if (st == ST_NONE)
2938         unexpected_eof ();
2939       if (st == ST_END_SELECT)
2940         /* Empty SELECT CASE is OK.  */
2941         goto done;
2942       if (st == ST_TYPE_IS || st == ST_CLASS_IS)
2943         break;
2944
2945       gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
2946                  "following SELECT TYPE at %C");
2947
2948       reject_statement ();
2949     }
2950
2951   /* At this point, we're got a nonempty select block.  */
2952   cp = new_level (cp);
2953   *cp = new_st;
2954
2955   accept_statement (st);
2956
2957   do
2958     {
2959       st = parse_executable (ST_NONE);
2960       switch (st)
2961         {
2962         case ST_NONE:
2963           unexpected_eof ();
2964
2965         case ST_TYPE_IS:
2966         case ST_CLASS_IS:
2967           cp = new_level (gfc_state_stack->head);
2968           *cp = new_st;
2969           gfc_clear_new_st ();
2970
2971           accept_statement (st);
2972           /* Fall through */
2973
2974         case ST_END_SELECT:
2975           break;
2976
2977         /* Can't have an executable statement because of
2978            parse_executable().  */
2979         default:
2980           unexpected_statement (st);
2981           break;
2982         }
2983     }
2984   while (st != ST_END_SELECT);
2985
2986 done:
2987   pop_state ();
2988   accept_statement (st);
2989   gfc_current_ns = gfc_current_ns->parent;
2990   select_type_pop ();
2991 }
2992
2993
2994 /* Given a symbol, make sure it is not an iteration variable for a DO
2995    statement.  This subroutine is called when the symbol is seen in a
2996    context that causes it to become redefined.  If the symbol is an
2997    iterator, we generate an error message and return nonzero.  */
2998
2999 int
3000 gfc_check_do_variable (gfc_symtree *st)
3001 {
3002   gfc_state_data *s;
3003
3004   for (s=gfc_state_stack; s; s = s->previous)
3005     if (s->do_variable == st)
3006       {
3007         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3008                       "loop beginning at %L", st->name, &s->head->loc);
3009         return 1;
3010       }
3011
3012   return 0;
3013 }
3014
3015
3016 /* Checks to see if the current statement label closes an enddo.
3017    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3018    an error) if it incorrectly closes an ENDDO.  */
3019
3020 static int
3021 check_do_closure (void)
3022 {
3023   gfc_state_data *p;
3024
3025   if (gfc_statement_label == NULL)
3026     return 0;
3027
3028   for (p = gfc_state_stack; p; p = p->previous)
3029     if (p->state == COMP_DO)
3030       break;
3031
3032   if (p == NULL)
3033     return 0;           /* No loops to close */
3034
3035   if (p->ext.end_do_label == gfc_statement_label)
3036     {
3037       if (p == gfc_state_stack)
3038         return 1;
3039
3040       gfc_error ("End of nonblock DO statement at %C is within another block");
3041       return 2;
3042     }
3043
3044   /* At this point, the label doesn't terminate the innermost loop.
3045      Make sure it doesn't terminate another one.  */
3046   for (; p; p = p->previous)
3047     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
3048       {
3049         gfc_error ("End of nonblock DO statement at %C is interwoven "
3050                    "with another DO loop");
3051         return 2;
3052       }
3053
3054   return 0;
3055 }
3056
3057
3058 /* Parse a series of contained program units.  */
3059
3060 static void parse_progunit (gfc_statement);
3061
3062
3063 /* Parse a CRITICAL block.  */
3064
3065 static void
3066 parse_critical_block (void)
3067 {
3068   gfc_code *top, *d;
3069   gfc_state_data s;
3070   gfc_statement st;
3071
3072   s.ext.end_do_label = new_st.label1;
3073
3074   accept_statement (ST_CRITICAL);
3075   top = gfc_state_stack->tail;
3076
3077   push_state (&s, COMP_CRITICAL, gfc_new_block);
3078
3079   d = add_statement ();
3080   d->op = EXEC_CRITICAL;
3081   top->block = d;
3082
3083   do
3084     {
3085       st = parse_executable (ST_NONE);
3086
3087       switch (st)
3088         {
3089           case ST_NONE:
3090             unexpected_eof ();
3091             break;
3092
3093           case ST_END_CRITICAL:
3094             if (s.ext.end_do_label != NULL
3095                 && s.ext.end_do_label != gfc_statement_label)
3096               gfc_error_now ("Statement label in END CRITICAL at %C does not "
3097                              "match CRITIAL label");
3098
3099             if (gfc_statement_label != NULL)
3100               {
3101                 new_st.op = EXEC_NOP;
3102                 add_statement ();
3103               }
3104             break;
3105
3106           default:
3107             unexpected_statement (st);
3108             break;
3109         }
3110     }
3111   while (st != ST_END_CRITICAL);
3112
3113   pop_state ();
3114   accept_statement (st);
3115 }
3116
3117
3118 /* Set up the local namespace for a BLOCK construct.  */
3119
3120 gfc_namespace*
3121 gfc_build_block_ns (gfc_namespace *parent_ns)
3122 {
3123   gfc_namespace* my_ns;
3124
3125   my_ns = gfc_get_namespace (parent_ns, 1);
3126   my_ns->construct_entities = 1;
3127
3128   /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3129      code generation (so it must not be NULL).
3130      We set its recursive argument if our container procedure is recursive, so
3131      that local variables are accordingly placed on the stack when it
3132      will be necessary.  */
3133   if (gfc_new_block)
3134     my_ns->proc_name = gfc_new_block;
3135   else
3136     {
3137       gfc_try t;
3138
3139       gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
3140       t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3141                           my_ns->proc_name->name, NULL);
3142       gcc_assert (t == SUCCESS);
3143     }
3144
3145   if (parent_ns->proc_name)
3146     my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3147
3148   return my_ns;
3149 }
3150
3151
3152 /* Parse a BLOCK construct.  */
3153
3154 static void
3155 parse_block_construct (void)
3156 {
3157   gfc_namespace* my_ns;
3158   gfc_state_data s;
3159
3160   gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
3161
3162   my_ns = gfc_build_block_ns (gfc_current_ns);
3163
3164   new_st.op = EXEC_BLOCK;
3165   new_st.ext.ns = my_ns;
3166   accept_statement (ST_BLOCK);
3167
3168   push_state (&s, COMP_BLOCK, my_ns->proc_name);
3169   gfc_current_ns = my_ns;
3170
3171   parse_progunit (ST_NONE);
3172
3173   gfc_current_ns = gfc_current_ns->parent;
3174   pop_state ();
3175 }
3176
3177
3178 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
3179    handled inside of parse_executable(), because they aren't really
3180    loop statements.  */
3181
3182 static void
3183 parse_do_block (void)
3184 {
3185   gfc_statement st;
3186   gfc_code *top;
3187   gfc_state_data s;
3188   gfc_symtree *stree;
3189
3190   s.ext.end_do_label = new_st.label1;
3191
3192   if (new_st.ext.iterator != NULL)
3193     stree = new_st.ext.iterator->var->symtree;
3194   else
3195     stree = NULL;
3196
3197   accept_statement (ST_DO);
3198
3199   top = gfc_state_stack->tail;
3200   push_state (&s, COMP_DO, gfc_new_block);
3201
3202   s.do_variable = stree;
3203
3204   top->block = new_level (top);
3205   top->block->op = EXEC_DO;
3206
3207 loop:
3208   st = parse_executable (ST_NONE);
3209
3210   switch (st)
3211     {
3212     case ST_NONE:
3213       unexpected_eof ();
3214
3215     case ST_ENDDO:
3216       if (s.ext.end_do_label != NULL
3217           && s.ext.end_do_label != gfc_statement_label)
3218         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3219                        "DO label");
3220
3221       if (gfc_statement_label != NULL)
3222         {
3223           new_st.op = EXEC_NOP;
3224           add_statement ();
3225         }
3226       break;
3227
3228     case ST_IMPLIED_ENDDO:
3229      /* If the do-stmt of this DO construct has a do-construct-name,
3230         the corresponding end-do must be an end-do-stmt (with a matching
3231         name, but in that case we must have seen ST_ENDDO first).
3232         We only complain about this in pedantic mode.  */
3233      if (gfc_current_block () != NULL)
3234         gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3235                        &gfc_current_block()->declared_at);
3236
3237       break;
3238
3239     default:
3240       unexpected_statement (st);
3241       goto loop;
3242     }
3243
3244   pop_state ();
3245   accept_statement (st);
3246 }
3247
3248
3249 /* Parse the statements of OpenMP do/parallel do.  */
3250
3251 static gfc_statement
3252 parse_omp_do (gfc_statement omp_st)
3253 {
3254   gfc_statement st;
3255   gfc_code *cp, *np;
3256   gfc_state_data s;
3257
3258   accept_statement (omp_st);
3259
3260   cp = gfc_state_stack->tail;
3261   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3262   np = new_level (cp);
3263   np->op = cp->op;
3264   np->block = NULL;
3265
3266   for (;;)
3267     {
3268       st = next_statement ();
3269       if (st == ST_NONE)
3270         unexpected_eof ();
3271       else if (st == ST_DO)
3272         break;
3273       else
3274         unexpected_statement (st);
3275     }
3276
3277   parse_do_block ();
3278   if (gfc_statement_label != NULL
3279       && gfc_state_stack->previous != NULL
3280       && gfc_state_stack->previous->state == COMP_DO
3281       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3282     {
3283       /* In
3284          DO 100 I=1,10
3285            !$OMP DO
3286              DO J=1,10
3287              ...
3288              100 CONTINUE
3289          there should be no !$OMP END DO.  */
3290       pop_state ();
3291       return ST_IMPLIED_ENDDO;
3292     }
3293
3294   check_do_closure ();
3295   pop_state ();
3296
3297   st = next_statement ();
3298   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3299     {
3300       if (new_st.op == EXEC_OMP_END_NOWAIT)
3301         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3302       else
3303         gcc_assert (new_st.op == EXEC_NOP);
3304       gfc_clear_new_st ();
3305       gfc_commit_symbols ();
3306       gfc_warning_check ();
3307       st = next_statement ();
3308     }
3309   return st;
3310 }
3311
3312
3313 /* Parse the statements of OpenMP atomic directive.  */
3314
3315 static void
3316 parse_omp_atomic (void)
3317 {
3318   gfc_statement st;
3319   gfc_code *cp, *np;
3320   gfc_state_data s;
3321
3322   accept_statement (ST_OMP_ATOMIC);
3323
3324   cp = gfc_state_stack->tail;
3325   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3326   np = new_level (cp);
3327   np->op = cp->op;
3328   np->block = NULL;
3329
3330   for (;;)
3331     {
3332       st = next_statement ();
3333       if (st == ST_NONE)
3334         unexpected_eof ();
3335       else if (st == ST_ASSIGNMENT)
3336         break;
3337       else
3338         unexpected_statement (st);
3339     }
3340
3341   accept_statement (st);
3342
3343   pop_state ();
3344 }
3345
3346
3347 /* Parse the statements of an OpenMP structured block.  */
3348
3349 static void
3350 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3351 {
3352   gfc_statement st, omp_end_st;
3353   gfc_code *cp, *np;
3354   gfc_state_data s;
3355
3356   accept_statement (omp_st);
3357
3358   cp = gfc_state_stack->tail;
3359   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3360   np = new_level (cp);
3361   np->op = cp->op;
3362   np->block = NULL;
3363
3364   switch (omp_st)
3365     {
3366     case ST_OMP_PARALLEL:
3367       omp_end_st = ST_OMP_END_PARALLEL;
3368       break;
3369     case ST_OMP_PARALLEL_SECTIONS:
3370       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3371       break;
3372     case ST_OMP_SECTIONS:
3373       omp_end_st = ST_OMP_END_SECTIONS;
3374       break;
3375     case ST_OMP_ORDERED:
3376       omp_end_st = ST_OMP_END_ORDERED;
3377       break;
3378     case ST_OMP_CRITICAL:
3379       omp_end_st = ST_OMP_END_CRITICAL;
3380       break;
3381     case ST_OMP_MASTER:
3382       omp_end_st = ST_OMP_END_MASTER;
3383       break;
3384     case ST_OMP_SINGLE:
3385       omp_end_st = ST_OMP_END_SINGLE;
3386       break;
3387     case ST_OMP_TASK:
3388       omp_end_st = ST_OMP_END_TASK;
3389       break;
3390     case ST_OMP_WORKSHARE:
3391       omp_end_st = ST_OMP_END_WORKSHARE;
3392       break;
3393     case ST_OMP_PARALLEL_WORKSHARE:
3394       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3395       break;
3396     default:
3397       gcc_unreachable ();
3398     }
3399
3400   do
3401     {
3402       if (workshare_stmts_only)
3403         {
3404           /* Inside of !$omp workshare, only
3405              scalar assignments
3406              array assignments
3407              where statements and constructs
3408              forall statements and constructs
3409              !$omp atomic
3410              !$omp critical
3411              !$omp parallel
3412              are allowed.  For !$omp critical these
3413              restrictions apply recursively.  */
3414           bool cycle = true;
3415
3416           st = next_statement ();
3417           for (;;)
3418             {
3419               switch (st)
3420                 {
3421                 case ST_NONE:
3422                   unexpected_eof ();
3423
3424                 case ST_ASSIGNMENT:
3425                 case ST_WHERE:
3426                 case ST_FORALL:
3427                   accept_statement (st);
3428                   break;
3429
3430                 case ST_WHERE_BLOCK:
3431                   parse_where_block ();
3432                   break;
3433
3434                 case ST_FORALL_BLOCK:
3435                   parse_forall_block ();
3436                   break;
3437
3438                 case ST_OMP_PARALLEL:
3439                 case ST_OMP_PARALLEL_SECTIONS:
3440                   parse_omp_structured_block (st, false);
3441                   break;
3442
3443                 case ST_OMP_PARALLEL_WORKSHARE:
3444                 case ST_OMP_CRITICAL:
3445                   parse_omp_structured_block (st, true);
3446                   break;
3447
3448                 case ST_OMP_PARALLEL_DO:
3449                   st = parse_omp_do (st);
3450                   continue;
3451
3452                 case ST_OMP_ATOMIC:
3453                   parse_omp_atomic ();
3454                   break;
3455
3456                 default:
3457                   cycle = false;
3458                   break;
3459                 }
3460
3461               if (!cycle)
3462                 break;
3463
3464               st = next_statement ();
3465             }
3466         }
3467       else
3468         st = parse_executable (ST_NONE);
3469       if (st == ST_NONE)
3470         unexpected_eof ();
3471       else if (st == ST_OMP_SECTION
3472                && (omp_st == ST_OMP_SECTIONS
3473                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
3474         {
3475           np = new_level (np);
3476           np->op = cp->op;
3477           np->block = NULL;
3478         }
3479       else if (st != omp_end_st)
3480         unexpected_statement (st);
3481     }
3482   while (st != omp_end_st);
3483
3484   switch (new_st.op)
3485     {
3486     case EXEC_OMP_END_NOWAIT:
3487       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3488       break;
3489     case EXEC_OMP_CRITICAL:
3490       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3491           || (new_st.ext.omp_name != NULL
3492               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3493         gfc_error ("Name after !$omp critical and !$omp end critical does "
3494                    "not match at %C");
3495       gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
3496       break;
3497     case EXEC_OMP_END_SINGLE:
3498       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3499         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3500       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3501       gfc_free_omp_clauses (new_st.ext.omp_clauses);
3502       break;
3503     case EXEC_NOP:
3504       break;
3505     default:
3506       gcc_unreachable ();
3507     }
3508
3509   gfc_clear_new_st ();
3510   gfc_commit_symbols ();
3511   gfc_warning_check ();
3512   pop_state ();
3513 }
3514
3515
3516 /* Accept a series of executable statements.  We return the first
3517    statement that doesn't fit to the caller.  Any block statements are
3518    passed on to the correct handler, which usually passes the buck
3519    right back here.  */
3520
3521 static gfc_statement
3522 parse_executable (gfc_statement st)
3523 {
3524   int close_flag;
3525
3526   if (st == ST_NONE)
3527     st = next_statement ();
3528
3529   for (;;)
3530     {
3531       close_flag = check_do_closure ();
3532       if (close_flag)
3533         switch (st)
3534           {
3535           case ST_GOTO:
3536           case ST_END_PROGRAM:
3537           case ST_RETURN:
3538           case ST_EXIT:
3539           case ST_END_FUNCTION:
3540           case ST_CYCLE:
3541           case ST_PAUSE:
3542           case ST_STOP:
3543           case ST_ERROR_STOP:
3544           case ST_END_SUBROUTINE:
3545
3546           case ST_DO:
3547           case ST_CRITICAL:
3548           case ST_BLOCK:
3549           case ST_FORALL:
3550           case ST_WHERE:
3551           case ST_SELECT_CASE:
3552             gfc_error ("%s statement at %C cannot terminate a non-block "
3553                        "DO loop", gfc_ascii_statement (st));
3554             break;
3555
3556           default:
3557             break;
3558           }
3559
3560       switch (st)
3561         {
3562         case ST_NONE:
3563           unexpected_eof ();
3564
3565         case ST_FORMAT:
3566         case ST_DATA:
3567         case ST_ENTRY:
3568         case_executable:
3569           accept_statement (st);
3570           if (close_flag == 1)
3571             return ST_IMPLIED_ENDDO;
3572           break;
3573
3574         case ST_BLOCK:
3575           parse_block_construct ();
3576           break;
3577
3578         case ST_IF_BLOCK:
3579           parse_if_block ();
3580           break;
3581
3582         case ST_SELECT_CASE:
3583           parse_select_block ();
3584           break;
3585
3586         case ST_SELECT_TYPE:
3587           parse_select_type_block();
3588           break;
3589
3590         case ST_DO:
3591           parse_do_block ();
3592           if (check_do_closure () == 1)
3593             return ST_IMPLIED_ENDDO;
3594           break;
3595
3596         case ST_CRITICAL:
3597           parse_critical_block ();
3598           break;
3599
3600         case ST_WHERE_BLOCK:
3601           parse_where_block ();
3602           break;
3603
3604         case ST_FORALL_BLOCK:
3605           parse_forall_block ();
3606           break;
3607
3608         case ST_OMP_PARALLEL:
3609         case ST_OMP_PARALLEL_SECTIONS:
3610         case ST_OMP_SECTIONS:
3611         case ST_OMP_ORDERED:
3612         case ST_OMP_CRITICAL:
3613         case ST_OMP_MASTER:
3614         case ST_OMP_SINGLE:
3615         case ST_OMP_TASK:
3616           parse_omp_structured_block (st, false);
3617           break;
3618
3619         case ST_OMP_WORKSHARE:
3620         case ST_OMP_PARALLEL_WORKSHARE:
3621           parse_omp_structured_block (st, true);
3622           break;
3623
3624         case ST_OMP_DO:
3625         case ST_OMP_PARALLEL_DO:
3626           st = parse_omp_do (st);
3627           if (st == ST_IMPLIED_ENDDO)
3628             return st;
3629           continue;
3630
3631         case ST_OMP_ATOMIC:
3632           parse_omp_atomic ();
3633           break;
3634
3635         default:
3636           return st;
3637         }
3638
3639       st = next_statement ();
3640     }
3641 }
3642
3643
3644 /* Fix the symbols for sibling functions.  These are incorrectly added to
3645    the child namespace as the parser didn't know about this procedure.  */
3646
3647 static void
3648 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3649 {
3650   gfc_namespace *ns;
3651   gfc_symtree *st;
3652   gfc_symbol *old_sym;
3653
3654   sym->attr.referenced = 1;
3655   for (ns = siblings; ns; ns = ns->sibling)
3656     {
3657       st = gfc_find_symtree (ns->sym_root, sym->name);
3658
3659       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3660         goto fixup_contained;
3661
3662       old_sym = st->n.sym;
3663       if (old_sym->ns == ns
3664             && !old_sym->attr.contained
3665
3666             /* By 14.6.1.3, host association should be excluded
3667                for the following.  */
3668             && !(old_sym->attr.external
3669                   || (old_sym->ts.type != BT_UNKNOWN
3670                         && !old_sym->attr.implicit_type)
3671                   || old_sym->attr.flavor == FL_PARAMETER
3672                   || old_sym->attr.in_common
3673                   || old_sym->attr.in_equivalence
3674                   || old_sym->attr.data
3675                   || old_sym->attr.dummy
3676                   || old_sym->attr.result
3677                   || old_sym->attr.dimension
3678                   || old_sym->attr.allocatable
3679                   || old_sym->attr.intrinsic
3680                   || old_sym->attr.generic
3681                   || old_sym->attr.flavor == FL_NAMELIST
3682                   || old_sym->attr.proc == PROC_ST_FUNCTION))
3683         {
3684           /* Replace it with the symbol from the parent namespace.  */
3685           st->n.sym = sym;
3686           sym->refs++;
3687
3688           /* Free the old (local) symbol.  */
3689           old_sym->refs--;
3690           if (old_sym->refs == 0)
3691             gfc_free_symbol (old_sym);
3692         }
3693
3694 fixup_contained:
3695       /* Do the same for any contained procedures.  */
3696       gfc_fixup_sibling_symbols (sym, ns->contained);
3697     }
3698 }
3699
3700 static void
3701 parse_contained (int module)
3702 {
3703   gfc_namespace *ns, *parent_ns, *tmp;
3704   gfc_state_data s1, s2;
3705   gfc_statement st;
3706   gfc_symbol *sym;
3707   gfc_entry_list *el;
3708   int contains_statements = 0;
3709   int seen_error = 0;
3710
3711   push_state (&s1, COMP_CONTAINS, NULL);
3712   parent_ns = gfc_current_ns;
3713
3714   do
3715     {
3716       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3717
3718       gfc_current_ns->sibling = parent_ns->contained;
3719       parent_ns->contained = gfc_current_ns;
3720
3721  next:
3722       /* Process the next available statement.  We come here if we got an error
3723          and rejected the last statement.  */
3724       st = next_statement ();
3725
3726       switch (st)
3727         {
3728         case ST_NONE:
3729           unexpected_eof ();
3730
3731         case ST_FUNCTION:
3732         case ST_SUBROUTINE:
3733           contains_statements = 1;
3734           accept_statement (st);
3735
3736           push_state (&s2,
3737                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3738                       gfc_new_block);
3739
3740           /* For internal procedures, create/update the symbol in the
3741              parent namespace.  */
3742
3743           if (!module)
3744             {
3745               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3746                 gfc_error ("Contained procedure '%s' at %C is already "
3747                            "ambiguous", gfc_new_block->name);
3748               else
3749                 {
3750                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3751                                          &gfc_new_block->declared_at) ==
3752                       SUCCESS)
3753                     {
3754                       if (st == ST_FUNCTION)
3755                         gfc_add_function (&sym->attr, sym->name,
3756                                           &gfc_new_block->declared_at);
3757                       else
3758                         gfc_add_subroutine (&sym->attr, sym->name,
3759                                             &gfc_new_block->declared_at);
3760                     }
3761                 }
3762
3763               gfc_commit_symbols ();
3764             }
3765           else
3766             sym = gfc_new_block;
3767
3768           /* Mark this as a contained function, so it isn't replaced
3769              by other module functions.  */
3770           sym->attr.contained = 1;
3771           sym->attr.referenced = 1;
3772
3773           parse_progunit (ST_NONE);
3774
3775           /* Fix up any sibling functions that refer to this one.  */
3776           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3777           /* Or refer to any of its alternate entry points.  */
3778           for (el = gfc_current_ns->entries; el; el = el->next)
3779             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3780
3781           gfc_current_ns->code = s2.head;
3782           gfc_current_ns = parent_ns;
3783
3784           pop_state ();
3785           break;
3786
3787         /* These statements are associated with the end of the host unit.  */
3788         case ST_END_FUNCTION:
3789         case ST_END_MODULE:
3790         case ST_END_PROGRAM:
3791         case ST_END_SUBROUTINE:
3792           accept_statement (st);
3793           break;
3794
3795         default:
3796           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3797                      gfc_ascii_statement (st));
3798           reject_statement ();
3799           seen_error = 1;
3800           goto next;
3801           break;
3802         }
3803     }
3804   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3805          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3806
3807   /* The first namespace in the list is guaranteed to not have
3808      anything (worthwhile) in it.  */
3809   tmp = gfc_current_ns;
3810   gfc_current_ns = parent_ns;
3811   if (seen_error && tmp->refs > 1)
3812     gfc_free_namespace (tmp);
3813
3814   ns = gfc_current_ns->contained;
3815   gfc_current_ns->contained = ns->sibling;
3816   gfc_free_namespace (ns);
3817
3818   pop_state ();
3819   if (!contains_statements)
3820     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3821                     "FUNCTION or SUBROUTINE statement at %C");
3822 }
3823
3824
3825 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
3826
3827 static void
3828 parse_progunit (gfc_statement st)
3829 {
3830   gfc_state_data *p;
3831   int n;
3832
3833   st = parse_spec (st);
3834   switch (st)
3835     {
3836     case ST_NONE:
3837       unexpected_eof ();
3838
3839     case ST_CONTAINS:
3840       /* This is not allowed within BLOCK!  */
3841       if (gfc_current_state () != COMP_BLOCK)
3842         goto contains;
3843       break;
3844
3845     case_end:
3846       accept_statement (st);
3847       goto done;
3848
3849     default:
3850       break;
3851     }
3852
3853   if (gfc_current_state () == COMP_FUNCTION)
3854     gfc_check_function_type (gfc_current_ns);
3855
3856 loop:
3857   for (;;)
3858     {
3859       st = parse_executable (st);
3860
3861       switch (st)
3862         {
3863         case ST_NONE:
3864           unexpected_eof ();
3865
3866         case ST_CONTAINS:
3867           /* This is not allowed within BLOCK!  */
3868           if (gfc_current_state () != COMP_BLOCK)
3869             goto contains;
3870           break;
3871
3872         case_end:
3873           accept_statement (st);
3874           goto done;
3875
3876         default:
3877           break;
3878         }
3879
3880       unexpected_statement (st);
3881       reject_statement ();
3882       st = next_statement ();
3883     }
3884
3885 contains:
3886   n = 0;
3887
3888   for (p = gfc_state_stack; p; p = p->previous)
3889     if (p->state == COMP_CONTAINS)
3890       n++;
3891
3892   if (gfc_find_state (COMP_MODULE) == SUCCESS)
3893     n--;
3894
3895   if (n > 0)
3896     {
3897       gfc_error ("CONTAINS statement at %C is already in a contained "
3898                  "program unit");
3899       st = next_statement ();
3900       goto loop;
3901     }
3902
3903   parse_contained (0);
3904
3905 done:
3906   gfc_current_ns->code = gfc_state_stack->head;
3907 }
3908
3909
3910 /* Come here to complain about a global symbol already in use as
3911    something else.  */
3912
3913 void
3914 gfc_global_used (gfc_gsymbol *sym, locus *where)
3915 {
3916   const char *name;
3917
3918   if (where == NULL)
3919     where = &gfc_current_locus;
3920
3921   switch(sym->type)
3922     {
3923     case GSYM_PROGRAM:
3924       name = "PROGRAM";
3925       break;
3926     case GSYM_FUNCTION:
3927       name = "FUNCTION";
3928       break;
3929     case GSYM_SUBROUTINE:
3930       name = "SUBROUTINE";
3931       break;
3932     case GSYM_COMMON:
3933       name = "COMMON";
3934       break;
3935     case GSYM_BLOCK_DATA:
3936       name = "BLOCK DATA";
3937       break;
3938     case GSYM_MODULE:
3939       name = "MODULE";
3940       break;
3941     default:
3942       gfc_internal_error ("gfc_global_used(): Bad type");
3943       name = NULL;
3944     }
3945
3946   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3947               sym->name, where, name, &sym->where);
3948 }
3949
3950
3951 /* Parse a block data program unit.  */
3952
3953 static void
3954 parse_block_data (void)
3955 {
3956   gfc_statement st;
3957   static locus blank_locus;
3958   static int blank_block=0;
3959   gfc_gsymbol *s;
3960
3961   gfc_current_ns->proc_name = gfc_new_block;
3962   gfc_current_ns->is_block_data = 1;
3963
3964   if (gfc_new_block == NULL)
3965     {
3966       if (blank_block)
3967        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3968                   "prior BLOCK DATA at %L", &blank_locus);
3969       else
3970        {
3971          blank_block = 1;
3972          blank_locus = gfc_current_locus;
3973        }
3974     }
3975   else
3976     {
3977       s = gfc_get_gsymbol (gfc_new_block->name);
3978       if (s->defined
3979           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3980        gfc_global_used(s, NULL);
3981       else
3982        {
3983          s->type = GSYM_BLOCK_DATA;
3984          s->where = gfc_current_locus;
3985          s->defined = 1;
3986        }
3987     }
3988
3989   st = parse_spec (ST_NONE);
3990
3991   while (st != ST_END_BLOCK_DATA)
3992     {
3993       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3994                  gfc_ascii_statement (st));
3995       reject_statement ();
3996       st = next_statement ();
3997     }
3998 }
3999
4000
4001 /* Parse a module subprogram.  */
4002
4003 static void
4004 parse_module (void)
4005 {
4006   gfc_statement st;
4007   gfc_gsymbol *s;
4008
4009   s = gfc_get_gsymbol (gfc_new_block->name);
4010   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4011     gfc_global_used(s, NULL);
4012   else
4013     {
4014       s->type = GSYM_MODULE;
4015       s->where = gfc_current_locus;
4016       s->defined = 1;
4017     }
4018
4019   st = parse_spec (ST_NONE);
4020
4021 loop:
4022   switch (st)
4023     {
4024     case ST_NONE:
4025       unexpected_eof ();
4026
4027     case ST_CONTAINS:
4028       parse_contained (1);
4029       break;
4030
4031     case ST_END_MODULE:
4032       accept_statement (st);
4033       break;
4034
4035     default:
4036       gfc_error ("Unexpected %s statement in MODULE at %C",
4037                  gfc_ascii_statement (st));
4038
4039       reject_statement ();
4040       st = next_statement ();
4041       goto loop;
4042     }
4043
4044   s->ns = gfc_current_ns;
4045 }
4046
4047
4048 /* Add a procedure name to the global symbol table.  */
4049
4050 static void
4051 add_global_procedure (int sub)
4052 {
4053   gfc_gsymbol *s;
4054
4055   s = gfc_get_gsymbol(gfc_new_block->name);
4056
4057   if (s->defined
4058       || (s->type != GSYM_UNKNOWN
4059           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4060     gfc_global_used(s, NULL);
4061   else
4062     {
4063       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4064       s->where = gfc_current_locus;
4065       s->defined = 1;
4066       s->ns = gfc_current_ns;
4067     }
4068 }
4069
4070
4071 /* Add a program to the global symbol table.  */
4072
4073 static void
4074 add_global_program (void)
4075 {
4076   gfc_gsymbol *s;
4077
4078   if (gfc_new_block == NULL)
4079     return;
4080   s = gfc_get_gsymbol (gfc_new_block->name);
4081
4082   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4083     gfc_global_used(s, NULL);
4084   else
4085     {
4086       s->type = GSYM_PROGRAM;
4087       s->where = gfc_current_locus;
4088       s->defined = 1;
4089       s->ns = gfc_current_ns;
4090     }
4091 }
4092
4093
4094 /* Resolve all the program units when whole file scope option
4095    is active. */
4096 static void
4097 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4098 {
4099   gfc_free_dt_list ();
4100   gfc_current_ns = gfc_global_ns_list;
4101   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4102     {
4103       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4104       gfc_resolve (gfc_current_ns);
4105       gfc_current_ns->derived_types = gfc_derived_types;
4106       gfc_derived_types = NULL;
4107     }
4108 }
4109
4110
4111 static void
4112 clean_up_modules (gfc_gsymbol *gsym)
4113 {
4114   if (gsym == NULL)
4115     return;
4116
4117   clean_up_modules (gsym->left);
4118   clean_up_modules (gsym->right);
4119
4120   if (gsym->type != GSYM_MODULE || !gsym->ns)
4121     return;
4122
4123   gfc_current_ns = gsym->ns;
4124   gfc_derived_types = gfc_current_ns->derived_types;
4125   gfc_done_2 ();
4126   gsym->ns = NULL;
4127   return;
4128 }
4129
4130
4131 /* Translate all the program units when whole file scope option
4132    is active. This could be in a different order to resolution if
4133    there are forward references in the file.  */
4134 static void
4135 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4136 {
4137   int errors;
4138
4139   gfc_current_ns = gfc_global_ns_list;
4140   gfc_get_errors (NULL, &errors);
4141
4142   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4143     {
4144       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4145       gfc_derived_types = gfc_current_ns->derived_types;
4146       gfc_generate_code (gfc_current_ns);
4147       gfc_current_ns->translated = 1;
4148     }
4149
4150   /* Clean up all the namespaces after translation.  */
4151   gfc_current_ns = gfc_global_ns_list;
4152   for (;gfc_current_ns;)
4153     {
4154       gfc_namespace *ns = gfc_current_ns->sibling;
4155       gfc_derived_types = gfc_current_ns->derived_types;
4156       gfc_done_2 ();
4157       gfc_current_ns = ns;
4158     }
4159
4160   clean_up_modules (gfc_gsym_root);
4161 }
4162
4163
4164 /* Top level parser.  */
4165
4166 gfc_try
4167 gfc_parse_file (void)
4168 {
4169   int seen_program, errors_before, errors;
4170   gfc_state_data top, s;
4171   gfc_statement st;
4172   locus prog_locus;
4173   gfc_namespace *next;
4174
4175   gfc_start_source_files ();
4176
4177   top.state = COMP_NONE;
4178   top.sym = NULL;
4179   top.previous = NULL;
4180   top.head = top.tail = NULL;
4181   top.do_variable = NULL;
4182
4183   gfc_state_stack = &top;
4184
4185   gfc_clear_new_st ();
4186
4187   gfc_statement_label = NULL;
4188
4189   if (setjmp (eof_buf))
4190     return FAILURE;     /* Come here on unexpected EOF */
4191
4192   /* Prepare the global namespace that will contain the
4193      program units.  */
4194   gfc_global_ns_list = next = NULL;
4195
4196   seen_program = 0;
4197
4198   /* Exit early for empty files.  */
4199   if (gfc_at_eof ())
4200     goto done;
4201
4202 loop:
4203   gfc_init_2 ();
4204   st = next_statement ();
4205   switch (st)
4206     {
4207     case ST_NONE:
4208       gfc_done_2 ();
4209       goto done;
4210
4211     case ST_PROGRAM:
4212       if (seen_program)
4213         goto duplicate_main;
4214       seen_program = 1;
4215       prog_locus = gfc_current_locus;
4216
4217       push_state (&s, COMP_PROGRAM, gfc_new_block);
4218       main_program_symbol(gfc_current_ns, gfc_new_block->name);
4219       accept_statement (st);
4220       add_global_program ();
4221       parse_progunit (ST_NONE);
4222       if (gfc_option.flag_whole_file)
4223         goto prog_units;
4224       break;
4225
4226     case ST_SUBROUTINE:
4227       add_global_procedure (1);
4228       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4229       accept_statement (st);
4230       parse_progunit (ST_NONE);
4231       if (gfc_option.flag_whole_file)
4232         goto prog_units;
4233       break;
4234
4235     case ST_FUNCTION:
4236       add_global_procedure (0);
4237       push_state (&s, COMP_FUNCTION, gfc_new_block);
4238       accept_statement (st);
4239       parse_progunit (ST_NONE);
4240       if (gfc_option.flag_whole_file)
4241         goto prog_units;
4242       break;
4243
4244     case ST_BLOCK_DATA:
4245       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4246       accept_statement (st);
4247       parse_block_data ();
4248       break;
4249
4250     case ST_MODULE:
4251       push_state (&s, COMP_MODULE, gfc_new_block);
4252       accept_statement (st);
4253
4254       gfc_get_errors (NULL, &errors_before);
4255       parse_module ();
4256       break;
4257
4258     /* Anything else starts a nameless main program block.  */
4259     default:
4260       if (seen_program)
4261         goto duplicate_main;
4262       seen_program = 1;
4263       prog_locus = gfc_current_locus;
4264
4265       push_state (&s, COMP_PROGRAM, gfc_new_block);
4266       main_program_symbol (gfc_current_ns, "MAIN__");
4267       parse_progunit (st);
4268       if (gfc_option.flag_whole_file)
4269         goto prog_units;
4270       break;
4271     }
4272
4273   /* Handle the non-program units.  */
4274   gfc_current_ns->code = s.head;
4275
4276   gfc_resolve (gfc_current_ns);
4277
4278   /* Dump the parse tree if requested.  */
4279   if (gfc_option.dump_parse_tree)
4280     gfc_dump_parse_tree (gfc_current_ns, stdout);
4281
4282   gfc_get_errors (NULL, &errors);
4283   if (s.state == COMP_MODULE)
4284     {
4285       gfc_dump_module (s.sym->name, errors_before == errors);
4286       if (errors == 0)
4287         gfc_generate_module_code (gfc_current_ns);
4288       pop_state ();
4289       if (!gfc_option.flag_whole_file)
4290         gfc_done_2 ();
4291       else
4292         {
4293           gfc_current_ns->derived_types = gfc_derived_types;
4294           gfc_derived_types = NULL;
4295           gfc_current_ns = NULL;
4296         }
4297     }
4298   else
4299     {
4300       if (errors == 0)
4301         gfc_generate_code (gfc_current_ns);
4302       pop_state ();
4303       gfc_done_2 ();
4304     }
4305
4306   goto loop;
4307
4308 prog_units:
4309   /* The main program and non-contained procedures are put
4310      in the global namespace list, so that they can be processed
4311      later and all their interfaces resolved.  */
4312   gfc_current_ns->code = s.head;
4313   if (next)
4314     next->sibling = gfc_current_ns;
4315   else
4316     gfc_global_ns_list = gfc_current_ns;
4317
4318   next = gfc_current_ns;
4319
4320   pop_state ();
4321   goto loop;
4322
4323   done:
4324
4325   if (!gfc_option.flag_whole_file)
4326     goto termination;
4327
4328   /* Do the resolution.  */
4329   resolve_all_program_units (gfc_global_ns_list);
4330
4331   /* Do the parse tree dump.  */
4332   gfc_current_ns
4333         = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
4334
4335   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4336     {
4337       gfc_dump_parse_tree (gfc_current_ns, stdout);
4338       fputs ("------------------------------------------\n\n", stdout);
4339     }
4340
4341   /* Do the translation.  */
4342   translate_all_program_units (gfc_global_ns_list);
4343
4344 termination:
4345
4346   gfc_end_source_files ();
4347   return SUCCESS;
4348
4349 duplicate_main:
4350   /* If we see a duplicate main program, shut down.  If the second
4351      instance is an implied main program, i.e. data decls or executable
4352      statements, we're in for lots of errors.  */
4353   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
4354   reject_statement ();
4355   gfc_done_2 ();
4356   return SUCCESS;
4357 }