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