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