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 gfc_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, i.e., 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 gfc_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_new_block->attr.pointer)
1996         {
1997           gfc_new_block->attr.pointer = 0;
1998           gfc_new_block->attr.proc_pointer = 1;
1999         }
2000       if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2001                                   gfc_new_block->formal, NULL) == FAILURE)
2002         {
2003           reject_statement ();
2004           gfc_free_namespace (gfc_current_ns);
2005           goto loop;
2006         }
2007       if (current_interface.type != INTERFACE_ABSTRACT &&
2008          !gfc_new_block->attr.dummy &&
2009          gfc_add_external (&gfc_new_block->attr, &gfc_current_locus) == FAILURE)
2010         {
2011           reject_statement ();
2012           gfc_free_namespace (gfc_current_ns);
2013           goto loop;
2014         }
2015       break;
2016
2017     case ST_PROCEDURE:
2018     case ST_MODULE_PROC:        /* The module procedure matcher makes
2019                                    sure the context is correct.  */
2020       accept_statement (st);
2021       gfc_free_namespace (gfc_current_ns);
2022       goto loop;
2023
2024     case ST_END_INTERFACE:
2025       gfc_free_namespace (gfc_current_ns);
2026       gfc_current_ns = current_interface.ns;
2027       goto done;
2028
2029     default:
2030       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2031                  gfc_ascii_statement (st));
2032       reject_statement ();
2033       gfc_free_namespace (gfc_current_ns);
2034       goto loop;
2035     }
2036
2037
2038   /* Make sure that a generic interface has only subroutines or
2039      functions and that the generic name has the right attribute.  */
2040   if (current_interface.type == INTERFACE_GENERIC)
2041     {
2042       if (current_state == COMP_NONE)
2043         {
2044           if (new_state == COMP_FUNCTION)
2045             gfc_add_function (&sym->attr, sym->name, NULL);
2046           else if (new_state == COMP_SUBROUTINE)
2047             gfc_add_subroutine (&sym->attr, sym->name, NULL);
2048
2049           current_state = new_state;
2050         }
2051       else
2052         {
2053           if (new_state != current_state)
2054             {
2055               if (new_state == COMP_SUBROUTINE)
2056                 gfc_error ("SUBROUTINE at %C does not belong in a "
2057                            "generic function interface");
2058
2059               if (new_state == COMP_FUNCTION)
2060                 gfc_error ("FUNCTION at %C does not belong in a "
2061                            "generic subroutine interface");
2062             }
2063         }
2064     }
2065
2066   if (current_interface.type == INTERFACE_ABSTRACT)
2067     {
2068       gfc_new_block->attr.abstract = 1;
2069       if (gfc_is_intrinsic_typename (gfc_new_block->name))
2070         gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2071                    "cannot be the same as an intrinsic type",
2072                    gfc_new_block->name);
2073     }
2074
2075   push_state (&s2, new_state, gfc_new_block);
2076   accept_statement (st);
2077   prog_unit = gfc_new_block;
2078   prog_unit->formal_ns = gfc_current_ns;
2079   proc_locus = gfc_current_locus;
2080
2081 decl:
2082   /* Read data declaration statements.  */
2083   st = parse_spec (ST_NONE);
2084
2085   /* Since the interface block does not permit an IMPLICIT statement,
2086      the default type for the function or the result must be taken
2087      from the formal namespace.  */
2088   if (new_state == COMP_FUNCTION)
2089     {
2090         if (prog_unit->result == prog_unit
2091               && prog_unit->ts.type == BT_UNKNOWN)
2092           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2093         else if (prog_unit->result != prog_unit
2094                    && prog_unit->result->ts.type == BT_UNKNOWN)
2095           gfc_set_default_type (prog_unit->result, 1,
2096                                 prog_unit->formal_ns);
2097     }
2098
2099   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2100     {
2101       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2102                  gfc_ascii_statement (st));
2103       reject_statement ();
2104       goto decl;
2105     }
2106
2107   current_interface = save;
2108   gfc_add_interface (prog_unit);
2109   pop_state ();
2110
2111   if (current_interface.ns
2112         && current_interface.ns->proc_name
2113         && strcmp (current_interface.ns->proc_name->name,
2114                    prog_unit->name) == 0)
2115     gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2116                "enclosing procedure", prog_unit->name, &proc_locus);
2117
2118   goto loop;
2119
2120 done:
2121   pop_state ();
2122 }
2123
2124
2125 /* Associate function characteristics by going back to the function
2126    declaration and rematching the prefix.  */
2127
2128 static match
2129 match_deferred_characteristics (gfc_typespec * ts)
2130 {
2131   locus loc;
2132   match m = MATCH_ERROR;
2133   char name[GFC_MAX_SYMBOL_LEN + 1];
2134
2135   loc = gfc_current_locus;
2136
2137   gfc_current_locus = gfc_current_block ()->declared_at;
2138
2139   gfc_clear_error ();
2140   gfc_buffer_error (1);
2141   m = gfc_match_prefix (ts);
2142   gfc_buffer_error (0);
2143
2144   if (ts->type == BT_DERIVED)
2145     {
2146       ts->kind = 0;
2147
2148       if (!ts->derived || !ts->derived->components)
2149         m = MATCH_ERROR;
2150     }
2151
2152   /* Only permit one go at the characteristic association.  */
2153   if (ts->kind == -1)
2154     ts->kind = 0;
2155
2156   /* Set the function locus correctly.  If we have not found the
2157      function name, there is an error.  */
2158   gfc_match ("function% %n", name);
2159   if (m == MATCH_YES && strcmp (name, gfc_current_block ()->name) == 0)
2160     {
2161       gfc_current_block ()->declared_at = gfc_current_locus;
2162       gfc_commit_symbols ();
2163     }
2164   else
2165     gfc_error_check ();
2166
2167   gfc_current_locus =loc;
2168   return m;
2169 }
2170
2171
2172 /* Parse a set of specification statements.  Returns the statement
2173    that doesn't fit.  */
2174
2175 static gfc_statement
2176 parse_spec (gfc_statement st)
2177 {
2178   st_state ss;
2179   bool bad_characteristic = false;
2180   gfc_typespec *ts;
2181
2182   verify_st_order (&ss, ST_NONE);
2183   if (st == ST_NONE)
2184     st = next_statement ();
2185
2186 loop:
2187   switch (st)
2188     {
2189     case ST_NONE:
2190       unexpected_eof ();
2191
2192     case ST_FORMAT:
2193     case ST_ENTRY:
2194     case ST_DATA:       /* Not allowed in interfaces */
2195       if (gfc_current_state () == COMP_INTERFACE)
2196         break;
2197
2198       /* Fall through */
2199
2200     case ST_USE:
2201     case ST_IMPORT:
2202     case ST_IMPLICIT_NONE:
2203     case ST_IMPLICIT:
2204     case ST_PARAMETER:
2205     case ST_PUBLIC:
2206     case ST_PRIVATE:
2207     case ST_DERIVED_DECL:
2208     case_decl:
2209       if (verify_st_order (&ss, st) == FAILURE)
2210         {
2211           reject_statement ();
2212           st = next_statement ();
2213           goto loop;
2214         }
2215
2216       switch (st)
2217         {
2218         case ST_INTERFACE:
2219           parse_interface ();
2220           break;
2221
2222         case ST_DERIVED_DECL:
2223           parse_derived ();
2224           break;
2225
2226         case ST_PUBLIC:
2227         case ST_PRIVATE:
2228           if (gfc_current_state () != COMP_MODULE)
2229             {
2230               gfc_error ("%s statement must appear in a MODULE",
2231                          gfc_ascii_statement (st));
2232               break;
2233             }
2234
2235           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2236             {
2237               gfc_error ("%s statement at %C follows another accessibility "
2238                          "specification", gfc_ascii_statement (st));
2239               break;
2240             }
2241
2242           gfc_current_ns->default_access = (st == ST_PUBLIC)
2243             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2244
2245           break;
2246
2247         case ST_STATEMENT_FUNCTION:
2248           if (gfc_current_state () == COMP_MODULE)
2249             {
2250               unexpected_statement (st);
2251               break;
2252             }
2253
2254         default:
2255           break;
2256         }
2257
2258       accept_statement (st);
2259       st = next_statement ();
2260       goto loop;
2261
2262     case ST_ENUM:
2263       accept_statement (st);
2264       parse_enum();
2265       st = next_statement ();
2266       goto loop;
2267
2268     case ST_GET_FCN_CHARACTERISTICS:
2269       /* This statement triggers the association of a function's result
2270          characteristics.  */
2271       ts = &gfc_current_block ()->result->ts;
2272       if (match_deferred_characteristics (ts) != MATCH_YES)
2273         bad_characteristic = true;
2274
2275       st = next_statement ();
2276       goto loop;
2277
2278     default:
2279       break;
2280     }
2281
2282   /* If match_deferred_characteristics failed, then there is an error. */
2283   if (bad_characteristic)
2284     {
2285       ts = &gfc_current_block ()->result->ts;
2286       if (ts->type != BT_DERIVED)
2287         gfc_error ("Bad kind expression for function '%s' at %L",
2288                    gfc_current_block ()->name,
2289                    &gfc_current_block ()->declared_at);
2290       else
2291         gfc_error ("The type for function '%s' at %L is not accessible",
2292                    gfc_current_block ()->name,
2293                    &gfc_current_block ()->declared_at);
2294
2295       gfc_current_block ()->ts.kind = 0;
2296       /* Keep the derived type; if it's bad, it will be discovered later.  */
2297       if (!(ts->type == BT_DERIVED && ts->derived))
2298         ts->type = BT_UNKNOWN;
2299     }
2300
2301   return st;
2302 }
2303
2304
2305 /* Parse a WHERE block, (not a simple WHERE statement).  */
2306
2307 static void
2308 parse_where_block (void)
2309 {
2310   int seen_empty_else;
2311   gfc_code *top, *d;
2312   gfc_state_data s;
2313   gfc_statement st;
2314
2315   accept_statement (ST_WHERE_BLOCK);
2316   top = gfc_state_stack->tail;
2317
2318   push_state (&s, COMP_WHERE, gfc_new_block);
2319
2320   d = add_statement ();
2321   d->expr = top->expr;
2322   d->op = EXEC_WHERE;
2323
2324   top->expr = NULL;
2325   top->block = d;
2326
2327   seen_empty_else = 0;
2328
2329   do
2330     {
2331       st = next_statement ();
2332       switch (st)
2333         {
2334         case ST_NONE:
2335           unexpected_eof ();
2336
2337         case ST_WHERE_BLOCK:
2338           parse_where_block ();
2339           break;
2340
2341         case ST_ASSIGNMENT:
2342         case ST_WHERE:
2343           accept_statement (st);
2344           break;
2345
2346         case ST_ELSEWHERE:
2347           if (seen_empty_else)
2348             {
2349               gfc_error ("ELSEWHERE statement at %C follows previous "
2350                          "unmasked ELSEWHERE");
2351               break;
2352             }
2353
2354           if (new_st.expr == NULL)
2355             seen_empty_else = 1;
2356
2357           d = new_level (gfc_state_stack->head);
2358           d->op = EXEC_WHERE;
2359           d->expr = new_st.expr;
2360
2361           accept_statement (st);
2362
2363           break;
2364
2365         case ST_END_WHERE:
2366           accept_statement (st);
2367           break;
2368
2369         default:
2370           gfc_error ("Unexpected %s statement in WHERE block at %C",
2371                      gfc_ascii_statement (st));
2372           reject_statement ();
2373           break;
2374         }
2375     }
2376   while (st != ST_END_WHERE);
2377
2378   pop_state ();
2379 }
2380
2381
2382 /* Parse a FORALL block (not a simple FORALL statement).  */
2383
2384 static void
2385 parse_forall_block (void)
2386 {
2387   gfc_code *top, *d;
2388   gfc_state_data s;
2389   gfc_statement st;
2390
2391   accept_statement (ST_FORALL_BLOCK);
2392   top = gfc_state_stack->tail;
2393
2394   push_state (&s, COMP_FORALL, gfc_new_block);
2395
2396   d = add_statement ();
2397   d->op = EXEC_FORALL;
2398   top->block = d;
2399
2400   do
2401     {
2402       st = next_statement ();
2403       switch (st)
2404         {
2405
2406         case ST_ASSIGNMENT:
2407         case ST_POINTER_ASSIGNMENT:
2408         case ST_WHERE:
2409         case ST_FORALL:
2410           accept_statement (st);
2411           break;
2412
2413         case ST_WHERE_BLOCK:
2414           parse_where_block ();
2415           break;
2416
2417         case ST_FORALL_BLOCK:
2418           parse_forall_block ();
2419           break;
2420
2421         case ST_END_FORALL:
2422           accept_statement (st);
2423           break;
2424
2425         case ST_NONE:
2426           unexpected_eof ();
2427
2428         default:
2429           gfc_error ("Unexpected %s statement in FORALL block at %C",
2430                      gfc_ascii_statement (st));
2431
2432           reject_statement ();
2433           break;
2434         }
2435     }
2436   while (st != ST_END_FORALL);
2437
2438   pop_state ();
2439 }
2440
2441
2442 static gfc_statement parse_executable (gfc_statement);
2443
2444 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2445
2446 static void
2447 parse_if_block (void)
2448 {
2449   gfc_code *top, *d;
2450   gfc_statement st;
2451   locus else_locus;
2452   gfc_state_data s;
2453   int seen_else;
2454
2455   seen_else = 0;
2456   accept_statement (ST_IF_BLOCK);
2457
2458   top = gfc_state_stack->tail;
2459   push_state (&s, COMP_IF, gfc_new_block);
2460
2461   new_st.op = EXEC_IF;
2462   d = add_statement ();
2463
2464   d->expr = top->expr;
2465   top->expr = NULL;
2466   top->block = d;
2467
2468   do
2469     {
2470       st = parse_executable (ST_NONE);
2471
2472       switch (st)
2473         {
2474         case ST_NONE:
2475           unexpected_eof ();
2476
2477         case ST_ELSEIF:
2478           if (seen_else)
2479             {
2480               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2481                          "statement at %L", &else_locus);
2482
2483               reject_statement ();
2484               break;
2485             }
2486
2487           d = new_level (gfc_state_stack->head);
2488           d->op = EXEC_IF;
2489           d->expr = new_st.expr;
2490
2491           accept_statement (st);
2492
2493           break;
2494
2495         case ST_ELSE:
2496           if (seen_else)
2497             {
2498               gfc_error ("Duplicate ELSE statements at %L and %C",
2499                          &else_locus);
2500               reject_statement ();
2501               break;
2502             }
2503
2504           seen_else = 1;
2505           else_locus = gfc_current_locus;
2506
2507           d = new_level (gfc_state_stack->head);
2508           d->op = EXEC_IF;
2509
2510           accept_statement (st);
2511
2512           break;
2513
2514         case ST_ENDIF:
2515           break;
2516
2517         default:
2518           unexpected_statement (st);
2519           break;
2520         }
2521     }
2522   while (st != ST_ENDIF);
2523
2524   pop_state ();
2525   accept_statement (st);
2526 }
2527
2528
2529 /* Parse a SELECT block.  */
2530
2531 static void
2532 parse_select_block (void)
2533 {
2534   gfc_statement st;
2535   gfc_code *cp;
2536   gfc_state_data s;
2537
2538   accept_statement (ST_SELECT_CASE);
2539
2540   cp = gfc_state_stack->tail;
2541   push_state (&s, COMP_SELECT, gfc_new_block);
2542
2543   /* Make sure that the next statement is a CASE or END SELECT.  */
2544   for (;;)
2545     {
2546       st = next_statement ();
2547       if (st == ST_NONE)
2548         unexpected_eof ();
2549       if (st == ST_END_SELECT)
2550         {
2551           /* Empty SELECT CASE is OK.  */
2552           accept_statement (st);
2553           pop_state ();
2554           return;
2555         }
2556       if (st == ST_CASE)
2557         break;
2558
2559       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2560                  "CASE at %C");
2561
2562       reject_statement ();
2563     }
2564
2565   /* At this point, we're got a nonempty select block.  */
2566   cp = new_level (cp);
2567   *cp = new_st;
2568
2569   accept_statement (st);
2570
2571   do
2572     {
2573       st = parse_executable (ST_NONE);
2574       switch (st)
2575         {
2576         case ST_NONE:
2577           unexpected_eof ();
2578
2579         case ST_CASE:
2580           cp = new_level (gfc_state_stack->head);
2581           *cp = new_st;
2582           gfc_clear_new_st ();
2583
2584           accept_statement (st);
2585           /* Fall through */
2586
2587         case ST_END_SELECT:
2588           break;
2589
2590         /* Can't have an executable statement because of
2591            parse_executable().  */
2592         default:
2593           unexpected_statement (st);
2594           break;
2595         }
2596     }
2597   while (st != ST_END_SELECT);
2598
2599   pop_state ();
2600   accept_statement (st);
2601 }
2602
2603
2604 /* Given a symbol, make sure it is not an iteration variable for a DO
2605    statement.  This subroutine is called when the symbol is seen in a
2606    context that causes it to become redefined.  If the symbol is an
2607    iterator, we generate an error message and return nonzero.  */
2608
2609 int
2610 gfc_check_do_variable (gfc_symtree *st)
2611 {
2612   gfc_state_data *s;
2613
2614   for (s=gfc_state_stack; s; s = s->previous)
2615     if (s->do_variable == st)
2616       {
2617         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2618                       "loop beginning at %L", st->name, &s->head->loc);
2619         return 1;
2620       }
2621
2622   return 0;
2623 }
2624
2625
2626 /* Checks to see if the current statement label closes an enddo.
2627    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2628    an error) if it incorrectly closes an ENDDO.  */
2629
2630 static int
2631 check_do_closure (void)
2632 {
2633   gfc_state_data *p;
2634
2635   if (gfc_statement_label == NULL)
2636     return 0;
2637
2638   for (p = gfc_state_stack; p; p = p->previous)
2639     if (p->state == COMP_DO)
2640       break;
2641
2642   if (p == NULL)
2643     return 0;           /* No loops to close */
2644
2645   if (p->ext.end_do_label == gfc_statement_label)
2646     {
2647
2648       if (p == gfc_state_stack)
2649         return 1;
2650
2651       gfc_error ("End of nonblock DO statement at %C is within another block");
2652       return 2;
2653     }
2654
2655   /* At this point, the label doesn't terminate the innermost loop.
2656      Make sure it doesn't terminate another one.  */
2657   for (; p; p = p->previous)
2658     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2659       {
2660         gfc_error ("End of nonblock DO statement at %C is interwoven "
2661                    "with another DO loop");
2662         return 2;
2663       }
2664
2665   return 0;
2666 }
2667
2668
2669 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
2670    handled inside of parse_executable(), because they aren't really
2671    loop statements.  */
2672
2673 static void
2674 parse_do_block (void)
2675 {
2676   gfc_statement st;
2677   gfc_code *top;
2678   gfc_state_data s;
2679   gfc_symtree *stree;
2680
2681   s.ext.end_do_label = new_st.label;
2682
2683   if (new_st.ext.iterator != NULL)
2684     stree = new_st.ext.iterator->var->symtree;
2685   else
2686     stree = NULL;
2687
2688   accept_statement (ST_DO);
2689
2690   top = gfc_state_stack->tail;
2691   push_state (&s, COMP_DO, gfc_new_block);
2692
2693   s.do_variable = stree;
2694
2695   top->block = new_level (top);
2696   top->block->op = EXEC_DO;
2697
2698 loop:
2699   st = parse_executable (ST_NONE);
2700
2701   switch (st)
2702     {
2703     case ST_NONE:
2704       unexpected_eof ();
2705
2706     case ST_ENDDO:
2707       if (s.ext.end_do_label != NULL
2708           && s.ext.end_do_label != gfc_statement_label)
2709         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2710                        "DO label");
2711
2712       if (gfc_statement_label != NULL)
2713         {
2714           new_st.op = EXEC_NOP;
2715           add_statement ();
2716         }
2717       break;
2718
2719     case ST_IMPLIED_ENDDO:
2720      /* If the do-stmt of this DO construct has a do-construct-name,
2721         the corresponding end-do must be an end-do-stmt (with a matching
2722         name, but in that case we must have seen ST_ENDDO first).
2723         We only complain about this in pedantic mode.  */
2724      if (gfc_current_block () != NULL)
2725         gfc_error_now ("named block DO at %L requires matching ENDDO name",
2726                        &gfc_current_block()->declared_at);
2727
2728       break;
2729
2730     default:
2731       unexpected_statement (st);
2732       goto loop;
2733     }
2734
2735   pop_state ();
2736   accept_statement (st);
2737 }
2738
2739
2740 /* Parse the statements of OpenMP do/parallel do.  */
2741
2742 static gfc_statement
2743 parse_omp_do (gfc_statement omp_st)
2744 {
2745   gfc_statement st;
2746   gfc_code *cp, *np;
2747   gfc_state_data s;
2748
2749   accept_statement (omp_st);
2750
2751   cp = gfc_state_stack->tail;
2752   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2753   np = new_level (cp);
2754   np->op = cp->op;
2755   np->block = NULL;
2756
2757   for (;;)
2758     {
2759       st = next_statement ();
2760       if (st == ST_NONE)
2761         unexpected_eof ();
2762       else if (st == ST_DO)
2763         break;
2764       else
2765         unexpected_statement (st);
2766     }
2767
2768   parse_do_block ();
2769   if (gfc_statement_label != NULL
2770       && gfc_state_stack->previous != NULL
2771       && gfc_state_stack->previous->state == COMP_DO
2772       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2773     {
2774       /* In
2775          DO 100 I=1,10
2776            !$OMP DO
2777              DO J=1,10
2778              ...
2779              100 CONTINUE
2780          there should be no !$OMP END DO.  */
2781       pop_state ();
2782       return ST_IMPLIED_ENDDO;
2783     }
2784
2785   check_do_closure ();
2786   pop_state ();
2787
2788   st = next_statement ();
2789   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2790     {
2791       if (new_st.op == EXEC_OMP_END_NOWAIT)
2792         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2793       else
2794         gcc_assert (new_st.op == EXEC_NOP);
2795       gfc_clear_new_st ();
2796       gfc_commit_symbols ();
2797       gfc_warning_check ();
2798       st = next_statement ();
2799     }
2800   return st;
2801 }
2802
2803
2804 /* Parse the statements of OpenMP atomic directive.  */
2805
2806 static void
2807 parse_omp_atomic (void)
2808 {
2809   gfc_statement st;
2810   gfc_code *cp, *np;
2811   gfc_state_data s;
2812
2813   accept_statement (ST_OMP_ATOMIC);
2814
2815   cp = gfc_state_stack->tail;
2816   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2817   np = new_level (cp);
2818   np->op = cp->op;
2819   np->block = NULL;
2820
2821   for (;;)
2822     {
2823       st = next_statement ();
2824       if (st == ST_NONE)
2825         unexpected_eof ();
2826       else if (st == ST_ASSIGNMENT)
2827         break;
2828       else
2829         unexpected_statement (st);
2830     }
2831
2832   accept_statement (st);
2833
2834   pop_state ();
2835 }
2836
2837
2838 /* Parse the statements of an OpenMP structured block.  */
2839
2840 static void
2841 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2842 {
2843   gfc_statement st, omp_end_st;
2844   gfc_code *cp, *np;
2845   gfc_state_data s;
2846
2847   accept_statement (omp_st);
2848
2849   cp = gfc_state_stack->tail;
2850   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2851   np = new_level (cp);
2852   np->op = cp->op;
2853   np->block = NULL;
2854
2855   switch (omp_st)
2856     {
2857     case ST_OMP_PARALLEL:
2858       omp_end_st = ST_OMP_END_PARALLEL;
2859       break;
2860     case ST_OMP_PARALLEL_SECTIONS:
2861       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2862       break;
2863     case ST_OMP_SECTIONS:
2864       omp_end_st = ST_OMP_END_SECTIONS;
2865       break;
2866     case ST_OMP_ORDERED:
2867       omp_end_st = ST_OMP_END_ORDERED;
2868       break;
2869     case ST_OMP_CRITICAL:
2870       omp_end_st = ST_OMP_END_CRITICAL;
2871       break;
2872     case ST_OMP_MASTER:
2873       omp_end_st = ST_OMP_END_MASTER;
2874       break;
2875     case ST_OMP_SINGLE:
2876       omp_end_st = ST_OMP_END_SINGLE;
2877       break;
2878     case ST_OMP_TASK:
2879       omp_end_st = ST_OMP_END_TASK;
2880       break;
2881     case ST_OMP_WORKSHARE:
2882       omp_end_st = ST_OMP_END_WORKSHARE;
2883       break;
2884     case ST_OMP_PARALLEL_WORKSHARE:
2885       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2886       break;
2887     default:
2888       gcc_unreachable ();
2889     }
2890
2891   do
2892     {
2893       if (workshare_stmts_only)
2894         {
2895           /* Inside of !$omp workshare, only
2896              scalar assignments
2897              array assignments
2898              where statements and constructs
2899              forall statements and constructs
2900              !$omp atomic
2901              !$omp critical
2902              !$omp parallel
2903              are allowed.  For !$omp critical these
2904              restrictions apply recursively.  */
2905           bool cycle = true;
2906
2907           st = next_statement ();
2908           for (;;)
2909             {
2910               switch (st)
2911                 {
2912                 case ST_NONE:
2913                   unexpected_eof ();
2914
2915                 case ST_ASSIGNMENT:
2916                 case ST_WHERE:
2917                 case ST_FORALL:
2918                   accept_statement (st);
2919                   break;
2920
2921                 case ST_WHERE_BLOCK:
2922                   parse_where_block ();
2923                   break;
2924
2925                 case ST_FORALL_BLOCK:
2926                   parse_forall_block ();
2927                   break;
2928
2929                 case ST_OMP_PARALLEL:
2930                 case ST_OMP_PARALLEL_SECTIONS:
2931                   parse_omp_structured_block (st, false);
2932                   break;
2933
2934                 case ST_OMP_PARALLEL_WORKSHARE:
2935                 case ST_OMP_CRITICAL:
2936                   parse_omp_structured_block (st, true);
2937                   break;
2938
2939                 case ST_OMP_PARALLEL_DO:
2940                   st = parse_omp_do (st);
2941                   continue;
2942
2943                 case ST_OMP_ATOMIC:
2944                   parse_omp_atomic ();
2945                   break;
2946
2947                 default:
2948                   cycle = false;
2949                   break;
2950                 }
2951
2952               if (!cycle)
2953                 break;
2954
2955               st = next_statement ();
2956             }
2957         }
2958       else
2959         st = parse_executable (ST_NONE);
2960       if (st == ST_NONE)
2961         unexpected_eof ();
2962       else if (st == ST_OMP_SECTION
2963                && (omp_st == ST_OMP_SECTIONS
2964                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
2965         {
2966           np = new_level (np);
2967           np->op = cp->op;
2968           np->block = NULL;
2969         }
2970       else if (st != omp_end_st)
2971         unexpected_statement (st);
2972     }
2973   while (st != omp_end_st);
2974
2975   switch (new_st.op)
2976     {
2977     case EXEC_OMP_END_NOWAIT:
2978       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2979       break;
2980     case EXEC_OMP_CRITICAL:
2981       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2982           || (new_st.ext.omp_name != NULL
2983               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2984         gfc_error ("Name after !$omp critical and !$omp end critical does "
2985                    "not match at %C");
2986       gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
2987       break;
2988     case EXEC_OMP_END_SINGLE:
2989       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2990         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2991       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2992       gfc_free_omp_clauses (new_st.ext.omp_clauses);
2993       break;
2994     case EXEC_NOP:
2995       break;
2996     default:
2997       gcc_unreachable ();
2998     }
2999
3000   gfc_clear_new_st ();
3001   gfc_commit_symbols ();
3002   gfc_warning_check ();
3003   pop_state ();
3004 }
3005
3006
3007 /* Accept a series of executable statements.  We return the first
3008    statement that doesn't fit to the caller.  Any block statements are
3009    passed on to the correct handler, which usually passes the buck
3010    right back here.  */
3011
3012 static gfc_statement
3013 parse_executable (gfc_statement st)
3014 {
3015   int close_flag;
3016
3017   if (st == ST_NONE)
3018     st = next_statement ();
3019
3020   for (;;)
3021     {
3022       close_flag = check_do_closure ();
3023       if (close_flag)
3024         switch (st)
3025           {
3026           case ST_GOTO:
3027           case ST_END_PROGRAM:
3028           case ST_RETURN:
3029           case ST_EXIT:
3030           case ST_END_FUNCTION:
3031           case ST_CYCLE:
3032           case ST_PAUSE:
3033           case ST_STOP:
3034           case ST_END_SUBROUTINE:
3035
3036           case ST_DO:
3037           case ST_FORALL:
3038           case ST_WHERE:
3039           case ST_SELECT_CASE:
3040             gfc_error ("%s statement at %C cannot terminate a non-block "
3041                        "DO loop", gfc_ascii_statement (st));
3042             break;
3043
3044           default:
3045             break;
3046           }
3047
3048       switch (st)
3049         {
3050         case ST_NONE:
3051           unexpected_eof ();
3052
3053         case ST_FORMAT:
3054         case ST_DATA:
3055         case ST_ENTRY:
3056         case_executable:
3057           accept_statement (st);
3058           if (close_flag == 1)
3059             return ST_IMPLIED_ENDDO;
3060           break;
3061
3062         case ST_IF_BLOCK:
3063           parse_if_block ();
3064           break;
3065
3066         case ST_SELECT_CASE:
3067           parse_select_block ();
3068           break;
3069
3070         case ST_DO:
3071           parse_do_block ();
3072           if (check_do_closure () == 1)
3073             return ST_IMPLIED_ENDDO;
3074           break;
3075
3076         case ST_WHERE_BLOCK:
3077           parse_where_block ();
3078           break;
3079
3080         case ST_FORALL_BLOCK:
3081           parse_forall_block ();
3082           break;
3083
3084         case ST_OMP_PARALLEL:
3085         case ST_OMP_PARALLEL_SECTIONS:
3086         case ST_OMP_SECTIONS:
3087         case ST_OMP_ORDERED:
3088         case ST_OMP_CRITICAL:
3089         case ST_OMP_MASTER:
3090         case ST_OMP_SINGLE:
3091         case ST_OMP_TASK:
3092           parse_omp_structured_block (st, false);
3093           break;
3094
3095         case ST_OMP_WORKSHARE:
3096         case ST_OMP_PARALLEL_WORKSHARE:
3097           parse_omp_structured_block (st, true);
3098           break;
3099
3100         case ST_OMP_DO:
3101         case ST_OMP_PARALLEL_DO:
3102           st = parse_omp_do (st);
3103           if (st == ST_IMPLIED_ENDDO)
3104             return st;
3105           continue;
3106
3107         case ST_OMP_ATOMIC:
3108           parse_omp_atomic ();
3109           break;
3110
3111         default:
3112           return st;
3113         }
3114
3115       st = next_statement ();
3116     }
3117 }
3118
3119
3120 /* Parse a series of contained program units.  */
3121
3122 static void parse_progunit (gfc_statement);
3123
3124
3125 /* Fix the symbols for sibling functions.  These are incorrectly added to
3126    the child namespace as the parser didn't know about this procedure.  */
3127
3128 static void
3129 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3130 {
3131   gfc_namespace *ns;
3132   gfc_symtree *st;
3133   gfc_symbol *old_sym;
3134
3135   sym->attr.referenced = 1;
3136   for (ns = siblings; ns; ns = ns->sibling)
3137     {
3138       gfc_find_sym_tree (sym->name, ns, 0, &st);
3139
3140       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3141         continue;
3142
3143       old_sym = st->n.sym;
3144       if (old_sym->ns == ns
3145             && !old_sym->attr.contained
3146
3147             /* By 14.6.1.3, host association should be excluded
3148                for the following.  */
3149             && !(old_sym->attr.external
3150                   || (old_sym->ts.type != BT_UNKNOWN
3151                         && !old_sym->attr.implicit_type)
3152                   || old_sym->attr.flavor == FL_PARAMETER
3153                   || old_sym->attr.in_common
3154                   || old_sym->attr.in_equivalence
3155                   || old_sym->attr.data
3156                   || old_sym->attr.dummy
3157                   || old_sym->attr.result
3158                   || old_sym->attr.dimension
3159                   || old_sym->attr.allocatable
3160                   || old_sym->attr.intrinsic
3161                   || old_sym->attr.generic
3162                   || old_sym->attr.flavor == FL_NAMELIST
3163                   || old_sym->attr.proc == PROC_ST_FUNCTION))
3164         {
3165           /* Replace it with the symbol from the parent namespace.  */
3166           st->n.sym = sym;
3167           sym->refs++;
3168
3169           /* Free the old (local) symbol.  */
3170           old_sym->refs--;
3171           if (old_sym->refs == 0)
3172             gfc_free_symbol (old_sym);
3173         }
3174
3175       /* Do the same for any contained procedures.  */
3176       gfc_fixup_sibling_symbols (sym, ns->contained);
3177     }
3178 }
3179
3180 static void
3181 parse_contained (int module)
3182 {
3183   gfc_namespace *ns, *parent_ns, *tmp;
3184   gfc_state_data s1, s2;
3185   gfc_statement st;
3186   gfc_symbol *sym;
3187   gfc_entry_list *el;
3188   int contains_statements = 0;
3189   int seen_error = 0;
3190
3191   push_state (&s1, COMP_CONTAINS, NULL);
3192   parent_ns = gfc_current_ns;
3193
3194   do
3195     {
3196       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3197
3198       gfc_current_ns->sibling = parent_ns->contained;
3199       parent_ns->contained = gfc_current_ns;
3200
3201  next:
3202       /* Process the next available statement.  We come here if we got an error
3203          and rejected the last statement.  */
3204       st = next_statement ();
3205
3206       switch (st)
3207         {
3208         case ST_NONE:
3209           unexpected_eof ();
3210
3211         case ST_FUNCTION:
3212         case ST_SUBROUTINE:
3213           contains_statements = 1;
3214           accept_statement (st);
3215
3216           push_state (&s2,
3217                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3218                       gfc_new_block);
3219
3220           /* For internal procedures, create/update the symbol in the
3221              parent namespace.  */
3222
3223           if (!module)
3224             {
3225               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3226                 gfc_error ("Contained procedure '%s' at %C is already "
3227                            "ambiguous", gfc_new_block->name);
3228               else
3229                 {
3230                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3231                                          &gfc_new_block->declared_at) ==
3232                       SUCCESS)
3233                     {
3234                       if (st == ST_FUNCTION)
3235                         gfc_add_function (&sym->attr, sym->name,
3236                                           &gfc_new_block->declared_at);
3237                       else
3238                         gfc_add_subroutine (&sym->attr, sym->name,
3239                                             &gfc_new_block->declared_at);
3240                     }
3241                 }
3242
3243               gfc_commit_symbols ();
3244             }
3245           else
3246             sym = gfc_new_block;
3247
3248           /* Mark this as a contained function, so it isn't replaced
3249              by other module functions.  */
3250           sym->attr.contained = 1;
3251           sym->attr.referenced = 1;
3252
3253           parse_progunit (ST_NONE);
3254
3255           /* Fix up any sibling functions that refer to this one.  */
3256           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3257           /* Or refer to any of its alternate entry points.  */
3258           for (el = gfc_current_ns->entries; el; el = el->next)
3259             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3260
3261           gfc_current_ns->code = s2.head;
3262           gfc_current_ns = parent_ns;
3263
3264           pop_state ();
3265           break;
3266
3267         /* These statements are associated with the end of the host unit.  */
3268         case ST_END_FUNCTION:
3269         case ST_END_MODULE:
3270         case ST_END_PROGRAM:
3271         case ST_END_SUBROUTINE:
3272           accept_statement (st);
3273           break;
3274
3275         default:
3276           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3277                      gfc_ascii_statement (st));
3278           reject_statement ();
3279           seen_error = 1;
3280           goto next;
3281           break;
3282         }
3283     }
3284   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3285          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3286
3287   /* The first namespace in the list is guaranteed to not have
3288      anything (worthwhile) in it.  */
3289   tmp = gfc_current_ns;
3290   gfc_current_ns = parent_ns;
3291   if (seen_error && tmp->refs > 1)
3292     gfc_free_namespace (tmp);
3293
3294   ns = gfc_current_ns->contained;
3295   gfc_current_ns->contained = ns->sibling;
3296   gfc_free_namespace (ns);
3297
3298   pop_state ();
3299   if (!contains_statements)
3300     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3301                     "FUNCTION or SUBROUTINE statement at %C");
3302 }
3303
3304
3305 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
3306
3307 static void
3308 parse_progunit (gfc_statement st)
3309 {
3310   gfc_state_data *p;
3311   int n;
3312
3313   st = parse_spec (st);
3314   switch (st)
3315     {
3316     case ST_NONE:
3317       unexpected_eof ();
3318
3319     case ST_CONTAINS:
3320       goto contains;
3321
3322     case_end:
3323       accept_statement (st);
3324       goto done;
3325
3326     default:
3327       break;
3328     }
3329
3330   if (gfc_current_state () == COMP_FUNCTION)
3331     gfc_check_function_type (gfc_current_ns);
3332
3333 loop:
3334   for (;;)
3335     {
3336       st = parse_executable (st);
3337
3338       switch (st)
3339         {
3340         case ST_NONE:
3341           unexpected_eof ();
3342
3343         case ST_CONTAINS:
3344           goto contains;
3345
3346         case_end:
3347           accept_statement (st);
3348           goto done;
3349
3350         default:
3351           break;
3352         }
3353
3354       unexpected_statement (st);
3355       reject_statement ();
3356       st = next_statement ();
3357     }
3358
3359 contains:
3360   n = 0;
3361
3362   for (p = gfc_state_stack; p; p = p->previous)
3363     if (p->state == COMP_CONTAINS)
3364       n++;
3365
3366   if (gfc_find_state (COMP_MODULE) == SUCCESS)
3367     n--;
3368
3369   if (n > 0)
3370     {
3371       gfc_error ("CONTAINS statement at %C is already in a contained "
3372                  "program unit");
3373       st = next_statement ();
3374       goto loop;
3375     }
3376
3377   parse_contained (0);
3378
3379 done:
3380   gfc_current_ns->code = gfc_state_stack->head;
3381 }
3382
3383
3384 /* Come here to complain about a global symbol already in use as
3385    something else.  */
3386
3387 void
3388 gfc_global_used (gfc_gsymbol *sym, locus *where)
3389 {
3390   const char *name;
3391
3392   if (where == NULL)
3393     where = &gfc_current_locus;
3394
3395   switch(sym->type)
3396     {
3397     case GSYM_PROGRAM:
3398       name = "PROGRAM";
3399       break;
3400     case GSYM_FUNCTION:
3401       name = "FUNCTION";
3402       break;
3403     case GSYM_SUBROUTINE:
3404       name = "SUBROUTINE";
3405       break;
3406     case GSYM_COMMON:
3407       name = "COMMON";
3408       break;
3409     case GSYM_BLOCK_DATA:
3410       name = "BLOCK DATA";
3411       break;
3412     case GSYM_MODULE:
3413       name = "MODULE";
3414       break;
3415     default:
3416       gfc_internal_error ("gfc_global_used(): Bad type");
3417       name = NULL;
3418     }
3419
3420   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3421               sym->name, where, name, &sym->where);
3422 }
3423
3424
3425 /* Parse a block data program unit.  */
3426
3427 static void
3428 parse_block_data (void)
3429 {
3430   gfc_statement st;
3431   static locus blank_locus;
3432   static int blank_block=0;
3433   gfc_gsymbol *s;
3434
3435   gfc_current_ns->proc_name = gfc_new_block;
3436   gfc_current_ns->is_block_data = 1;
3437
3438   if (gfc_new_block == NULL)
3439     {
3440       if (blank_block)
3441        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3442                   "prior BLOCK DATA at %L", &blank_locus);
3443       else
3444        {
3445          blank_block = 1;
3446          blank_locus = gfc_current_locus;
3447        }
3448     }
3449   else
3450     {
3451       s = gfc_get_gsymbol (gfc_new_block->name);
3452       if (s->defined
3453           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3454        gfc_global_used(s, NULL);
3455       else
3456        {
3457          s->type = GSYM_BLOCK_DATA;
3458          s->where = gfc_current_locus;
3459          s->defined = 1;
3460        }
3461     }
3462
3463   st = parse_spec (ST_NONE);
3464
3465   while (st != ST_END_BLOCK_DATA)
3466     {
3467       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3468                  gfc_ascii_statement (st));
3469       reject_statement ();
3470       st = next_statement ();
3471     }
3472 }
3473
3474
3475 /* Parse a module subprogram.  */
3476
3477 static void
3478 parse_module (void)
3479 {
3480   gfc_statement st;
3481   gfc_gsymbol *s;
3482
3483   s = gfc_get_gsymbol (gfc_new_block->name);
3484   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3485     gfc_global_used(s, NULL);
3486   else
3487     {
3488       s->type = GSYM_MODULE;
3489       s->where = gfc_current_locus;
3490       s->defined = 1;
3491     }
3492
3493   st = parse_spec (ST_NONE);
3494
3495 loop:
3496   switch (st)
3497     {
3498     case ST_NONE:
3499       unexpected_eof ();
3500
3501     case ST_CONTAINS:
3502       parse_contained (1);
3503       break;
3504
3505     case ST_END_MODULE:
3506       accept_statement (st);
3507       break;
3508
3509     default:
3510       gfc_error ("Unexpected %s statement in MODULE at %C",
3511                  gfc_ascii_statement (st));
3512
3513       reject_statement ();
3514       st = next_statement ();
3515       goto loop;
3516     }
3517 }
3518
3519
3520 /* Add a procedure name to the global symbol table.  */
3521
3522 static void
3523 add_global_procedure (int sub)
3524 {
3525   gfc_gsymbol *s;
3526
3527   s = gfc_get_gsymbol(gfc_new_block->name);
3528
3529   if (s->defined
3530       || (s->type != GSYM_UNKNOWN
3531           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3532     gfc_global_used(s, NULL);
3533   else
3534     {
3535       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3536       s->where = gfc_current_locus;
3537       s->defined = 1;
3538     }
3539 }
3540
3541
3542 /* Add a program to the global symbol table.  */
3543
3544 static void
3545 add_global_program (void)
3546 {
3547   gfc_gsymbol *s;
3548
3549   if (gfc_new_block == NULL)
3550     return;
3551   s = gfc_get_gsymbol (gfc_new_block->name);
3552
3553   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3554     gfc_global_used(s, NULL);
3555   else
3556     {
3557       s->type = GSYM_PROGRAM;
3558       s->where = gfc_current_locus;
3559       s->defined = 1;
3560     }
3561 }
3562
3563
3564 /* Top level parser.  */
3565
3566 gfc_try
3567 gfc_parse_file (void)
3568 {
3569   int seen_program, errors_before, errors;
3570   gfc_state_data top, s;
3571   gfc_statement st;
3572   locus prog_locus;
3573
3574   gfc_start_source_files ();
3575
3576   top.state = COMP_NONE;
3577   top.sym = NULL;
3578   top.previous = NULL;
3579   top.head = top.tail = NULL;
3580   top.do_variable = NULL;
3581
3582   gfc_state_stack = &top;
3583
3584   gfc_clear_new_st ();
3585
3586   gfc_statement_label = NULL;
3587
3588   if (setjmp (eof_buf))
3589     return FAILURE;     /* Come here on unexpected EOF */
3590
3591   seen_program = 0;
3592
3593   /* Exit early for empty files.  */
3594   if (gfc_at_eof ())
3595     goto done;
3596
3597 loop:
3598   gfc_init_2 ();
3599   st = next_statement ();
3600   switch (st)
3601     {
3602     case ST_NONE:
3603       gfc_done_2 ();
3604       goto done;
3605
3606     case ST_PROGRAM:
3607       if (seen_program)
3608         goto duplicate_main;
3609       seen_program = 1;
3610       prog_locus = gfc_current_locus;
3611
3612       push_state (&s, COMP_PROGRAM, gfc_new_block);
3613       main_program_symbol(gfc_current_ns, gfc_new_block->name);
3614       accept_statement (st);
3615       add_global_program ();
3616       parse_progunit (ST_NONE);
3617       break;
3618
3619     case ST_SUBROUTINE:
3620       add_global_procedure (1);
3621       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3622       accept_statement (st);
3623       parse_progunit (ST_NONE);
3624       break;
3625
3626     case ST_FUNCTION:
3627       add_global_procedure (0);
3628       push_state (&s, COMP_FUNCTION, gfc_new_block);
3629       accept_statement (st);
3630       parse_progunit (ST_NONE);
3631       break;
3632
3633     case ST_BLOCK_DATA:
3634       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3635       accept_statement (st);
3636       parse_block_data ();
3637       break;
3638
3639     case ST_MODULE:
3640       push_state (&s, COMP_MODULE, gfc_new_block);
3641       accept_statement (st);
3642
3643       gfc_get_errors (NULL, &errors_before);
3644       parse_module ();
3645       break;
3646
3647     /* Anything else starts a nameless main program block.  */
3648     default:
3649       if (seen_program)
3650         goto duplicate_main;
3651       seen_program = 1;
3652       prog_locus = gfc_current_locus;
3653
3654       push_state (&s, COMP_PROGRAM, gfc_new_block);
3655       main_program_symbol (gfc_current_ns, "MAIN__");
3656       parse_progunit (st);
3657       break;
3658     }
3659
3660   gfc_current_ns->code = s.head;
3661
3662   gfc_resolve (gfc_current_ns);
3663
3664   /* Dump the parse tree if requested.  */
3665   if (gfc_option.dump_parse_tree)
3666     gfc_dump_parse_tree (gfc_current_ns, stdout);
3667
3668   gfc_get_errors (NULL, &errors);
3669   if (s.state == COMP_MODULE)
3670     {
3671       gfc_dump_module (s.sym->name, errors_before == errors);
3672       if (errors == 0)
3673         gfc_generate_module_code (gfc_current_ns);
3674     }
3675   else
3676     {
3677       if (errors == 0)
3678         gfc_generate_code (gfc_current_ns);
3679     }
3680
3681   pop_state ();
3682   gfc_done_2 ();
3683   goto loop;
3684
3685 done:
3686   gfc_end_source_files ();
3687   return SUCCESS;
3688
3689 duplicate_main:
3690   /* If we see a duplicate main program, shut down.  If the second
3691      instance is an implied main program, i.e. data decls or executable
3692      statements, we're in for lots of errors.  */
3693   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3694   reject_statement ();
3695   gfc_done_2 ();
3696   return SUCCESS;
3697 }