gcc/fortran/parse.c

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