gcc/fortran/parse.c

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