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