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