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