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