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