gcc/fortran/parse.c

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