gcc/fortran/parse.c

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