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, const char *name)
1241 {
1242   gfc_symbol *main_program;
1243   symbol_attribute attr;
1244
1245   gfc_get_symbol (name, ns, &main_program);
1246   gfc_clear_attr (&attr);
1247   attr.flavor = FL_PROGRAM;
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 /* Recover use associated or imported function characteristics.  */
1874
1875 static try
1876 match_deferred_characteristics (gfc_typespec * ts)
1877 {
1878   locus loc;
1879   match m;
1880
1881   loc = gfc_current_locus;
1882
1883   if (gfc_current_block ()->ts.type != BT_UNKNOWN)
1884     {
1885       /* Kind expression for an intrinsic type.  */
1886       gfc_current_locus = gfc_function_kind_locus;
1887       m = gfc_match_kind_spec (ts, true);
1888     }
1889   else
1890     {
1891       /* A derived type.  */
1892       gfc_current_locus = gfc_function_type_locus;
1893       m = gfc_match_type_spec (ts, 0);
1894     }
1895
1896   gfc_current_ns->proc_name->result->ts = *ts;
1897   gfc_current_locus =loc;
1898   return m;
1899 }
1900
1901
1902 /* Parse a set of specification statements.  Returns the statement
1903    that doesn't fit.  */
1904
1905 static gfc_statement
1906 parse_spec (gfc_statement st)
1907 {
1908   st_state ss;
1909
1910   verify_st_order (&ss, ST_NONE);
1911   if (st == ST_NONE)
1912     st = next_statement ();
1913
1914 loop:
1915   switch (st)
1916     {
1917     case ST_NONE:
1918       unexpected_eof ();
1919
1920     case ST_FORMAT:
1921     case ST_ENTRY:
1922     case ST_DATA:       /* Not allowed in interfaces */
1923       if (gfc_current_state () == COMP_INTERFACE)
1924         break;
1925
1926       /* Fall through */
1927
1928     case ST_USE:
1929     case ST_IMPORT:
1930     case ST_IMPLICIT_NONE:
1931     case ST_IMPLICIT:
1932     case ST_PARAMETER:
1933     case ST_PUBLIC:
1934     case ST_PRIVATE:
1935     case ST_DERIVED_DECL:
1936     case_decl:
1937       if (verify_st_order (&ss, st) == FAILURE)
1938         {
1939           reject_statement ();
1940           st = next_statement ();
1941           goto loop;
1942         }
1943
1944       switch (st)
1945         {
1946         case ST_INTERFACE:
1947           parse_interface ();
1948           break;
1949
1950         case ST_DERIVED_DECL:
1951           parse_derived ();
1952           break;
1953
1954         case ST_PUBLIC:
1955         case ST_PRIVATE:
1956           if (gfc_current_state () != COMP_MODULE)
1957             {
1958               gfc_error ("%s statement must appear in a MODULE",
1959                          gfc_ascii_statement (st));
1960               break;
1961             }
1962
1963           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
1964             {
1965               gfc_error ("%s statement at %C follows another accessibility "
1966                          "specification", gfc_ascii_statement (st));
1967               break;
1968             }
1969
1970           gfc_current_ns->default_access = (st == ST_PUBLIC)
1971             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
1972
1973           break;
1974
1975         case ST_STATEMENT_FUNCTION:
1976           if (gfc_current_state () == COMP_MODULE)
1977             {
1978               unexpected_statement (st);
1979               break;
1980             }
1981
1982         default:
1983           break;
1984         }
1985
1986       accept_statement (st);
1987
1988       /* Look out for function kind/type information that used
1989          use associated or imported parameter.  This is signalled
1990          by kind = -1.  */
1991       if (gfc_current_state () == COMP_FUNCTION
1992             && (st == ST_USE || st == ST_IMPORT || st == ST_DERIVED_DECL)
1993             && gfc_current_block ()->ts.kind == -1)
1994         match_deferred_characteristics (&gfc_current_block ()->ts);
1995
1996       st = next_statement ();
1997       goto loop;
1998
1999     case ST_ENUM:
2000       accept_statement (st);
2001       parse_enum();
2002       st = next_statement ();
2003       goto loop;
2004
2005     default:
2006       break;
2007     }
2008
2009   /* If we still have kind = -1 at the end of the specification block,
2010      then there is an error. */
2011   if (gfc_current_state () == COMP_FUNCTION
2012         && gfc_current_block ()->ts.kind == -1)
2013     {
2014       if (gfc_current_block ()->ts.type != BT_UNKNOWN)
2015         gfc_error ("Bad kind expression for function '%s' at %L",
2016                    gfc_current_block ()->name, &gfc_function_kind_locus);
2017       else
2018         gfc_error ("The type for function '%s' at %L is not accessible",
2019                    gfc_current_block ()->name, &gfc_function_type_locus);
2020     }
2021
2022   return st;
2023 }
2024
2025
2026 /* Parse a WHERE block, (not a simple WHERE statement).  */
2027
2028 static void
2029 parse_where_block (void)
2030 {
2031   int seen_empty_else;
2032   gfc_code *top, *d;
2033   gfc_state_data s;
2034   gfc_statement st;
2035
2036   accept_statement (ST_WHERE_BLOCK);
2037   top = gfc_state_stack->tail;
2038
2039   push_state (&s, COMP_WHERE, gfc_new_block);
2040
2041   d = add_statement ();
2042   d->expr = top->expr;
2043   d->op = EXEC_WHERE;
2044
2045   top->expr = NULL;
2046   top->block = d;
2047
2048   seen_empty_else = 0;
2049
2050   do
2051     {
2052       st = next_statement ();
2053       switch (st)
2054         {
2055         case ST_NONE:
2056           unexpected_eof ();
2057
2058         case ST_WHERE_BLOCK:
2059           parse_where_block ();
2060           break;
2061
2062         case ST_ASSIGNMENT:
2063         case ST_WHERE:
2064           accept_statement (st);
2065           break;
2066
2067         case ST_ELSEWHERE:
2068           if (seen_empty_else)
2069             {
2070               gfc_error ("ELSEWHERE statement at %C follows previous "
2071                          "unmasked ELSEWHERE");
2072               break;
2073             }
2074
2075           if (new_st.expr == NULL)
2076             seen_empty_else = 1;
2077
2078           d = new_level (gfc_state_stack->head);
2079           d->op = EXEC_WHERE;
2080           d->expr = new_st.expr;
2081
2082           accept_statement (st);
2083
2084           break;
2085
2086         case ST_END_WHERE:
2087           accept_statement (st);
2088           break;
2089
2090         default:
2091           gfc_error ("Unexpected %s statement in WHERE block at %C",
2092                      gfc_ascii_statement (st));
2093           reject_statement ();
2094           break;
2095         }
2096     }
2097   while (st != ST_END_WHERE);
2098
2099   pop_state ();
2100 }
2101
2102
2103 /* Parse a FORALL block (not a simple FORALL statement).  */
2104
2105 static void
2106 parse_forall_block (void)
2107 {
2108   gfc_code *top, *d;
2109   gfc_state_data s;
2110   gfc_statement st;
2111
2112   accept_statement (ST_FORALL_BLOCK);
2113   top = gfc_state_stack->tail;
2114
2115   push_state (&s, COMP_FORALL, gfc_new_block);
2116
2117   d = add_statement ();
2118   d->op = EXEC_FORALL;
2119   top->block = d;
2120
2121   do
2122     {
2123       st = next_statement ();
2124       switch (st)
2125         {
2126
2127         case ST_ASSIGNMENT:
2128         case ST_POINTER_ASSIGNMENT:
2129         case ST_WHERE:
2130         case ST_FORALL:
2131           accept_statement (st);
2132           break;
2133
2134         case ST_WHERE_BLOCK:
2135           parse_where_block ();
2136           break;
2137
2138         case ST_FORALL_BLOCK:
2139           parse_forall_block ();
2140           break;
2141
2142         case ST_END_FORALL:
2143           accept_statement (st);
2144           break;
2145
2146         case ST_NONE:
2147           unexpected_eof ();
2148
2149         default:
2150           gfc_error ("Unexpected %s statement in FORALL block at %C",
2151                      gfc_ascii_statement (st));
2152
2153           reject_statement ();
2154           break;
2155         }
2156     }
2157   while (st != ST_END_FORALL);
2158
2159   pop_state ();
2160 }
2161
2162
2163 static gfc_statement parse_executable (gfc_statement);
2164
2165 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2166
2167 static void
2168 parse_if_block (void)
2169 {
2170   gfc_code *top, *d;
2171   gfc_statement st;
2172   locus else_locus;
2173   gfc_state_data s;
2174   int seen_else;
2175
2176   seen_else = 0;
2177   accept_statement (ST_IF_BLOCK);
2178
2179   top = gfc_state_stack->tail;
2180   push_state (&s, COMP_IF, gfc_new_block);
2181
2182   new_st.op = EXEC_IF;
2183   d = add_statement ();
2184
2185   d->expr = top->expr;
2186   top->expr = NULL;
2187   top->block = d;
2188
2189   do
2190     {
2191       st = parse_executable (ST_NONE);
2192
2193       switch (st)
2194         {
2195         case ST_NONE:
2196           unexpected_eof ();
2197
2198         case ST_ELSEIF:
2199           if (seen_else)
2200             {
2201               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2202                          "statement at %L", &else_locus);
2203
2204               reject_statement ();
2205               break;
2206             }
2207
2208           d = new_level (gfc_state_stack->head);
2209           d->op = EXEC_IF;
2210           d->expr = new_st.expr;
2211
2212           accept_statement (st);
2213
2214           break;
2215
2216         case ST_ELSE:
2217           if (seen_else)
2218             {
2219               gfc_error ("Duplicate ELSE statements at %L and %C",
2220                          &else_locus);
2221               reject_statement ();
2222               break;
2223             }
2224
2225           seen_else = 1;
2226           else_locus = gfc_current_locus;
2227
2228           d = new_level (gfc_state_stack->head);
2229           d->op = EXEC_IF;
2230
2231           accept_statement (st);
2232
2233           break;
2234
2235         case ST_ENDIF:
2236           break;
2237
2238         default:
2239           unexpected_statement (st);
2240           break;
2241         }
2242     }
2243   while (st != ST_ENDIF);
2244
2245   pop_state ();
2246   accept_statement (st);
2247 }
2248
2249
2250 /* Parse a SELECT block.  */
2251
2252 static void
2253 parse_select_block (void)
2254 {
2255   gfc_statement st;
2256   gfc_code *cp;
2257   gfc_state_data s;
2258
2259   accept_statement (ST_SELECT_CASE);
2260
2261   cp = gfc_state_stack->tail;
2262   push_state (&s, COMP_SELECT, gfc_new_block);
2263
2264   /* Make sure that the next statement is a CASE or END SELECT.  */
2265   for (;;)
2266     {
2267       st = next_statement ();
2268       if (st == ST_NONE)
2269         unexpected_eof ();
2270       if (st == ST_END_SELECT)
2271         {
2272           /* Empty SELECT CASE is OK.  */
2273           accept_statement (st);
2274           pop_state ();
2275           return;
2276         }
2277       if (st == ST_CASE)
2278         break;
2279
2280       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2281                  "CASE at %C");
2282
2283       reject_statement ();
2284     }
2285
2286   /* At this point, we're got a nonempty select block.  */
2287   cp = new_level (cp);
2288   *cp = new_st;
2289
2290   accept_statement (st);
2291
2292   do
2293     {
2294       st = parse_executable (ST_NONE);
2295       switch (st)
2296         {
2297         case ST_NONE:
2298           unexpected_eof ();
2299
2300         case ST_CASE:
2301           cp = new_level (gfc_state_stack->head);
2302           *cp = new_st;
2303           gfc_clear_new_st ();
2304
2305           accept_statement (st);
2306           /* Fall through */
2307
2308         case ST_END_SELECT:
2309           break;
2310
2311         /* Can't have an executable statement because of
2312            parse_executable().  */
2313         default:
2314           unexpected_statement (st);
2315           break;
2316         }
2317     }
2318   while (st != ST_END_SELECT);
2319
2320   pop_state ();
2321   accept_statement (st);
2322 }
2323
2324
2325 /* Given a symbol, make sure it is not an iteration variable for a DO
2326    statement.  This subroutine is called when the symbol is seen in a
2327    context that causes it to become redefined.  If the symbol is an
2328    iterator, we generate an error message and return nonzero.  */
2329
2330 int
2331 gfc_check_do_variable (gfc_symtree *st)
2332 {
2333   gfc_state_data *s;
2334
2335   for (s=gfc_state_stack; s; s = s->previous)
2336     if (s->do_variable == st)
2337       {
2338         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
2339                       "loop beginning at %L", st->name, &s->head->loc);
2340         return 1;
2341       }
2342
2343   return 0;
2344 }
2345
2346
2347 /* Checks to see if the current statement label closes an enddo.
2348    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
2349    an error) if it incorrectly closes an ENDDO.  */
2350
2351 static int
2352 check_do_closure (void)
2353 {
2354   gfc_state_data *p;
2355
2356   if (gfc_statement_label == NULL)
2357     return 0;
2358
2359   for (p = gfc_state_stack; p; p = p->previous)
2360     if (p->state == COMP_DO)
2361       break;
2362
2363   if (p == NULL)
2364     return 0;           /* No loops to close */
2365
2366   if (p->ext.end_do_label == gfc_statement_label)
2367     {
2368
2369       if (p == gfc_state_stack)
2370         return 1;
2371
2372       gfc_error ("End of nonblock DO statement at %C is within another block");
2373       return 2;
2374     }
2375
2376   /* At this point, the label doesn't terminate the innermost loop.
2377      Make sure it doesn't terminate another one.  */
2378   for (; p; p = p->previous)
2379     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
2380       {
2381         gfc_error ("End of nonblock DO statement at %C is interwoven "
2382                    "with another DO loop");
2383         return 2;
2384       }
2385
2386   return 0;
2387 }
2388
2389
2390 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
2391    handled inside of parse_executable(), because they aren't really
2392    loop statements.  */
2393
2394 static void
2395 parse_do_block (void)
2396 {
2397   gfc_statement st;
2398   gfc_code *top;
2399   gfc_state_data s;
2400   gfc_symtree *stree;
2401
2402   s.ext.end_do_label = new_st.label;
2403
2404   if (new_st.ext.iterator != NULL)
2405     stree = new_st.ext.iterator->var->symtree;
2406   else
2407     stree = NULL;
2408
2409   accept_statement (ST_DO);
2410
2411   top = gfc_state_stack->tail;
2412   push_state (&s, COMP_DO, gfc_new_block);
2413
2414   s.do_variable = stree;
2415
2416   top->block = new_level (top);
2417   top->block->op = EXEC_DO;
2418
2419 loop:
2420   st = parse_executable (ST_NONE);
2421
2422   switch (st)
2423     {
2424     case ST_NONE:
2425       unexpected_eof ();
2426
2427     case ST_ENDDO:
2428       if (s.ext.end_do_label != NULL
2429           && s.ext.end_do_label != gfc_statement_label)
2430         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
2431                        "DO label");
2432
2433       if (gfc_statement_label != NULL)
2434         {
2435           new_st.op = EXEC_NOP;
2436           add_statement ();
2437         }
2438       break;
2439
2440     case ST_IMPLIED_ENDDO:
2441      /* If the do-stmt of this DO construct has a do-construct-name,
2442         the corresponding end-do must be an end-do-stmt (with a matching
2443         name, but in that case we must have seen ST_ENDDO first).
2444         We only complain about this in pedantic mode.  */
2445      if (gfc_current_block () != NULL)
2446         gfc_error_now ("named block DO at %L requires matching ENDDO name",
2447                        &gfc_current_block()->declared_at);
2448
2449       break;
2450
2451     default:
2452       unexpected_statement (st);
2453       goto loop;
2454     }
2455
2456   pop_state ();
2457   accept_statement (st);
2458 }
2459
2460
2461 /* Parse the statements of OpenMP do/parallel do.  */
2462
2463 static gfc_statement
2464 parse_omp_do (gfc_statement omp_st)
2465 {
2466   gfc_statement st;
2467   gfc_code *cp, *np;
2468   gfc_state_data s;
2469
2470   accept_statement (omp_st);
2471
2472   cp = gfc_state_stack->tail;
2473   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2474   np = new_level (cp);
2475   np->op = cp->op;
2476   np->block = NULL;
2477
2478   for (;;)
2479     {
2480       st = next_statement ();
2481       if (st == ST_NONE)
2482         unexpected_eof ();
2483       else if (st == ST_DO)
2484         break;
2485       else
2486         unexpected_statement (st);
2487     }
2488
2489   parse_do_block ();
2490   if (gfc_statement_label != NULL
2491       && gfc_state_stack->previous != NULL
2492       && gfc_state_stack->previous->state == COMP_DO
2493       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
2494     {
2495       /* In
2496          DO 100 I=1,10
2497            !$OMP DO
2498              DO J=1,10
2499              ...
2500              100 CONTINUE
2501          there should be no !$OMP END DO.  */
2502       pop_state ();
2503       return ST_IMPLIED_ENDDO;
2504     }
2505
2506   check_do_closure ();
2507   pop_state ();
2508
2509   st = next_statement ();
2510   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
2511     {
2512       if (new_st.op == EXEC_OMP_END_NOWAIT)
2513         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2514       else
2515         gcc_assert (new_st.op == EXEC_NOP);
2516       gfc_clear_new_st ();
2517       gfc_commit_symbols ();
2518       gfc_warning_check ();
2519       st = next_statement ();
2520     }
2521   return st;
2522 }
2523
2524
2525 /* Parse the statements of OpenMP atomic directive.  */
2526
2527 static void
2528 parse_omp_atomic (void)
2529 {
2530   gfc_statement st;
2531   gfc_code *cp, *np;
2532   gfc_state_data s;
2533
2534   accept_statement (ST_OMP_ATOMIC);
2535
2536   cp = gfc_state_stack->tail;
2537   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2538   np = new_level (cp);
2539   np->op = cp->op;
2540   np->block = NULL;
2541
2542   for (;;)
2543     {
2544       st = next_statement ();
2545       if (st == ST_NONE)
2546         unexpected_eof ();
2547       else if (st == ST_ASSIGNMENT)
2548         break;
2549       else
2550         unexpected_statement (st);
2551     }
2552
2553   accept_statement (st);
2554
2555   pop_state ();
2556 }
2557
2558
2559 /* Parse the statements of an OpenMP structured block.  */
2560
2561 static void
2562 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
2563 {
2564   gfc_statement st, omp_end_st;
2565   gfc_code *cp, *np;
2566   gfc_state_data s;
2567
2568   accept_statement (omp_st);
2569
2570   cp = gfc_state_stack->tail;
2571   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
2572   np = new_level (cp);
2573   np->op = cp->op;
2574   np->block = NULL;
2575
2576   switch (omp_st)
2577     {
2578     case ST_OMP_PARALLEL:
2579       omp_end_st = ST_OMP_END_PARALLEL;
2580       break;
2581     case ST_OMP_PARALLEL_SECTIONS:
2582       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
2583       break;
2584     case ST_OMP_SECTIONS:
2585       omp_end_st = ST_OMP_END_SECTIONS;
2586       break;
2587     case ST_OMP_ORDERED:
2588       omp_end_st = ST_OMP_END_ORDERED;
2589       break;
2590     case ST_OMP_CRITICAL:
2591       omp_end_st = ST_OMP_END_CRITICAL;
2592       break;
2593     case ST_OMP_MASTER:
2594       omp_end_st = ST_OMP_END_MASTER;
2595       break;
2596     case ST_OMP_SINGLE:
2597       omp_end_st = ST_OMP_END_SINGLE;
2598       break;
2599     case ST_OMP_WORKSHARE:
2600       omp_end_st = ST_OMP_END_WORKSHARE;
2601       break;
2602     case ST_OMP_PARALLEL_WORKSHARE:
2603       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
2604       break;
2605     default:
2606       gcc_unreachable ();
2607     }
2608
2609   do
2610     {
2611       if (workshare_stmts_only)
2612         {
2613           /* Inside of !$omp workshare, only
2614              scalar assignments
2615              array assignments
2616              where statements and constructs
2617              forall statements and constructs
2618              !$omp atomic
2619              !$omp critical
2620              !$omp parallel
2621              are allowed.  For !$omp critical these
2622              restrictions apply recursively.  */
2623           bool cycle = true;
2624
2625           st = next_statement ();
2626           for (;;)
2627             {
2628               switch (st)
2629                 {
2630                 case ST_NONE:
2631                   unexpected_eof ();
2632
2633                 case ST_ASSIGNMENT:
2634                 case ST_WHERE:
2635                 case ST_FORALL:
2636                   accept_statement (st);
2637                   break;
2638
2639                 case ST_WHERE_BLOCK:
2640                   parse_where_block ();
2641                   break;
2642
2643                 case ST_FORALL_BLOCK:
2644                   parse_forall_block ();
2645                   break;
2646
2647                 case ST_OMP_PARALLEL:
2648                 case ST_OMP_PARALLEL_SECTIONS:
2649                   parse_omp_structured_block (st, false);
2650                   break;
2651
2652                 case ST_OMP_PARALLEL_WORKSHARE:
2653                 case ST_OMP_CRITICAL:
2654                   parse_omp_structured_block (st, true);
2655                   break;
2656
2657                 case ST_OMP_PARALLEL_DO:
2658                   st = parse_omp_do (st);
2659                   continue;
2660
2661                 case ST_OMP_ATOMIC:
2662                   parse_omp_atomic ();
2663                   break;
2664
2665                 default:
2666                   cycle = false;
2667                   break;
2668                 }
2669
2670               if (!cycle)
2671                 break;
2672
2673               st = next_statement ();
2674             }
2675         }
2676       else
2677         st = parse_executable (ST_NONE);
2678       if (st == ST_NONE)
2679         unexpected_eof ();
2680       else if (st == ST_OMP_SECTION
2681                && (omp_st == ST_OMP_SECTIONS
2682                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
2683         {
2684           np = new_level (np);
2685           np->op = cp->op;
2686           np->block = NULL;
2687         }
2688       else if (st != omp_end_st)
2689         unexpected_statement (st);
2690     }
2691   while (st != omp_end_st);
2692
2693   switch (new_st.op)
2694     {
2695     case EXEC_OMP_END_NOWAIT:
2696       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
2697       break;
2698     case EXEC_OMP_CRITICAL:
2699       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
2700           || (new_st.ext.omp_name != NULL
2701               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
2702         gfc_error ("Name after !$omp critical and !$omp end critical does "
2703                    "not match at %C");
2704       gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
2705       break;
2706     case EXEC_OMP_END_SINGLE:
2707       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
2708         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
2709       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
2710       gfc_free_omp_clauses (new_st.ext.omp_clauses);
2711       break;
2712     case EXEC_NOP:
2713       break;
2714     default:
2715       gcc_unreachable ();
2716     }
2717
2718   gfc_clear_new_st ();
2719   gfc_commit_symbols ();
2720   gfc_warning_check ();
2721   pop_state ();
2722 }
2723
2724
2725 /* Accept a series of executable statements.  We return the first
2726    statement that doesn't fit to the caller.  Any block statements are
2727    passed on to the correct handler, which usually passes the buck
2728    right back here.  */
2729
2730 static gfc_statement
2731 parse_executable (gfc_statement st)
2732 {
2733   int close_flag;
2734
2735   if (st == ST_NONE)
2736     st = next_statement ();
2737
2738   for (;;)
2739     {
2740       close_flag = check_do_closure ();
2741       if (close_flag)
2742         switch (st)
2743           {
2744           case ST_GOTO:
2745           case ST_END_PROGRAM:
2746           case ST_RETURN:
2747           case ST_EXIT:
2748           case ST_END_FUNCTION:
2749           case ST_CYCLE:
2750           case ST_PAUSE:
2751           case ST_STOP:
2752           case ST_END_SUBROUTINE:
2753
2754           case ST_DO:
2755           case ST_FORALL:
2756           case ST_WHERE:
2757           case ST_SELECT_CASE:
2758             gfc_error ("%s statement at %C cannot terminate a non-block "
2759                        "DO loop", gfc_ascii_statement (st));
2760             break;
2761
2762           default:
2763             break;
2764           }
2765
2766       switch (st)
2767         {
2768         case ST_NONE:
2769           unexpected_eof ();
2770
2771         case ST_FORMAT:
2772         case ST_DATA:
2773         case ST_ENTRY:
2774         case_executable:
2775           accept_statement (st);
2776           if (close_flag == 1)
2777             return ST_IMPLIED_ENDDO;
2778           break;
2779
2780         case ST_IF_BLOCK:
2781           parse_if_block ();
2782           break;
2783
2784         case ST_SELECT_CASE:
2785           parse_select_block ();
2786           break;
2787
2788         case ST_DO:
2789           parse_do_block ();
2790           if (check_do_closure () == 1)
2791             return ST_IMPLIED_ENDDO;
2792           break;
2793
2794         case ST_WHERE_BLOCK:
2795           parse_where_block ();
2796           break;
2797
2798         case ST_FORALL_BLOCK:
2799           parse_forall_block ();
2800           break;
2801
2802         case ST_OMP_PARALLEL:
2803         case ST_OMP_PARALLEL_SECTIONS:
2804         case ST_OMP_SECTIONS:
2805         case ST_OMP_ORDERED:
2806         case ST_OMP_CRITICAL:
2807         case ST_OMP_MASTER:
2808         case ST_OMP_SINGLE:
2809           parse_omp_structured_block (st, false);
2810           break;
2811
2812         case ST_OMP_WORKSHARE:
2813         case ST_OMP_PARALLEL_WORKSHARE:
2814           parse_omp_structured_block (st, true);
2815           break;
2816
2817         case ST_OMP_DO:
2818         case ST_OMP_PARALLEL_DO:
2819           st = parse_omp_do (st);
2820           if (st == ST_IMPLIED_ENDDO)
2821             return st;
2822           continue;
2823
2824         case ST_OMP_ATOMIC:
2825           parse_omp_atomic ();
2826           break;
2827
2828         default:
2829           return st;
2830         }
2831
2832       st = next_statement ();
2833     }
2834 }
2835
2836
2837 /* Parse a series of contained program units.  */
2838
2839 static void parse_progunit (gfc_statement);
2840
2841
2842 /* Fix the symbols for sibling functions.  These are incorrectly added to
2843    the child namespace as the parser didn't know about this procedure.  */
2844
2845 static void
2846 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
2847 {
2848   gfc_namespace *ns;
2849   gfc_symtree *st;
2850   gfc_symbol *old_sym;
2851
2852   sym->attr.referenced = 1;
2853   for (ns = siblings; ns; ns = ns->sibling)
2854     {
2855       gfc_find_sym_tree (sym->name, ns, 0, &st);
2856
2857       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
2858         continue;
2859
2860       old_sym = st->n.sym;
2861       if (old_sym->ns == ns
2862             && !old_sym->attr.contained
2863
2864             /* By 14.6.1.3, host association should be excluded
2865                for the following.  */
2866             && !(old_sym->attr.external
2867                   || (old_sym->ts.type != BT_UNKNOWN
2868                         && !old_sym->attr.implicit_type)
2869                   || old_sym->attr.flavor == FL_PARAMETER
2870                   || old_sym->attr.in_common
2871                   || old_sym->attr.in_equivalence
2872                   || old_sym->attr.data
2873                   || old_sym->attr.dummy
2874                   || old_sym->attr.result
2875                   || old_sym->attr.dimension
2876                   || old_sym->attr.allocatable
2877                   || old_sym->attr.intrinsic
2878                   || old_sym->attr.generic
2879                   || old_sym->attr.flavor == FL_NAMELIST
2880                   || old_sym->attr.proc == PROC_ST_FUNCTION))
2881         {
2882           /* Replace it with the symbol from the parent namespace.  */
2883           st->n.sym = sym;
2884           sym->refs++;
2885
2886           /* Free the old (local) symbol.  */
2887           old_sym->refs--;
2888           if (old_sym->refs == 0)
2889             gfc_free_symbol (old_sym);
2890         }
2891
2892       /* Do the same for any contained procedures.  */
2893       gfc_fixup_sibling_symbols (sym, ns->contained);
2894     }
2895 }
2896
2897 static void
2898 parse_contained (int module)
2899 {
2900   gfc_namespace *ns, *parent_ns, *tmp;
2901   gfc_state_data s1, s2;
2902   gfc_statement st;
2903   gfc_symbol *sym;
2904   gfc_entry_list *el;
2905   int contains_statements = 0;
2906   int seen_error = 0;
2907
2908   push_state (&s1, COMP_CONTAINS, NULL);
2909   parent_ns = gfc_current_ns;
2910
2911   do
2912     {
2913       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
2914
2915       gfc_current_ns->sibling = parent_ns->contained;
2916       parent_ns->contained = gfc_current_ns;
2917
2918  next:
2919       /* Process the next available statement.  We come here if we got an error
2920          and rejected the last statement.  */
2921       st = next_statement ();
2922
2923       switch (st)
2924         {
2925         case ST_NONE:
2926           unexpected_eof ();
2927
2928         case ST_FUNCTION:
2929         case ST_SUBROUTINE:
2930           contains_statements = 1;
2931           accept_statement (st);
2932
2933           push_state (&s2,
2934                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
2935                       gfc_new_block);
2936
2937           /* For internal procedures, create/update the symbol in the
2938              parent namespace.  */
2939
2940           if (!module)
2941             {
2942               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
2943                 gfc_error ("Contained procedure '%s' at %C is already "
2944                            "ambiguous", gfc_new_block->name);
2945               else
2946                 {
2947                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
2948                                          &gfc_new_block->declared_at) ==
2949                       SUCCESS)
2950                     {
2951                       if (st == ST_FUNCTION)
2952                         gfc_add_function (&sym->attr, sym->name,
2953                                           &gfc_new_block->declared_at);
2954                       else
2955                         gfc_add_subroutine (&sym->attr, sym->name,
2956                                             &gfc_new_block->declared_at);
2957                     }
2958                 }
2959
2960               gfc_commit_symbols ();
2961             }
2962           else
2963             sym = gfc_new_block;
2964
2965           /* Mark this as a contained function, so it isn't replaced
2966              by other module functions.  */
2967           sym->attr.contained = 1;
2968           sym->attr.referenced = 1;
2969
2970           parse_progunit (ST_NONE);
2971
2972           /* Fix up any sibling functions that refer to this one.  */
2973           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
2974           /* Or refer to any of its alternate entry points.  */
2975           for (el = gfc_current_ns->entries; el; el = el->next)
2976             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
2977
2978           gfc_current_ns->code = s2.head;
2979           gfc_current_ns = parent_ns;
2980
2981           pop_state ();
2982           break;
2983
2984         /* These statements are associated with the end of the host unit.  */
2985         case ST_END_FUNCTION:
2986         case ST_END_MODULE:
2987         case ST_END_PROGRAM:
2988         case ST_END_SUBROUTINE:
2989           accept_statement (st);
2990           break;
2991
2992         default:
2993           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
2994                      gfc_ascii_statement (st));
2995           reject_statement ();
2996           seen_error = 1;
2997           goto next;
2998           break;
2999         }
3000     }
3001   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3002          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3003
3004   /* The first namespace in the list is guaranteed to not have
3005      anything (worthwhile) in it.  */
3006   tmp = gfc_current_ns;
3007   gfc_current_ns = parent_ns;
3008   if (seen_error && tmp->refs > 1)
3009     gfc_free_namespace (tmp);
3010
3011   ns = gfc_current_ns->contained;
3012   gfc_current_ns->contained = ns->sibling;
3013   gfc_free_namespace (ns);
3014
3015   pop_state ();
3016   if (!contains_statements)
3017     /* This is valid in Fortran 2008.  */
3018     gfc_notify_std (GFC_STD_GNU, "Extension: CONTAINS statement without "
3019                     "FUNCTION or SUBROUTINE statement at %C");
3020 }
3021
3022
3023 /* Parse a PROGRAM, SUBROUTINE or FUNCTION unit.  */
3024
3025 static void
3026 parse_progunit (gfc_statement st)
3027 {
3028   gfc_state_data *p;
3029   int n;
3030
3031   st = parse_spec (st);
3032   switch (st)
3033     {
3034     case ST_NONE:
3035       unexpected_eof ();
3036
3037     case ST_CONTAINS:
3038       goto contains;
3039
3040     case_end:
3041       accept_statement (st);
3042       goto done;
3043
3044     default:
3045       break;
3046     }
3047
3048   if (gfc_current_state () == COMP_FUNCTION)
3049     gfc_check_function_type (gfc_current_ns);
3050
3051 loop:
3052   for (;;)
3053     {
3054       st = parse_executable (st);
3055
3056       switch (st)
3057         {
3058         case ST_NONE:
3059           unexpected_eof ();
3060
3061         case ST_CONTAINS:
3062           goto contains;
3063
3064         case_end:
3065           accept_statement (st);
3066           goto done;
3067
3068         default:
3069           break;
3070         }
3071
3072       unexpected_statement (st);
3073       reject_statement ();
3074       st = next_statement ();
3075     }
3076
3077 contains:
3078   n = 0;
3079
3080   for (p = gfc_state_stack; p; p = p->previous)
3081     if (p->state == COMP_CONTAINS)
3082       n++;
3083
3084   if (gfc_find_state (COMP_MODULE) == SUCCESS)
3085     n--;
3086
3087   if (n > 0)
3088     {
3089       gfc_error ("CONTAINS statement at %C is already in a contained "
3090                  "program unit");
3091       st = next_statement ();
3092       goto loop;
3093     }
3094
3095   parse_contained (0);
3096
3097 done:
3098   gfc_current_ns->code = gfc_state_stack->head;
3099 }
3100
3101
3102 /* Come here to complain about a global symbol already in use as
3103    something else.  */
3104
3105 void
3106 gfc_global_used (gfc_gsymbol *sym, locus *where)
3107 {
3108   const char *name;
3109
3110   if (where == NULL)
3111     where = &gfc_current_locus;
3112
3113   switch(sym->type)
3114     {
3115     case GSYM_PROGRAM:
3116       name = "PROGRAM";
3117       break;
3118     case GSYM_FUNCTION:
3119       name = "FUNCTION";
3120       break;
3121     case GSYM_SUBROUTINE:
3122       name = "SUBROUTINE";
3123       break;
3124     case GSYM_COMMON:
3125       name = "COMMON";
3126       break;
3127     case GSYM_BLOCK_DATA:
3128       name = "BLOCK DATA";
3129       break;
3130     case GSYM_MODULE:
3131       name = "MODULE";
3132       break;
3133     default:
3134       gfc_internal_error ("gfc_gsymbol_type(): Bad type");
3135       name = NULL;
3136     }
3137
3138   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
3139               sym->name, where, name, &sym->where);
3140 }
3141
3142
3143 /* Parse a block data program unit.  */
3144
3145 static void
3146 parse_block_data (void)
3147 {
3148   gfc_statement st;
3149   static locus blank_locus;
3150   static int blank_block=0;
3151   gfc_gsymbol *s;
3152
3153   gfc_current_ns->proc_name = gfc_new_block;
3154   gfc_current_ns->is_block_data = 1;
3155
3156   if (gfc_new_block == NULL)
3157     {
3158       if (blank_block)
3159        gfc_error ("Blank BLOCK DATA at %C conflicts with "
3160                   "prior BLOCK DATA at %L", &blank_locus);
3161       else
3162        {
3163          blank_block = 1;
3164          blank_locus = gfc_current_locus;
3165        }
3166     }
3167   else
3168     {
3169       s = gfc_get_gsymbol (gfc_new_block->name);
3170       if (s->defined
3171           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
3172        gfc_global_used(s, NULL);
3173       else
3174        {
3175          s->type = GSYM_BLOCK_DATA;
3176          s->where = gfc_current_locus;
3177          s->defined = 1;
3178        }
3179     }
3180
3181   st = parse_spec (ST_NONE);
3182
3183   while (st != ST_END_BLOCK_DATA)
3184     {
3185       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
3186                  gfc_ascii_statement (st));
3187       reject_statement ();
3188       st = next_statement ();
3189     }
3190 }
3191
3192
3193 /* Parse a module subprogram.  */
3194
3195 static void
3196 parse_module (void)
3197 {
3198   gfc_statement st;
3199   gfc_gsymbol *s;
3200
3201   s = gfc_get_gsymbol (gfc_new_block->name);
3202   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
3203     gfc_global_used(s, NULL);
3204   else
3205     {
3206       s->type = GSYM_MODULE;
3207       s->where = gfc_current_locus;
3208       s->defined = 1;
3209     }
3210
3211   st = parse_spec (ST_NONE);
3212
3213 loop:
3214   switch (st)
3215     {
3216     case ST_NONE:
3217       unexpected_eof ();
3218
3219     case ST_CONTAINS:
3220       parse_contained (1);
3221       break;
3222
3223     case ST_END_MODULE:
3224       accept_statement (st);
3225       break;
3226
3227     default:
3228       gfc_error ("Unexpected %s statement in MODULE at %C",
3229                  gfc_ascii_statement (st));
3230
3231       reject_statement ();
3232       st = next_statement ();
3233       goto loop;
3234     }
3235 }
3236
3237
3238 /* Add a procedure name to the global symbol table.  */
3239
3240 static void
3241 add_global_procedure (int sub)
3242 {
3243   gfc_gsymbol *s;
3244
3245   s = gfc_get_gsymbol(gfc_new_block->name);
3246
3247   if (s->defined
3248       || (s->type != GSYM_UNKNOWN
3249           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
3250     gfc_global_used(s, NULL);
3251   else
3252     {
3253       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
3254       s->where = gfc_current_locus;
3255       s->defined = 1;
3256     }
3257 }
3258
3259
3260 /* Add a program to the global symbol table.  */
3261
3262 static void
3263 add_global_program (void)
3264 {
3265   gfc_gsymbol *s;
3266
3267   if (gfc_new_block == NULL)
3268     return;
3269   s = gfc_get_gsymbol (gfc_new_block->name);
3270
3271   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
3272     gfc_global_used(s, NULL);
3273   else
3274     {
3275       s->type = GSYM_PROGRAM;
3276       s->where = gfc_current_locus;
3277       s->defined = 1;
3278     }
3279 }
3280
3281
3282 /* Top level parser.  */
3283
3284 try
3285 gfc_parse_file (void)
3286 {
3287   int seen_program, errors_before, errors;
3288   gfc_state_data top, s;
3289   gfc_statement st;
3290   locus prog_locus;
3291
3292   gfc_start_source_files ();
3293
3294   top.state = COMP_NONE;
3295   top.sym = NULL;
3296   top.previous = NULL;
3297   top.head = top.tail = NULL;
3298   top.do_variable = NULL;
3299
3300   gfc_state_stack = &top;
3301
3302   gfc_clear_new_st ();
3303
3304   gfc_statement_label = NULL;
3305
3306   if (setjmp (eof_buf))
3307     return FAILURE;     /* Come here on unexpected EOF */
3308
3309   seen_program = 0;
3310
3311   /* Exit early for empty files.  */
3312   if (gfc_at_eof ())
3313     goto done;
3314
3315 loop:
3316   gfc_init_2 ();
3317   st = next_statement ();
3318   switch (st)
3319     {
3320     case ST_NONE:
3321       gfc_done_2 ();
3322       goto done;
3323
3324     case ST_PROGRAM:
3325       if (seen_program)
3326         goto duplicate_main;
3327       seen_program = 1;
3328       prog_locus = gfc_current_locus;
3329
3330       push_state (&s, COMP_PROGRAM, gfc_new_block);
3331       main_program_symbol(gfc_current_ns, gfc_new_block->name);
3332       accept_statement (st);
3333       add_global_program ();
3334       parse_progunit (ST_NONE);
3335       break;
3336
3337     case ST_SUBROUTINE:
3338       add_global_procedure (1);
3339       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
3340       accept_statement (st);
3341       parse_progunit (ST_NONE);
3342       break;
3343
3344     case ST_FUNCTION:
3345       add_global_procedure (0);
3346       push_state (&s, COMP_FUNCTION, gfc_new_block);
3347       accept_statement (st);
3348       parse_progunit (ST_NONE);
3349       break;
3350
3351     case ST_BLOCK_DATA:
3352       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
3353       accept_statement (st);
3354       parse_block_data ();
3355       break;
3356
3357     case ST_MODULE:
3358       push_state (&s, COMP_MODULE, gfc_new_block);
3359       accept_statement (st);
3360
3361       gfc_get_errors (NULL, &errors_before);
3362       parse_module ();
3363       break;
3364
3365     /* Anything else starts a nameless main program block.  */
3366     default:
3367       if (seen_program)
3368         goto duplicate_main;
3369       seen_program = 1;
3370       prog_locus = gfc_current_locus;
3371
3372       push_state (&s, COMP_PROGRAM, gfc_new_block);
3373       main_program_symbol (gfc_current_ns, "MAIN__");
3374       parse_progunit (st);
3375       break;
3376     }
3377
3378   gfc_current_ns->code = s.head;
3379
3380   gfc_resolve (gfc_current_ns);
3381
3382   /* Dump the parse tree if requested.  */
3383   if (gfc_option.verbose)
3384     gfc_show_namespace (gfc_current_ns);
3385
3386   gfc_get_errors (NULL, &errors);
3387   if (s.state == COMP_MODULE)
3388     {
3389       gfc_dump_module (s.sym->name, errors_before == errors);
3390       if (errors == 0)
3391         gfc_generate_module_code (gfc_current_ns);
3392     }
3393   else
3394     {
3395       if (errors == 0)
3396         gfc_generate_code (gfc_current_ns);
3397     }
3398
3399   pop_state ();
3400   gfc_done_2 ();
3401   goto loop;
3402
3403 done:
3404   gfc_end_source_files ();
3405   return SUCCESS;
3406
3407 duplicate_main:
3408   /* If we see a duplicate main program, shut down.  If the second
3409      instance is an implied main program, ie data decls or executable
3410      statements, we're in for lots of errors.  */
3411   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
3412   reject_statement ();
3413   gfc_done_2 ();
3414   return SUCCESS;
3415 }