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