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