gcc/fortran/parse.c

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