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