gcc/fortran/parse.c

   1 /* Main parser.
   2    Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008,
   3    2009, 2010
   4    Free Software Foundation, Inc.
   5    Contributed by Andy Vaught
   6
   7 This file is part of GCC.
   8
   9 GCC is free software; you can redistribute it and/or modify it under
  10 the terms of the GNU General Public License as published by the Free
  11 Software Foundation; either version 3, or (at your option) any later
  12 version.
  13
  14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  16 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  17 for more details.
  18
  19 You should have received a copy of the GNU General Public License
  20 along with GCC; see the file COPYING3.  If not see
  21 <http://www.gnu.org/licenses/>.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include <setjmp.h>
  26 #include "gfortran.h"
  27 #include "match.h"
  28 #include "parse.h"
  29 #include "debug.h"
  30
  31 /* Current statement label.  Zero means no statement label.  Because new_st
  32    can get wiped during statement matching, we have to keep it separate.  */
  33
  34 gfc_st_label *gfc_statement_label;
  35
  36 static locus label_locus;
  37 static jmp_buf eof_buf;
  38
  39 gfc_state_data *gfc_state_stack;
  40
  41 /* TODO: Re-order functions to kill these forward decls.  */
  42 static void check_statement_label (gfc_statement);
  43 static void undo_new_statement (void);
  44 static void reject_statement (void);
  45
  46
  47 /* A sort of half-matching function.  We try to match the word on the
  48    input with the passed string.  If this succeeds, we call the
  49    keyword-dependent matching function that will match the rest of the
  50    statement.  For single keywords, the matching subroutine is
  51    gfc_match_eos().  */
  52
  53 static match
  54 match_word (const char *str, match (*subr) (void), locus *old_locus)
  55 {
  56   match m;
  57
  58   if (str != NULL)
  59     {
  60       m = gfc_match (str);
  61       if (m != MATCH_YES)
  62         return m;
  63     }
  64
  65   m = (*subr) ();
  66
  67   if (m != MATCH_YES)
  68     {
  69       gfc_current_locus = *old_locus;
  70       reject_statement ();
  71     }
  72
  73   return m;
  74 }
  75
  76
  77 /* Figure out what the next statement is, (mostly) regardless of
  78    proper ordering.  The do...while(0) is there to prevent if/else
  79    ambiguity.  */
  80
  81 #define match(keyword, subr, st)                                \
  82     do {                                                        \
  83       if (match_word(keyword, subr, &old_locus) == MATCH_YES)   \
  84         return st;                                              \
  85       else                                                      \
  86         undo_new_statement ();                            \
  87     } while (0);
  88
  89
  90 /* This is a specialist version of decode_statement that is used
  91    for the specification statements in a function, whose
  92    characteristics are deferred into the specification statements.
  93    eg.:  INTEGER (king = mykind) foo ()
  94          USE mymodule, ONLY mykind.....
  95    The KIND parameter needs a return after USE or IMPORT, whereas
  96    derived type declarations can occur anywhere, up the executable
  97    block.  ST_GET_FCN_CHARACTERISTICS is returned when we have run
  98    out of the correct kind of specification statements.  */
  99 static gfc_statement
 100 decode_specification_statement (void)
 101 {
 102   gfc_statement st;
 103   locus old_locus;
 104   char c;
 105
 106   if (gfc_match_eos () == MATCH_YES)
 107     return ST_NONE;
 108
 109   old_locus = gfc_current_locus;
 110
 111   match ("import", gfc_match_import, ST_IMPORT);
 112   match ("use", gfc_match_use, ST_USE);
 113
 114   if (gfc_current_block ()->result->ts.type != BT_DERIVED)
 115     goto end_of_block;
 116
 117   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 118   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 119   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 120
 121   /* General statement matching: Instead of testing every possible
 122      statement, we eliminate most possibilities by peeking at the
 123      first character.  */
 124
 125   c = gfc_peek_ascii_char ();
 126
 127   switch (c)
 128     {
 129     case 'a':
 130       match ("abstract% interface", gfc_match_abstract_interface,
 131              ST_INTERFACE);
 132       match ("allocatable", gfc_match_asynchronous, ST_ATTR_DECL);
 133       match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
 134       break;
 135
 136     case 'b':
 137       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 138       break;
 139
 140     case 'c':
 141       match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
 142       match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
 143       break;
 144
 145     case 'd':
 146       match ("data", gfc_match_data, ST_DATA);
 147       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 148       break;
 149
 150     case 'e':
 151       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 152       match ("entry% ", gfc_match_entry, ST_ENTRY);
 153       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 154       match ("external", gfc_match_external, ST_ATTR_DECL);
 155       break;
 156
 157     case 'f':
 158       match ("format", gfc_match_format, ST_FORMAT);
 159       break;
 160
 161     case 'g':
 162       break;
 163
 164     case 'i':
 165       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 166       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 167       match ("interface", gfc_match_interface, ST_INTERFACE);
 168       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 169       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 170       break;
 171
 172     case 'm':
 173       break;
 174
 175     case 'n':
 176       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 177       break;
 178
 179     case 'o':
 180       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 181       break;
 182
 183     case 'p':
 184       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 185       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 186       if (gfc_match_private (&st) == MATCH_YES)
 187         return st;
 188       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 189       if (gfc_match_public (&st) == MATCH_YES)
 190         return st;
 191       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 192       break;
 193
 194     case 'r':
 195       break;
 196
 197     case 's':
 198       match ("save", gfc_match_save, ST_ATTR_DECL);
 199       break;
 200
 201     case 't':
 202       match ("target", gfc_match_target, ST_ATTR_DECL);
 203       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 204       break;
 205
 206     case 'u':
 207       break;
 208
 209     case 'v':
 210       match ("value", gfc_match_value, ST_ATTR_DECL);
 211       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 212       break;
 213
 214     case 'w':
 215       break;
 216     }
 217
 218   /* This is not a specification statement.  See if any of the matchers
 219      has stored an error message of some sort.  */
 220
 221 end_of_block:
 222   gfc_clear_error ();
 223   gfc_buffer_error (0);
 224   gfc_current_locus = old_locus;
 225
 226   return ST_GET_FCN_CHARACTERISTICS;
 227 }
 228
 229
 230 /* This is the primary 'decode_statement'.  */
 231 static gfc_statement
 232 decode_statement (void)
 233 {
 234   gfc_statement st;
 235   locus old_locus;
 236   match m;
 237   char c;
 238
 239   gfc_enforce_clean_symbol_state ();
 240
 241   gfc_clear_error ();   /* Clear any pending errors.  */
 242   gfc_clear_warning (); /* Clear any pending warnings.  */
 243
 244   gfc_matching_function = false;
 245
 246   if (gfc_match_eos () == MATCH_YES)
 247     return ST_NONE;
 248
 249   if (gfc_current_state () == COMP_FUNCTION
 250         && gfc_current_block ()->result->ts.kind == -1)
 251     return decode_specification_statement ();
 252
 253   old_locus = gfc_current_locus;
 254
 255   /* Try matching a data declaration or function declaration. The
 256       input "REALFUNCTIONA(N)" can mean several things in different
 257       contexts, so it (and its relatives) get special treatment.  */
 258
 259   if (gfc_current_state () == COMP_NONE
 260       || gfc_current_state () == COMP_INTERFACE
 261       || gfc_current_state () == COMP_CONTAINS)
 262     {
 263       gfc_matching_function = true;
 264       m = gfc_match_function_decl ();
 265       if (m == MATCH_YES)
 266         return ST_FUNCTION;
 267       else if (m == MATCH_ERROR)
 268         reject_statement ();
 269       else
 270         gfc_undo_symbols ();
 271       gfc_current_locus = old_locus;
 272     }
 273   gfc_matching_function = false;
 274
 275
 276   /* Match statements whose error messages are meant to be overwritten
 277      by something better.  */
 278
 279   match (NULL, gfc_match_assignment, ST_ASSIGNMENT);
 280   match (NULL, gfc_match_pointer_assignment, ST_POINTER_ASSIGNMENT);
 281   match (NULL, gfc_match_st_function, ST_STATEMENT_FUNCTION);
 282
 283   match (NULL, gfc_match_data_decl, ST_DATA_DECL);
 284   match (NULL, gfc_match_enumerator_def, ST_ENUMERATOR);
 285
 286   /* Try to match a subroutine statement, which has the same optional
 287      prefixes that functions can have.  */
 288
 289   if (gfc_match_subroutine () == MATCH_YES)
 290     return ST_SUBROUTINE;
 291   gfc_undo_symbols ();
 292   gfc_current_locus = old_locus;
 293
 294   /* Check for the IF, DO, SELECT, WHERE, FORALL, CRITICAL, BLOCK and ASSOCIATE
 295      statements, which might begin with a block label.  The match functions for
 296      these statements are unusual in that their keyword is not seen before
 297      the matcher is called.  */
 298
 299   if (gfc_match_if (&st) == MATCH_YES)
 300     return st;
 301   gfc_undo_symbols ();
 302   gfc_current_locus = old_locus;
 303
 304   if (gfc_match_where (&st) == MATCH_YES)
 305     return st;
 306   gfc_undo_symbols ();
 307   gfc_current_locus = old_locus;
 308
 309   if (gfc_match_forall (&st) == MATCH_YES)
 310     return st;
 311   gfc_undo_symbols ();
 312   gfc_current_locus = old_locus;
 313
 314   match (NULL, gfc_match_do, ST_DO);
 315   match (NULL, gfc_match_block, ST_BLOCK);
 316   match (NULL, gfc_match_associate, ST_ASSOCIATE);
 317   match (NULL, gfc_match_critical, ST_CRITICAL);
 318   match (NULL, gfc_match_select, ST_SELECT_CASE);
 319   match (NULL, gfc_match_select_type, ST_SELECT_TYPE);
 320
 321   /* General statement matching: Instead of testing every possible
 322      statement, we eliminate most possibilities by peeking at the
 323      first character.  */
 324
 325   c = gfc_peek_ascii_char ();
 326
 327   switch (c)
 328     {
 329     case 'a':
 330       match ("abstract% interface", gfc_match_abstract_interface,
 331              ST_INTERFACE);
 332       match ("allocate", gfc_match_allocate, ST_ALLOCATE);
 333       match ("allocatable", gfc_match_allocatable, ST_ATTR_DECL);
 334       match ("assign", gfc_match_assign, ST_LABEL_ASSIGNMENT);
 335       match ("asynchronous", gfc_match_asynchronous, ST_ATTR_DECL);
 336       break;
 337
 338     case 'b':
 339       match ("backspace", gfc_match_backspace, ST_BACKSPACE);
 340       match ("block data", gfc_match_block_data, ST_BLOCK_DATA);
 341       match (NULL, gfc_match_bind_c_stmt, ST_ATTR_DECL);
 342       break;
 343
 344     case 'c':
 345       match ("call", gfc_match_call, ST_CALL);
 346       match ("close", gfc_match_close, ST_CLOSE);
 347       match ("continue", gfc_match_continue, ST_CONTINUE);
 348       match ("contiguous", gfc_match_contiguous, ST_ATTR_DECL);
 349       match ("cycle", gfc_match_cycle, ST_CYCLE);
 350       match ("case", gfc_match_case, ST_CASE);
 351       match ("common", gfc_match_common, ST_COMMON);
 352       match ("contains", gfc_match_eos, ST_CONTAINS);
 353       match ("class", gfc_match_class_is, ST_CLASS_IS);
 354       match ("codimension", gfc_match_codimension, ST_ATTR_DECL);
 355       break;
 356
 357     case 'd':
 358       match ("deallocate", gfc_match_deallocate, ST_DEALLOCATE);
 359       match ("data", gfc_match_data, ST_DATA);
 360       match ("dimension", gfc_match_dimension, ST_ATTR_DECL);
 361       break;
 362
 363     case 'e':
 364       match ("end file", gfc_match_endfile, ST_END_FILE);
 365       match ("exit", gfc_match_exit, ST_EXIT);
 366       match ("else", gfc_match_else, ST_ELSE);
 367       match ("else where", gfc_match_elsewhere, ST_ELSEWHERE);
 368       match ("else if", gfc_match_elseif, ST_ELSEIF);
 369       match ("error stop", gfc_match_error_stop, ST_ERROR_STOP);
 370       match ("enum , bind ( c )", gfc_match_enum, ST_ENUM);
 371
 372       if (gfc_match_end (&st) == MATCH_YES)
 373         return st;
 374
 375       match ("entry% ", gfc_match_entry, ST_ENTRY);
 376       match ("equivalence", gfc_match_equivalence, ST_EQUIVALENCE);
 377       match ("external", gfc_match_external, ST_ATTR_DECL);
 378       break;
 379
 380     case 'f':
 381       match ("final", gfc_match_final_decl, ST_FINAL);
 382       match ("flush", gfc_match_flush, ST_FLUSH);
 383       match ("format", gfc_match_format, ST_FORMAT);
 384       break;
 385
 386     case 'g':
 387       match ("generic", gfc_match_generic, ST_GENERIC);
 388       match ("go to", gfc_match_goto, ST_GOTO);
 389       break;
 390
 391     case 'i':
 392       match ("inquire", gfc_match_inquire, ST_INQUIRE);
 393       match ("implicit", gfc_match_implicit, ST_IMPLICIT);
 394       match ("implicit% none", gfc_match_implicit_none, ST_IMPLICIT_NONE);
 395       match ("import", gfc_match_import, ST_IMPORT);
 396       match ("interface", gfc_match_interface, ST_INTERFACE);
 397       match ("intent", gfc_match_intent, ST_ATTR_DECL);
 398       match ("intrinsic", gfc_match_intrinsic, ST_ATTR_DECL);
 399       break;
 400
 401     case 'm':
 402       match ("module% procedure% ", gfc_match_modproc, ST_MODULE_PROC);
 403       match ("module", gfc_match_module, ST_MODULE);
 404       break;
 405
 406     case 'n':
 407       match ("nullify", gfc_match_nullify, ST_NULLIFY);
 408       match ("namelist", gfc_match_namelist, ST_NAMELIST);
 409       break;
 410
 411     case 'o':
 412       match ("open", gfc_match_open, ST_OPEN);
 413       match ("optional", gfc_match_optional, ST_ATTR_DECL);
 414       break;
 415
 416     case 'p':
 417       match ("print", gfc_match_print, ST_WRITE);
 418       match ("parameter", gfc_match_parameter, ST_PARAMETER);
 419       match ("pause", gfc_match_pause, ST_PAUSE);
 420       match ("pointer", gfc_match_pointer, ST_ATTR_DECL);
 421       if (gfc_match_private (&st) == MATCH_YES)
 422         return st;
 423       match ("procedure", gfc_match_procedure, ST_PROCEDURE);
 424       match ("program", gfc_match_program, ST_PROGRAM);
 425       if (gfc_match_public (&st) == MATCH_YES)
 426         return st;
 427       match ("protected", gfc_match_protected, ST_ATTR_DECL);
 428       break;
 429
 430     case 'r':
 431       match ("read", gfc_match_read, ST_READ);
 432       match ("return", gfc_match_return, ST_RETURN);
 433       match ("rewind", gfc_match_rewind, ST_REWIND);
 434       break;
 435
 436     case 's':
 437       match ("sequence", gfc_match_eos, ST_SEQUENCE);
 438       match ("stop", gfc_match_stop, ST_STOP);
 439       match ("save", gfc_match_save, ST_ATTR_DECL);
 440       match ("sync all", gfc_match_sync_all, ST_SYNC_ALL);
 441       match ("sync images", gfc_match_sync_images, ST_SYNC_IMAGES);
 442       match ("sync memory", gfc_match_sync_memory, ST_SYNC_MEMORY);
 443       break;
 444
 445     case 't':
 446       match ("target", gfc_match_target, ST_ATTR_DECL);
 447       match ("type", gfc_match_derived_decl, ST_DERIVED_DECL);
 448       match ("type is", gfc_match_type_is, ST_TYPE_IS);
 449       break;
 450
 451     case 'u':
 452       match ("use", gfc_match_use, ST_USE);
 453       break;
 454
 455     case 'v':
 456       match ("value", gfc_match_value, ST_ATTR_DECL);
 457       match ("volatile", gfc_match_volatile, ST_ATTR_DECL);
 458       break;
 459
 460     case 'w':
 461       match ("wait", gfc_match_wait, ST_WAIT);
 462       match ("write", gfc_match_write, ST_WRITE);
 463       break;
 464     }
 465
 466   /* All else has failed, so give up.  See if any of the matchers has
 467      stored an error message of some sort.  */
 468
 469   if (gfc_error_check () == 0)
 470     gfc_error_now ("Unclassifiable statement at %C");
 471
 472   reject_statement ();
 473
 474   gfc_error_recovery ();
 475
 476   return ST_NONE;
 477 }
 478
 479 static gfc_statement
 480 decode_omp_directive (void)
 481 {
 482   locus old_locus;
 483   char c;
 484
 485   gfc_enforce_clean_symbol_state ();
 486
 487   gfc_clear_error ();   /* Clear any pending errors.  */
 488   gfc_clear_warning (); /* Clear any pending warnings.  */
 489
 490   if (gfc_pure (NULL))
 491     {
 492       gfc_error_now ("OpenMP directives at %C may not appear in PURE "
 493                      "or ELEMENTAL procedures");
 494       gfc_error_recovery ();
 495       return ST_NONE;
 496     }
 497
 498   old_locus = gfc_current_locus;
 499
 500   /* General OpenMP directive matching: Instead of testing every possible
 501      statement, we eliminate most possibilities by peeking at the
 502      first character.  */
 503
 504   c = gfc_peek_ascii_char ();
 505
 506   switch (c)
 507     {
 508     case 'a':
 509       match ("atomic", gfc_match_omp_atomic, ST_OMP_ATOMIC);
 510       break;
 511     case 'b':
 512       match ("barrier", gfc_match_omp_barrier, ST_OMP_BARRIER);
 513       break;
 514     case 'c':
 515       match ("critical", gfc_match_omp_critical, ST_OMP_CRITICAL);
 516       break;
 517     case 'd':
 518       match ("do", gfc_match_omp_do, ST_OMP_DO);
 519       break;
 520     case 'e':
 521       match ("end critical", gfc_match_omp_critical, ST_OMP_END_CRITICAL);
 522       match ("end do", gfc_match_omp_end_nowait, ST_OMP_END_DO);
 523       match ("end master", gfc_match_omp_eos, ST_OMP_END_MASTER);
 524       match ("end ordered", gfc_match_omp_eos, ST_OMP_END_ORDERED);
 525       match ("end parallel do", gfc_match_omp_eos, ST_OMP_END_PARALLEL_DO);
 526       match ("end parallel sections", gfc_match_omp_eos,
 527              ST_OMP_END_PARALLEL_SECTIONS);
 528       match ("end parallel workshare", gfc_match_omp_eos,
 529              ST_OMP_END_PARALLEL_WORKSHARE);
 530       match ("end parallel", gfc_match_omp_eos, ST_OMP_END_PARALLEL);
 531       match ("end sections", gfc_match_omp_end_nowait, ST_OMP_END_SECTIONS);
 532       match ("end single", gfc_match_omp_end_single, ST_OMP_END_SINGLE);
 533       match ("end task", gfc_match_omp_eos, ST_OMP_END_TASK);
 534       match ("end workshare", gfc_match_omp_end_nowait,
 535              ST_OMP_END_WORKSHARE);
 536       break;
 537     case 'f':
 538       match ("flush", gfc_match_omp_flush, ST_OMP_FLUSH);
 539       break;
 540     case 'm':
 541       match ("master", gfc_match_omp_master, ST_OMP_MASTER);
 542       break;
 543     case 'o':
 544       match ("ordered", gfc_match_omp_ordered, ST_OMP_ORDERED);
 545       break;
 546     case 'p':
 547       match ("parallel do", gfc_match_omp_parallel_do, ST_OMP_PARALLEL_DO);
 548       match ("parallel sections", gfc_match_omp_parallel_sections,
 549              ST_OMP_PARALLEL_SECTIONS);
 550       match ("parallel workshare", gfc_match_omp_parallel_workshare,
 551              ST_OMP_PARALLEL_WORKSHARE);
 552       match ("parallel", gfc_match_omp_parallel, ST_OMP_PARALLEL);
 553       break;
 554     case 's':
 555       match ("sections", gfc_match_omp_sections, ST_OMP_SECTIONS);
 556       match ("section", gfc_match_omp_eos, ST_OMP_SECTION);
 557       match ("single", gfc_match_omp_single, ST_OMP_SINGLE);
 558       break;
 559     case 't':
 560       match ("task", gfc_match_omp_task, ST_OMP_TASK);
 561       match ("taskwait", gfc_match_omp_taskwait, ST_OMP_TASKWAIT);
 562       match ("threadprivate", gfc_match_omp_threadprivate,
 563              ST_OMP_THREADPRIVATE);
 564     case 'w':
 565       match ("workshare", gfc_match_omp_workshare, ST_OMP_WORKSHARE);
 566       break;
 567     }
 568
 569   /* All else has failed, so give up.  See if any of the matchers has
 570      stored an error message of some sort.  */
 571
 572   if (gfc_error_check () == 0)
 573     gfc_error_now ("Unclassifiable OpenMP directive at %C");
 574
 575   reject_statement ();
 576
 577   gfc_error_recovery ();
 578
 579   return ST_NONE;
 580 }
 581
 582 static gfc_statement
 583 decode_gcc_attribute (void)
 584 {
 585   locus old_locus;
 586
 587   gfc_enforce_clean_symbol_state ();
 588
 589   gfc_clear_error ();   /* Clear any pending errors.  */
 590   gfc_clear_warning (); /* Clear any pending warnings.  */
 591   old_locus = gfc_current_locus;
 592
 593   match ("attributes", gfc_match_gcc_attributes, ST_ATTR_DECL);
 594
 595   /* All else has failed, so give up.  See if any of the matchers has
 596      stored an error message of some sort.  */
 597
 598   if (gfc_error_check () == 0)
 599     gfc_error_now ("Unclassifiable GCC directive at %C");
 600
 601   reject_statement ();
 602
 603   gfc_error_recovery ();
 604
 605   return ST_NONE;
 606 }
 607
 608 #undef match
 609
 610
 611 /* Get the next statement in free form source.  */
 612
 613 static gfc_statement
 614 next_free (void)
 615 {
 616   match m;
 617   int i, cnt, at_bol;
 618   char c;
 619
 620   at_bol = gfc_at_bol ();
 621   gfc_gobble_whitespace ();
 622
 623   c = gfc_peek_ascii_char ();
 624
 625   if (ISDIGIT (c))
 626     {
 627       char d;
 628
 629       /* Found a statement label?  */
 630       m = gfc_match_st_label (&gfc_statement_label);
 631
 632       d = gfc_peek_ascii_char ();
 633       if (m != MATCH_YES || !gfc_is_whitespace (d))
 634         {
 635           gfc_match_small_literal_int (&i, &cnt);
 636
 637           if (cnt > 5)
 638             gfc_error_now ("Too many digits in statement label at %C");
 639
 640           if (i == 0)
 641             gfc_error_now ("Zero is not a valid statement label at %C");
 642
 643           do
 644             c = gfc_next_ascii_char ();
 645           while (ISDIGIT(c));
 646
 647           if (!gfc_is_whitespace (c))
 648             gfc_error_now ("Non-numeric character in statement label at %C");
 649
 650           return ST_NONE;
 651         }
 652       else
 653         {
 654           label_locus = gfc_current_locus;
 655
 656           gfc_gobble_whitespace ();
 657
 658           if (at_bol && gfc_peek_ascii_char () == ';')
 659             {
 660               gfc_error_now ("Semicolon at %C needs to be preceded by "
 661                              "statement");
 662               gfc_next_ascii_char (); /* Eat up the semicolon.  */
 663               return ST_NONE;
 664             }
 665
 666           if (gfc_match_eos () == MATCH_YES)
 667             {
 668               gfc_warning_now ("Ignoring statement label in empty statement "
 669                                "at %L", &label_locus);
 670               gfc_free_st_label (gfc_statement_label);
 671               gfc_statement_label = NULL;
 672               return ST_NONE;
 673             }
 674         }
 675     }
 676   else if (c == '!')
 677     {
 678       /* Comments have already been skipped by the time we get here,
 679          except for GCC attributes and OpenMP directives.  */
 680
 681       gfc_next_ascii_char (); /* Eat up the exclamation sign.  */
 682       c = gfc_peek_ascii_char ();
 683
 684       if (c == 'g')
 685         {
 686           int i;
 687
 688           c = gfc_next_ascii_char ();
 689           for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
 690             gcc_assert (c == "gcc$"[i]);
 691
 692           gfc_gobble_whitespace ();
 693           return decode_gcc_attribute ();
 694
 695         }
 696       else if (c == '$' && gfc_option.flag_openmp)
 697         {
 698           int i;
 699
 700           c = gfc_next_ascii_char ();
 701           for (i = 0; i < 4; i++, c = gfc_next_ascii_char ())
 702             gcc_assert (c == "$omp"[i]);
 703
 704           gcc_assert (c == ' ' || c == '\t');
 705           gfc_gobble_whitespace ();
 706           return decode_omp_directive ();
 707         }
 708
 709       gcc_unreachable ();
 710     }
 711
 712   if (at_bol && c == ';')
 713     {
 714       if (!(gfc_option.allow_std & GFC_STD_F2008))
 715         gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
 716                        "statement");
 717       gfc_next_ascii_char (); /* Eat up the semicolon.  */
 718       return ST_NONE;
 719     }
 720
 721   return decode_statement ();
 722 }
 723
 724
 725 /* Get the next statement in fixed-form source.  */
 726
 727 static gfc_statement
 728 next_fixed (void)
 729 {
 730   int label, digit_flag, i;
 731   locus loc;
 732   gfc_char_t c;
 733
 734   if (!gfc_at_bol ())
 735     return decode_statement ();
 736
 737   /* Skip past the current label field, parsing a statement label if
 738      one is there.  This is a weird number parser, since the number is
 739      contained within five columns and can have any kind of embedded
 740      spaces.  We also check for characters that make the rest of the
 741      line a comment.  */
 742
 743   label = 0;
 744   digit_flag = 0;
 745
 746   for (i = 0; i < 5; i++)
 747     {
 748       c = gfc_next_char_literal (0);
 749
 750       switch (c)
 751         {
 752         case ' ':
 753           break;
 754
 755         case '0':
 756         case '1':
 757         case '2':
 758         case '3':
 759         case '4':
 760         case '5':
 761         case '6':
 762         case '7':
 763         case '8':
 764         case '9':
 765           label = label * 10 + ((unsigned char) c - '0');
 766           label_locus = gfc_current_locus;
 767           digit_flag = 1;
 768           break;
 769
 770           /* Comments have already been skipped by the time we get
 771              here, except for GCC attributes and OpenMP directives.  */
 772
 773         case '*':
 774           c = gfc_next_char_literal (0);
 775
 776           if (TOLOWER (c) == 'g')
 777             {
 778               for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
 779                 gcc_assert (TOLOWER (c) == "gcc$"[i]);
 780
 781               return decode_gcc_attribute ();
 782             }
 783           else if (c == '$' && gfc_option.flag_openmp)
 784             {
 785               for (i = 0; i < 4; i++, c = gfc_next_char_literal (0))
 786                 gcc_assert ((char) gfc_wide_tolower (c) == "$omp"[i]);
 787
 788               if (c != ' ' && c != '0')
 789                 {
 790                   gfc_buffer_error (0);
 791                   gfc_error ("Bad continuation line at %C");
 792                   return ST_NONE;
 793                 }
 794
 795               return decode_omp_directive ();
 796             }
 797           /* FALLTHROUGH */
 798
 799           /* Comments have already been skipped by the time we get
 800              here so don't bother checking for them.  */
 801
 802         default:
 803           gfc_buffer_error (0);
 804           gfc_error ("Non-numeric character in statement label at %C");
 805           return ST_NONE;
 806         }
 807     }
 808
 809   if (digit_flag)
 810     {
 811       if (label == 0)
 812         gfc_warning_now ("Zero is not a valid statement label at %C");
 813       else
 814         {
 815           /* We've found a valid statement label.  */
 816           gfc_statement_label = gfc_get_st_label (label);
 817         }
 818     }
 819
 820   /* Since this line starts a statement, it cannot be a continuation
 821      of a previous statement.  If we see something here besides a
 822      space or zero, it must be a bad continuation line.  */
 823
 824   c = gfc_next_char_literal (0);
 825   if (c == '\n')
 826     goto blank_line;
 827
 828   if (c != ' ' && c != '0')
 829     {
 830       gfc_buffer_error (0);
 831       gfc_error ("Bad continuation line at %C");
 832       return ST_NONE;
 833     }
 834
 835   /* Now that we've taken care of the statement label columns, we have
 836      to make sure that the first nonblank character is not a '!'.  If
 837      it is, the rest of the line is a comment.  */
 838
 839   do
 840     {
 841       loc = gfc_current_locus;
 842       c = gfc_next_char_literal (0);
 843     }
 844   while (gfc_is_whitespace (c));
 845
 846   if (c == '!')
 847     goto blank_line;
 848   gfc_current_locus = loc;
 849
 850   if (c == ';')
 851     {
 852       if (digit_flag)
 853         gfc_error_now ("Semicolon at %C needs to be preceded by statement");
 854       else if (!(gfc_option.allow_std & GFC_STD_F2008))
 855         gfc_error_now ("Fortran 2008: Semicolon at %C without preceding "
 856                        "statement");
 857       return ST_NONE;
 858     }
 859
 860   if (gfc_match_eos () == MATCH_YES)
 861     goto blank_line;
 862
 863   /* At this point, we've got a nonblank statement to parse.  */
 864   return decode_statement ();
 865
 866 blank_line:
 867   if (digit_flag)
 868     gfc_warning_now ("Ignoring statement label in empty statement at %L",
 869                      &label_locus);
 870
 871   gfc_current_locus.lb->truncated = 0;
 872   gfc_advance_line ();
 873   return ST_NONE;
 874 }
 875
 876
 877 /* Return the next non-ST_NONE statement to the caller.  We also worry
 878    about including files and the ends of include files at this stage.  */
 879
 880 static gfc_statement
 881 next_statement (void)
 882 {
 883   gfc_statement st;
 884   locus old_locus;
 885
 886   gfc_enforce_clean_symbol_state ();
 887
 888   gfc_new_block = NULL;
 889
 890   gfc_current_ns->old_cl_list = gfc_current_ns->cl_list;
 891   gfc_current_ns->old_equiv = gfc_current_ns->equiv;
 892   for (;;)
 893     {
 894       gfc_statement_label = NULL;
 895       gfc_buffer_error (1);
 896
 897       if (gfc_at_eol ())
 898         gfc_advance_line ();
 899
 900       gfc_skip_comments ();
 901
 902       if (gfc_at_end ())
 903         {
 904           st = ST_NONE;
 905           break;
 906         }
 907
 908       if (gfc_define_undef_line ())
 909         continue;
 910
 911       old_locus = gfc_current_locus;
 912
 913       st = (gfc_current_form == FORM_FIXED) ? next_fixed () : next_free ();
 914
 915       if (st != ST_NONE)
 916         break;
 917     }
 918
 919   gfc_buffer_error (0);
 920
 921   if (st == ST_GET_FCN_CHARACTERISTICS && gfc_statement_label != NULL)
 922     {
 923       gfc_free_st_label (gfc_statement_label);
 924       gfc_statement_label = NULL;
 925       gfc_current_locus = old_locus;
 926     }
 927
 928   if (st != ST_NONE)
 929     check_statement_label (st);
 930
 931   return st;
 932 }
 933
 934
 935 /****************************** Parser ***********************************/
 936
 937 /* The parser subroutines are of type 'try' that fail if the file ends
 938    unexpectedly.  */
 939
 940 /* Macros that expand to case-labels for various classes of
 941    statements.  Start with executable statements that directly do
 942    things.  */
 943
 944 #define case_executable case ST_ALLOCATE: case ST_BACKSPACE: case ST_CALL: \
 945   case ST_CLOSE: case ST_CONTINUE: case ST_DEALLOCATE: case ST_END_FILE: \
 946   case ST_GOTO: case ST_INQUIRE: case ST_NULLIFY: case ST_OPEN: \
 947   case ST_READ: case ST_RETURN: case ST_REWIND: case ST_SIMPLE_IF: \
 948   case ST_PAUSE: case ST_STOP: case ST_WAIT: case ST_WRITE: \
 949   case ST_POINTER_ASSIGNMENT: case ST_EXIT: case ST_CYCLE: \
 950   case ST_ASSIGNMENT: case ST_ARITHMETIC_IF: case ST_WHERE: case ST_FORALL: \
 951   case ST_LABEL_ASSIGNMENT: case ST_FLUSH: case ST_OMP_FLUSH: \
 952   case ST_OMP_BARRIER: case ST_OMP_TASKWAIT: case ST_ERROR_STOP: \
 953   case ST_SYNC_ALL: case ST_SYNC_IMAGES: case ST_SYNC_MEMORY
 954
 955 /* Statements that mark other executable statements.  */
 956
 957 #define case_exec_markers case ST_DO: case ST_FORALL_BLOCK: \
 958   case ST_IF_BLOCK: case ST_BLOCK: case ST_ASSOCIATE: \
 959   case ST_WHERE_BLOCK: case ST_SELECT_CASE: case ST_SELECT_TYPE: \
 960   case ST_OMP_PARALLEL: \
 961   case ST_OMP_PARALLEL_SECTIONS: case ST_OMP_SECTIONS: case ST_OMP_ORDERED: \
 962   case ST_OMP_CRITICAL: case ST_OMP_MASTER: case ST_OMP_SINGLE: \
 963   case ST_OMP_DO: case ST_OMP_PARALLEL_DO: case ST_OMP_ATOMIC: \
 964   case ST_OMP_WORKSHARE: case ST_OMP_PARALLEL_WORKSHARE: \
 965   case ST_OMP_TASK: case ST_CRITICAL
 966
 967 /* Declaration statements */
 968
 969 #define case_decl case ST_ATTR_DECL: case ST_COMMON: case ST_DATA_DECL: \
 970   case ST_EQUIVALENCE: case ST_NAMELIST: case ST_STATEMENT_FUNCTION: \
 971   case ST_TYPE: case ST_INTERFACE: case ST_OMP_THREADPRIVATE: \
 972   case ST_PROCEDURE
 973
 974 /* Block end statements.  Errors associated with interchanging these
 975    are detected in gfc_match_end().  */
 976
 977 #define case_end case ST_END_BLOCK_DATA: case ST_END_FUNCTION: \
 978                  case ST_END_PROGRAM: case ST_END_SUBROUTINE: \
 979                  case ST_END_BLOCK: case ST_END_ASSOCIATE
 980
 981
 982 /* Push a new state onto the stack.  */
 983
 984 static void
 985 push_state (gfc_state_data *p, gfc_compile_state new_state, gfc_symbol *sym)
 986 {
 987   p->state = new_state;
 988   p->previous = gfc_state_stack;
 989   p->sym = sym;
 990   p->head = p->tail = NULL;
 991   p->do_variable = NULL;
 992   gfc_state_stack = p;
 993 }
 994
 995
 996 /* Pop the current state.  */
 997 static void
 998 pop_state (void)
 999 {
1000   gfc_state_stack = gfc_state_stack->previous;
1001 }
1002
1003
1004 /* Try to find the given state in the state stack.  */
1005
1006 gfc_try
1007 gfc_find_state (gfc_compile_state state)
1008 {
1009   gfc_state_data *p;
1010
1011   for (p = gfc_state_stack; p; p = p->previous)
1012     if (p->state == state)
1013       break;
1014
1015   return (p == NULL) ? FAILURE : SUCCESS;
1016 }
1017
1018
1019 /* Starts a new level in the statement list.  */
1020
1021 static gfc_code *
1022 new_level (gfc_code *q)
1023 {
1024   gfc_code *p;
1025
1026   p = q->block = gfc_get_code ();
1027
1028   gfc_state_stack->head = gfc_state_stack->tail = p;
1029
1030   return p;
1031 }
1032
1033
1034 /* Add the current new_st code structure and adds it to the current
1035    program unit.  As a side-effect, it zeroes the new_st.  */
1036
1037 static gfc_code *
1038 add_statement (void)
1039 {
1040   gfc_code *p;
1041
1042   p = gfc_get_code ();
1043   *p = new_st;
1044
1045   p->loc = gfc_current_locus;
1046
1047   if (gfc_state_stack->head == NULL)
1048     gfc_state_stack->head = p;
1049   else
1050     gfc_state_stack->tail->next = p;
1051
1052   while (p->next != NULL)
1053     p = p->next;
1054
1055   gfc_state_stack->tail = p;
1056
1057   gfc_clear_new_st ();
1058
1059   return p;
1060 }
1061
1062
1063 /* Frees everything associated with the current statement.  */
1064
1065 static void
1066 undo_new_statement (void)
1067 {
1068   gfc_free_statements (new_st.block);
1069   gfc_free_statements (new_st.next);
1070   gfc_free_statement (&new_st);
1071   gfc_clear_new_st ();
1072 }
1073
1074
1075 /* If the current statement has a statement label, make sure that it
1076    is allowed to, or should have one.  */
1077
1078 static void
1079 check_statement_label (gfc_statement st)
1080 {
1081   gfc_sl_type type;
1082
1083   if (gfc_statement_label == NULL)
1084     {
1085       if (st == ST_FORMAT)
1086         gfc_error ("FORMAT statement at %L does not have a statement label",
1087                    &new_st.loc);
1088       return;
1089     }
1090
1091   switch (st)
1092     {
1093     case ST_END_PROGRAM:
1094     case ST_END_FUNCTION:
1095     case ST_END_SUBROUTINE:
1096     case ST_ENDDO:
1097     case ST_ENDIF:
1098     case ST_END_SELECT:
1099     case ST_END_CRITICAL:
1100     case_executable:
1101     case_exec_markers:
1102       type = ST_LABEL_TARGET;
1103       break;
1104
1105     case ST_FORMAT:
1106       type = ST_LABEL_FORMAT;
1107       break;
1108
1109       /* Statement labels are not restricted from appearing on a
1110          particular line.  However, there are plenty of situations
1111          where the resulting label can't be referenced.  */
1112
1113     default:
1114       type = ST_LABEL_BAD_TARGET;
1115       break;
1116     }
1117
1118   gfc_define_st_label (gfc_statement_label, type, &label_locus);
1119
1120   new_st.here = gfc_statement_label;
1121 }
1122
1123
1124 /* Figures out what the enclosing program unit is.  This will be a
1125    function, subroutine, program, block data or module.  */
1126
1127 gfc_state_data *
1128 gfc_enclosing_unit (gfc_compile_state * result)
1129 {
1130   gfc_state_data *p;
1131
1132   for (p = gfc_state_stack; p; p = p->previous)
1133     if (p->state == COMP_FUNCTION || p->state == COMP_SUBROUTINE
1134         || p->state == COMP_MODULE || p->state == COMP_BLOCK_DATA
1135         || p->state == COMP_PROGRAM)
1136       {
1137
1138         if (result != NULL)
1139           *result = p->state;
1140         return p;
1141       }
1142
1143   if (result != NULL)
1144     *result = COMP_PROGRAM;
1145   return NULL;
1146 }
1147
1148
1149 /* Translate a statement enum to a string.  */
1150
1151 const char *
1152 gfc_ascii_statement (gfc_statement st)
1153 {
1154   const char *p;
1155
1156   switch (st)
1157     {
1158     case ST_ARITHMETIC_IF:
1159       p = _("arithmetic IF");
1160       break;
1161     case ST_ALLOCATE:
1162       p = "ALLOCATE";
1163       break;
1164     case ST_ASSOCIATE:
1165       p = "ASSOCIATE";
1166       break;
1167     case ST_ATTR_DECL:
1168       p = _("attribute declaration");
1169       break;
1170     case ST_BACKSPACE:
1171       p = "BACKSPACE";
1172       break;
1173     case ST_BLOCK:
1174       p = "BLOCK";
1175       break;
1176     case ST_BLOCK_DATA:
1177       p = "BLOCK DATA";
1178       break;
1179     case ST_CALL:
1180       p = "CALL";
1181       break;
1182     case ST_CASE:
1183       p = "CASE";
1184       break;
1185     case ST_CLOSE:
1186       p = "CLOSE";
1187       break;
1188     case ST_COMMON:
1189       p = "COMMON";
1190       break;
1191     case ST_CONTINUE:
1192       p = "CONTINUE";
1193       break;
1194     case ST_CONTAINS:
1195       p = "CONTAINS";
1196       break;
1197     case ST_CRITICAL:
1198       p = "CRITICAL";
1199       break;
1200     case ST_CYCLE:
1201       p = "CYCLE";
1202       break;
1203     case ST_DATA_DECL:
1204       p = _("data declaration");
1205       break;
1206     case ST_DATA:
1207       p = "DATA";
1208       break;
1209     case ST_DEALLOCATE:
1210       p = "DEALLOCATE";
1211       break;
1212     case ST_DERIVED_DECL:
1213       p = _("derived type declaration");
1214       break;
1215     case ST_DO:
1216       p = "DO";
1217       break;
1218     case ST_ELSE:
1219       p = "ELSE";
1220       break;
1221     case ST_ELSEIF:
1222       p = "ELSE IF";
1223       break;
1224     case ST_ELSEWHERE:
1225       p = "ELSEWHERE";
1226       break;
1227     case ST_END_ASSOCIATE:
1228       p = "END ASSOCIATE";
1229       break;
1230     case ST_END_BLOCK:
1231       p = "END BLOCK";
1232       break;
1233     case ST_END_BLOCK_DATA:
1234       p = "END BLOCK DATA";
1235       break;
1236     case ST_END_CRITICAL:
1237       p = "END CRITICAL";
1238       break;
1239     case ST_ENDDO:
1240       p = "END DO";
1241       break;
1242     case ST_END_FILE:
1243       p = "END FILE";
1244       break;
1245     case ST_END_FORALL:
1246       p = "END FORALL";
1247       break;
1248     case ST_END_FUNCTION:
1249       p = "END FUNCTION";
1250       break;
1251     case ST_ENDIF:
1252       p = "END IF";
1253       break;
1254     case ST_END_INTERFACE:
1255       p = "END INTERFACE";
1256       break;
1257     case ST_END_MODULE:
1258       p = "END MODULE";
1259       break;
1260     case ST_END_PROGRAM:
1261       p = "END PROGRAM";
1262       break;
1263     case ST_END_SELECT:
1264       p = "END SELECT";
1265       break;
1266     case ST_END_SUBROUTINE:
1267       p = "END SUBROUTINE";
1268       break;
1269     case ST_END_WHERE:
1270       p = "END WHERE";
1271       break;
1272     case ST_END_TYPE:
1273       p = "END TYPE";
1274       break;
1275     case ST_ENTRY:
1276       p = "ENTRY";
1277       break;
1278     case ST_EQUIVALENCE:
1279       p = "EQUIVALENCE";
1280       break;
1281     case ST_ERROR_STOP:
1282       p = "ERROR STOP";
1283       break;
1284     case ST_EXIT:
1285       p = "EXIT";
1286       break;
1287     case ST_FLUSH:
1288       p = "FLUSH";
1289       break;
1290     case ST_FORALL_BLOCK:       /* Fall through */
1291     case ST_FORALL:
1292       p = "FORALL";
1293       break;
1294     case ST_FORMAT:
1295       p = "FORMAT";
1296       break;
1297     case ST_FUNCTION:
1298       p = "FUNCTION";
1299       break;
1300     case ST_GENERIC:
1301       p = "GENERIC";
1302       break;
1303     case ST_GOTO:
1304       p = "GOTO";
1305       break;
1306     case ST_IF_BLOCK:
1307       p = _("block IF");
1308       break;
1309     case ST_IMPLICIT:
1310       p = "IMPLICIT";
1311       break;
1312     case ST_IMPLICIT_NONE:
1313       p = "IMPLICIT NONE";
1314       break;
1315     case ST_IMPLIED_ENDDO:
1316       p = _("implied END DO");
1317       break;
1318     case ST_IMPORT:
1319       p = "IMPORT";
1320       break;
1321     case ST_INQUIRE:
1322       p = "INQUIRE";
1323       break;
1324     case ST_INTERFACE:
1325       p = "INTERFACE";
1326       break;
1327     case ST_PARAMETER:
1328       p = "PARAMETER";
1329       break;
1330     case ST_PRIVATE:
1331       p = "PRIVATE";
1332       break;
1333     case ST_PUBLIC:
1334       p = "PUBLIC";
1335       break;
1336     case ST_MODULE:
1337       p = "MODULE";
1338       break;
1339     case ST_PAUSE:
1340       p = "PAUSE";
1341       break;
1342     case ST_MODULE_PROC:
1343       p = "MODULE PROCEDURE";
1344       break;
1345     case ST_NAMELIST:
1346       p = "NAMELIST";
1347       break;
1348     case ST_NULLIFY:
1349       p = "NULLIFY";
1350       break;
1351     case ST_OPEN:
1352       p = "OPEN";
1353       break;
1354     case ST_PROGRAM:
1355       p = "PROGRAM";
1356       break;
1357     case ST_PROCEDURE:
1358       p = "PROCEDURE";
1359       break;
1360     case ST_READ:
1361       p = "READ";
1362       break;
1363     case ST_RETURN:
1364       p = "RETURN";
1365       break;
1366     case ST_REWIND:
1367       p = "REWIND";
1368       break;
1369     case ST_STOP:
1370       p = "STOP";
1371       break;
1372     case ST_SYNC_ALL:
1373       p = "SYNC ALL";
1374       break;
1375     case ST_SYNC_IMAGES:
1376       p = "SYNC IMAGES";
1377       break;
1378     case ST_SYNC_MEMORY:
1379       p = "SYNC MEMORY";
1380       break;
1381     case ST_SUBROUTINE:
1382       p = "SUBROUTINE";
1383       break;
1384     case ST_TYPE:
1385       p = "TYPE";
1386       break;
1387     case ST_USE:
1388       p = "USE";
1389       break;
1390     case ST_WHERE_BLOCK:        /* Fall through */
1391     case ST_WHERE:
1392       p = "WHERE";
1393       break;
1394     case ST_WAIT:
1395       p = "WAIT";
1396       break;
1397     case ST_WRITE:
1398       p = "WRITE";
1399       break;
1400     case ST_ASSIGNMENT:
1401       p = _("assignment");
1402       break;
1403     case ST_POINTER_ASSIGNMENT:
1404       p = _("pointer assignment");
1405       break;
1406     case ST_SELECT_CASE:
1407       p = "SELECT CASE";
1408       break;
1409     case ST_SELECT_TYPE:
1410       p = "SELECT TYPE";
1411       break;
1412     case ST_TYPE_IS:
1413       p = "TYPE IS";
1414       break;
1415     case ST_CLASS_IS:
1416       p = "CLASS IS";
1417       break;
1418     case ST_SEQUENCE:
1419       p = "SEQUENCE";
1420       break;
1421     case ST_SIMPLE_IF:
1422       p = _("simple IF");
1423       break;
1424     case ST_STATEMENT_FUNCTION:
1425       p = "STATEMENT FUNCTION";
1426       break;
1427     case ST_LABEL_ASSIGNMENT:
1428       p = "LABEL ASSIGNMENT";
1429       break;
1430     case ST_ENUM:
1431       p = "ENUM DEFINITION";
1432       break;
1433     case ST_ENUMERATOR:
1434       p = "ENUMERATOR DEFINITION";
1435       break;
1436     case ST_END_ENUM:
1437       p = "END ENUM";
1438       break;
1439     case ST_OMP_ATOMIC:
1440       p = "!$OMP ATOMIC";
1441       break;
1442     case ST_OMP_BARRIER:
1443       p = "!$OMP BARRIER";
1444       break;
1445     case ST_OMP_CRITICAL:
1446       p = "!$OMP CRITICAL";
1447       break;
1448     case ST_OMP_DO:
1449       p = "!$OMP DO";
1450       break;
1451     case ST_OMP_END_CRITICAL:
1452       p = "!$OMP END CRITICAL";
1453       break;
1454     case ST_OMP_END_DO:
1455       p = "!$OMP END DO";
1456       break;
1457     case ST_OMP_END_MASTER:
1458       p = "!$OMP END MASTER";
1459       break;
1460     case ST_OMP_END_ORDERED:
1461       p = "!$OMP END ORDERED";
1462       break;
1463     case ST_OMP_END_PARALLEL:
1464       p = "!$OMP END PARALLEL";
1465       break;
1466     case ST_OMP_END_PARALLEL_DO:
1467       p = "!$OMP END PARALLEL DO";
1468       break;
1469     case ST_OMP_END_PARALLEL_SECTIONS:
1470       p = "!$OMP END PARALLEL SECTIONS";
1471       break;
1472     case ST_OMP_END_PARALLEL_WORKSHARE:
1473       p = "!$OMP END PARALLEL WORKSHARE";
1474       break;
1475     case ST_OMP_END_SECTIONS:
1476       p = "!$OMP END SECTIONS";
1477       break;
1478     case ST_OMP_END_SINGLE:
1479       p = "!$OMP END SINGLE";
1480       break;
1481     case ST_OMP_END_TASK:
1482       p = "!$OMP END TASK";
1483       break;
1484     case ST_OMP_END_WORKSHARE:
1485       p = "!$OMP END WORKSHARE";
1486       break;
1487     case ST_OMP_FLUSH:
1488       p = "!$OMP FLUSH";
1489       break;
1490     case ST_OMP_MASTER:
1491       p = "!$OMP MASTER";
1492       break;
1493     case ST_OMP_ORDERED:
1494       p = "!$OMP ORDERED";
1495       break;
1496     case ST_OMP_PARALLEL:
1497       p = "!$OMP PARALLEL";
1498       break;
1499     case ST_OMP_PARALLEL_DO:
1500       p = "!$OMP PARALLEL DO";
1501       break;
1502     case ST_OMP_PARALLEL_SECTIONS:
1503       p = "!$OMP PARALLEL SECTIONS";
1504       break;
1505     case ST_OMP_PARALLEL_WORKSHARE:
1506       p = "!$OMP PARALLEL WORKSHARE";
1507       break;
1508     case ST_OMP_SECTIONS:
1509       p = "!$OMP SECTIONS";
1510       break;
1511     case ST_OMP_SECTION:
1512       p = "!$OMP SECTION";
1513       break;
1514     case ST_OMP_SINGLE:
1515       p = "!$OMP SINGLE";
1516       break;
1517     case ST_OMP_TASK:
1518       p = "!$OMP TASK";
1519       break;
1520     case ST_OMP_TASKWAIT:
1521       p = "!$OMP TASKWAIT";
1522       break;
1523     case ST_OMP_THREADPRIVATE:
1524       p = "!$OMP THREADPRIVATE";
1525       break;
1526     case ST_OMP_WORKSHARE:
1527       p = "!$OMP WORKSHARE";
1528       break;
1529     default:
1530       gfc_internal_error ("gfc_ascii_statement(): Bad statement code");
1531     }
1532
1533   return p;
1534 }
1535
1536
1537 /* Create a symbol for the main program and assign it to ns->proc_name.  */
1538
1539 static void
1540 main_program_symbol (gfc_namespace *ns, const char *name)
1541 {
1542   gfc_symbol *main_program;
1543   symbol_attribute attr;
1544
1545   gfc_get_symbol (name, ns, &main_program);
1546   gfc_clear_attr (&attr);
1547   attr.flavor = FL_PROGRAM;
1548   attr.proc = PROC_UNKNOWN;
1549   attr.subroutine = 1;
1550   attr.access = ACCESS_PUBLIC;
1551   attr.is_main_program = 1;
1552   main_program->attr = attr;
1553   main_program->declared_at = gfc_current_locus;
1554   ns->proc_name = main_program;
1555   gfc_commit_symbols ();
1556 }
1557
1558
1559 /* Do whatever is necessary to accept the last statement.  */
1560
1561 static void
1562 accept_statement (gfc_statement st)
1563 {
1564   switch (st)
1565     {
1566     case ST_USE:
1567       gfc_use_module ();
1568       break;
1569
1570     case ST_IMPLICIT_NONE:
1571       gfc_set_implicit_none ();
1572       break;
1573
1574     case ST_IMPLICIT:
1575       break;
1576
1577     case ST_FUNCTION:
1578     case ST_SUBROUTINE:
1579     case ST_MODULE:
1580       gfc_current_ns->proc_name = gfc_new_block;
1581       break;
1582
1583       /* If the statement is the end of a block, lay down a special code
1584          that allows a branch to the end of the block from within the
1585          construct.  IF and SELECT are treated differently from DO
1586          (where EXEC_NOP is added inside the loop) for two
1587          reasons:
1588          1. END DO has a meaning in the sense that after a GOTO to
1589             it, the loop counter must be increased.
1590          2. IF blocks and SELECT blocks can consist of multiple
1591             parallel blocks (IF ... ELSE IF ... ELSE ... END IF).
1592             Putting the label before the END IF would make the jump
1593             from, say, the ELSE IF block to the END IF illegal.  */
1594
1595     case ST_ENDIF:
1596     case ST_END_SELECT:
1597     case ST_END_CRITICAL:
1598       if (gfc_statement_label != NULL)
1599         {
1600           new_st.op = EXEC_END_BLOCK;
1601           add_statement ();
1602         }
1603       break;
1604
1605       /* The end-of-program unit statements do not get the special
1606          marker and require a statement of some sort if they are a
1607          branch target.  */
1608
1609     case ST_END_PROGRAM:
1610     case ST_END_FUNCTION:
1611     case ST_END_SUBROUTINE:
1612       if (gfc_statement_label != NULL)
1613         {
1614           new_st.op = EXEC_RETURN;
1615           add_statement ();
1616         }
1617       else
1618         {
1619           new_st.op = EXEC_END_PROCEDURE;
1620           add_statement ();
1621         }
1622
1623       break;
1624
1625     case ST_ENTRY:
1626     case_executable:
1627     case_exec_markers:
1628       add_statement ();
1629       break;
1630
1631     default:
1632       break;
1633     }
1634
1635   gfc_commit_symbols ();
1636   gfc_warning_check ();
1637   gfc_clear_new_st ();
1638 }
1639
1640
1641 /* Undo anything tentative that has been built for the current
1642    statement.  */
1643
1644 static void
1645 reject_statement (void)
1646 {
1647   /* Revert to the previous charlen chain.  */
1648   gfc_free_charlen (gfc_current_ns->cl_list, gfc_current_ns->old_cl_list);
1649   gfc_current_ns->cl_list = gfc_current_ns->old_cl_list;
1650
1651   gfc_free_equiv_until (gfc_current_ns->equiv, gfc_current_ns->old_equiv);
1652   gfc_current_ns->equiv = gfc_current_ns->old_equiv;
1653
1654   gfc_new_block = NULL;
1655   gfc_undo_symbols ();
1656   gfc_clear_warning ();
1657   undo_new_statement ();
1658 }
1659
1660
1661 /* Generic complaint about an out of order statement.  We also do
1662    whatever is necessary to clean up.  */
1663
1664 static void
1665 unexpected_statement (gfc_statement st)
1666 {
1667   gfc_error ("Unexpected %s statement at %C", gfc_ascii_statement (st));
1668
1669   reject_statement ();
1670 }
1671
1672
1673 /* Given the next statement seen by the matcher, make sure that it is
1674    in proper order with the last.  This subroutine is initialized by
1675    calling it with an argument of ST_NONE.  If there is a problem, we
1676    issue an error and return FAILURE.  Otherwise we return SUCCESS.
1677
1678    Individual parsers need to verify that the statements seen are
1679    valid before calling here, i.e., ENTRY statements are not allowed in
1680    INTERFACE blocks.  The following diagram is taken from the standard:
1681
1682             +---------------------------------------+
1683             | program  subroutine  function  module |
1684             +---------------------------------------+
1685             |            use               |
1686             +---------------------------------------+
1687             |            import         |
1688             +---------------------------------------+
1689             |   |       implicit none    |
1690             |   +-----------+------------------+
1691             |   | parameter |  implicit |
1692             |   +-----------+------------------+
1693             | format |     |  derived type    |
1694             | entry  | parameter |  interface       |
1695             |   |   data    |  specification   |
1696             |   |          |  statement func  |
1697             |   +-----------+------------------+
1698             |   |   data    |    executable    |
1699             +--------+-----------+------------------+
1700             |           contains               |
1701             +---------------------------------------+
1702             |      internal module/subprogram       |
1703             +---------------------------------------+
1704             |              end           |
1705             +---------------------------------------+
1706
1707 */
1708
1709 enum state_order
1710 {
1711   ORDER_START,
1712   ORDER_USE,
1713   ORDER_IMPORT,
1714   ORDER_IMPLICIT_NONE,
1715   ORDER_IMPLICIT,
1716   ORDER_SPEC,
1717   ORDER_EXEC
1718 };
1719
1720 typedef struct
1721 {
1722   enum state_order state;
1723   gfc_statement last_statement;
1724   locus where;
1725 }
1726 st_state;
1727
1728 static gfc_try
1729 verify_st_order (st_state *p, gfc_statement st, bool silent)
1730 {
1731
1732   switch (st)
1733     {
1734     case ST_NONE:
1735       p->state = ORDER_START;
1736       break;
1737
1738     case ST_USE:
1739       if (p->state > ORDER_USE)
1740         goto order;
1741       p->state = ORDER_USE;
1742       break;
1743
1744     case ST_IMPORT:
1745       if (p->state > ORDER_IMPORT)
1746         goto order;
1747       p->state = ORDER_IMPORT;
1748       break;
1749
1750     case ST_IMPLICIT_NONE:
1751       if (p->state > ORDER_IMPLICIT_NONE)
1752         goto order;
1753
1754       /* The '>' sign cannot be a '>=', because a FORMAT or ENTRY
1755          statement disqualifies a USE but not an IMPLICIT NONE.
1756          Duplicate IMPLICIT NONEs are caught when the implicit types
1757          are set.  */
1758
1759       p->state = ORDER_IMPLICIT_NONE;
1760       break;
1761
1762     case ST_IMPLICIT:
1763       if (p->state > ORDER_IMPLICIT)
1764         goto order;
1765       p->state = ORDER_IMPLICIT;
1766       break;
1767
1768     case ST_FORMAT:
1769     case ST_ENTRY:
1770       if (p->state < ORDER_IMPLICIT_NONE)
1771         p->state = ORDER_IMPLICIT_NONE;
1772       break;
1773
1774     case ST_PARAMETER:
1775       if (p->state >= ORDER_EXEC)
1776         goto order;
1777       if (p->state < ORDER_IMPLICIT)
1778         p->state = ORDER_IMPLICIT;
1779       break;
1780
1781     case ST_DATA:
1782       if (p->state < ORDER_SPEC)
1783         p->state = ORDER_SPEC;
1784       break;
1785
1786     case ST_PUBLIC:
1787     case ST_PRIVATE:
1788     case ST_DERIVED_DECL:
1789     case_decl:
1790       if (p->state >= ORDER_EXEC)
1791         goto order;
1792       if (p->state < ORDER_SPEC)
1793         p->state = ORDER_SPEC;
1794       break;
1795
1796     case_executable:
1797     case_exec_markers:
1798       if (p->state < ORDER_EXEC)
1799         p->state = ORDER_EXEC;
1800       break;
1801
1802     default:
1803       gfc_internal_error ("Unexpected %s statement in verify_st_order() at %C",
1804                           gfc_ascii_statement (st));
1805     }
1806
1807   /* All is well, record the statement in case we need it next time.  */
1808   p->where = gfc_current_locus;
1809   p->last_statement = st;
1810   return SUCCESS;
1811
1812 order:
1813   if (!silent)
1814     gfc_error ("%s statement at %C cannot follow %s statement at %L",
1815                gfc_ascii_statement (st),
1816                gfc_ascii_statement (p->last_statement), &p->where);
1817
1818   return FAILURE;
1819 }
1820
1821
1822 /* Handle an unexpected end of file.  This is a show-stopper...  */
1823
1824 static void unexpected_eof (void) ATTRIBUTE_NORETURN;
1825
1826 static void
1827 unexpected_eof (void)
1828 {
1829   gfc_state_data *p;
1830
1831   gfc_error ("Unexpected end of file in '%s'", gfc_source_file);
1832
1833   /* Memory cleanup.  Move to "second to last".  */
1834   for (p = gfc_state_stack; p && p->previous && p->previous->previous;
1835        p = p->previous);
1836
1837   gfc_current_ns->code = (p && p->previous) ? p->head : NULL;
1838   gfc_done_2 ();
1839
1840   longjmp (eof_buf, 1);
1841 }
1842
1843
1844 /* Parse the CONTAINS section of a derived type definition.  */
1845
1846 gfc_access gfc_typebound_default_access;
1847
1848 static bool
1849 parse_derived_contains (void)
1850 {
1851   gfc_state_data s;
1852   bool seen_private = false;
1853   bool seen_comps = false;
1854   bool error_flag = false;
1855   bool to_finish;
1856
1857   gcc_assert (gfc_current_state () == COMP_DERIVED);
1858   gcc_assert (gfc_current_block ());
1859
1860   /* Derived-types with SEQUENCE and/or BIND(C) must not have a CONTAINS
1861      section.  */
1862   if (gfc_current_block ()->attr.sequence)
1863     gfc_error ("Derived-type '%s' with SEQUENCE must not have a CONTAINS"
1864                " section at %C", gfc_current_block ()->name);
1865   if (gfc_current_block ()->attr.is_bind_c)
1866     gfc_error ("Derived-type '%s' with BIND(C) must not have a CONTAINS"
1867                " section at %C", gfc_current_block ()->name);
1868
1869   accept_statement (ST_CONTAINS);
1870   push_state (&s, COMP_DERIVED_CONTAINS, NULL);
1871
1872   gfc_typebound_default_access = ACCESS_PUBLIC;
1873
1874   to_finish = false;
1875   while (!to_finish)
1876     {
1877       gfc_statement st;
1878       st = next_statement ();
1879       switch (st)
1880         {
1881         case ST_NONE:
1882           unexpected_eof ();
1883           break;
1884
1885         case ST_DATA_DECL:
1886           gfc_error ("Components in TYPE at %C must precede CONTAINS");
1887           goto error;
1888
1889         case ST_PROCEDURE:
1890           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  Type-bound"
1891                                              " procedure at %C") == FAILURE)
1892             goto error;
1893
1894           accept_statement (ST_PROCEDURE);
1895           seen_comps = true;
1896           break;
1897
1898         case ST_GENERIC:
1899           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003:  GENERIC binding"
1900                                              " at %C") == FAILURE)
1901             goto error;
1902
1903           accept_statement (ST_GENERIC);
1904           seen_comps = true;
1905           break;
1906
1907         case ST_FINAL:
1908           if (gfc_notify_std (GFC_STD_F2003,
1909                               "Fortran 2003:  FINAL procedure declaration"
1910                               " at %C") == FAILURE)
1911             goto error;
1912
1913           accept_statement (ST_FINAL);
1914           seen_comps = true;
1915           break;
1916
1917         case ST_END_TYPE:
1918           to_finish = true;
1919
1920           if (!seen_comps
1921               && (gfc_notify_std (GFC_STD_F2008, "Fortran 2008: Derived type "
1922                                   "definition at %C with empty CONTAINS "
1923                                   "section") == FAILURE))
1924             goto error;
1925
1926           /* ST_END_TYPE is accepted by parse_derived after return.  */
1927           break;
1928
1929         case ST_PRIVATE:
1930           if (gfc_find_state (COMP_MODULE) == FAILURE)
1931             {
1932               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
1933                          "a MODULE");
1934               goto error;
1935             }
1936
1937           if (seen_comps)
1938             {
1939               gfc_error ("PRIVATE statement at %C must precede procedure"
1940                          " bindings");
1941               goto error;
1942             }
1943
1944           if (seen_private)
1945             {
1946               gfc_error ("Duplicate PRIVATE statement at %C");
1947               goto error;
1948             }
1949
1950           accept_statement (ST_PRIVATE);
1951           gfc_typebound_default_access = ACCESS_PRIVATE;
1952           seen_private = true;
1953           break;
1954
1955         case ST_SEQUENCE:
1956           gfc_error ("SEQUENCE statement at %C must precede CONTAINS");
1957           goto error;
1958
1959         case ST_CONTAINS:
1960           gfc_error ("Already inside a CONTAINS block at %C");
1961           goto error;
1962
1963         default:
1964           unexpected_statement (st);
1965           break;
1966         }
1967
1968       continue;
1969
1970 error:
1971       error_flag = true;
1972       reject_statement ();
1973     }
1974
1975   pop_state ();
1976   gcc_assert (gfc_current_state () == COMP_DERIVED);
1977
1978   return error_flag;
1979 }
1980
1981
1982 /* Parse a derived type.  */
1983
1984 static void
1985 parse_derived (void)
1986 {
1987   int compiling_type, seen_private, seen_sequence, seen_component;
1988   gfc_statement st;
1989   gfc_state_data s;
1990   gfc_symbol *sym;
1991   gfc_component *c;
1992
1993   accept_statement (ST_DERIVED_DECL);
1994   push_state (&s, COMP_DERIVED, gfc_new_block);
1995
1996   gfc_new_block->component_access = ACCESS_PUBLIC;
1997   seen_private = 0;
1998   seen_sequence = 0;
1999   seen_component = 0;
2000
2001   compiling_type = 1;
2002
2003   while (compiling_type)
2004     {
2005       st = next_statement ();
2006       switch (st)
2007         {
2008         case ST_NONE:
2009           unexpected_eof ();
2010
2011         case ST_DATA_DECL:
2012         case ST_PROCEDURE:
2013           accept_statement (st);
2014           seen_component = 1;
2015           break;
2016
2017         case ST_FINAL:
2018           gfc_error ("FINAL declaration at %C must be inside CONTAINS");
2019           break;
2020
2021         case ST_END_TYPE:
2022 endType:
2023           compiling_type = 0;
2024
2025           if (!seen_component)
2026             gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Derived type "
2027                             "definition at %C without components");
2028
2029           accept_statement (ST_END_TYPE);
2030           break;
2031
2032         case ST_PRIVATE:
2033           if (gfc_find_state (COMP_MODULE) == FAILURE)
2034             {
2035               gfc_error ("PRIVATE statement in TYPE at %C must be inside "
2036                          "a MODULE");
2037               break;
2038             }
2039
2040           if (seen_component)
2041             {
2042               gfc_error ("PRIVATE statement at %C must precede "
2043                          "structure components");
2044               break;
2045             }
2046
2047           if (seen_private)
2048             gfc_error ("Duplicate PRIVATE statement at %C");
2049
2050           s.sym->component_access = ACCESS_PRIVATE;
2051
2052           accept_statement (ST_PRIVATE);
2053           seen_private = 1;
2054           break;
2055
2056         case ST_SEQUENCE:
2057           if (seen_component)
2058             {
2059               gfc_error ("SEQUENCE statement at %C must precede "
2060                          "structure components");
2061               break;
2062             }
2063
2064           if (gfc_current_block ()->attr.sequence)
2065             gfc_warning ("SEQUENCE attribute at %C already specified in "
2066                          "TYPE statement");
2067
2068           if (seen_sequence)
2069             {
2070               gfc_error ("Duplicate SEQUENCE statement at %C");
2071             }
2072
2073           seen_sequence = 1;
2074           gfc_add_sequence (&gfc_current_block ()->attr,
2075                             gfc_current_block ()->name, NULL);
2076           break;
2077
2078         case ST_CONTAINS:
2079           gfc_notify_std (GFC_STD_F2003,
2080                           "Fortran 2003:  CONTAINS block in derived type"
2081                           " definition at %C");
2082
2083           accept_statement (ST_CONTAINS);
2084           parse_derived_contains ();
2085           goto endType;
2086
2087         default:
2088           unexpected_statement (st);
2089           break;
2090         }
2091     }
2092
2093   /* need to verify that all fields of the derived type are
2094    * interoperable with C if the type is declared to be bind(c)
2095    */
2096   sym = gfc_current_block ();
2097   for (c = sym->components; c; c = c->next)
2098     {
2099       /* Look for allocatable components.  */
2100       if (c->attr.allocatable
2101           || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.allocatable)
2102           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.alloc_comp))
2103         sym->attr.alloc_comp = 1;
2104
2105       /* Look for pointer components.  */
2106       if (c->attr.pointer
2107           || (c->ts.type == BT_CLASS && CLASS_DATA (c)->attr.class_pointer)
2108           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.pointer_comp))
2109         sym->attr.pointer_comp = 1;
2110
2111       /* Look for procedure pointer components.  */
2112       if (c->attr.proc_pointer
2113           || (c->ts.type == BT_DERIVED
2114               && c->ts.u.derived->attr.proc_pointer_comp))
2115         sym->attr.proc_pointer_comp = 1;
2116
2117       /* Looking for coarray components.  */
2118       if (c->attr.codimension
2119           || (c->attr.coarray_comp && !c->attr.pointer && !c->attr.allocatable))
2120         sym->attr.coarray_comp = 1;
2121
2122       /* Look for private components.  */
2123       if (sym->component_access == ACCESS_PRIVATE
2124           || c->attr.access == ACCESS_PRIVATE
2125           || (c->ts.type == BT_DERIVED && c->ts.u.derived->attr.private_comp))
2126         sym->attr.private_comp = 1;
2127     }
2128
2129   if (!seen_component)
2130     sym->attr.zero_comp = 1;
2131
2132   pop_state ();
2133 }
2134
2135
2136 /* Parse an ENUM.  */
2137
2138 static void
2139 parse_enum (void)
2140 {
2141   gfc_statement st;
2142   int compiling_enum;
2143   gfc_state_data s;
2144   int seen_enumerator = 0;
2145
2146   push_state (&s, COMP_ENUM, gfc_new_block);
2147
2148   compiling_enum = 1;
2149
2150   while (compiling_enum)
2151     {
2152       st = next_statement ();
2153       switch (st)
2154         {
2155         case ST_NONE:
2156           unexpected_eof ();
2157           break;
2158
2159         case ST_ENUMERATOR:
2160           seen_enumerator = 1;
2161           accept_statement (st);
2162           break;
2163
2164         case ST_END_ENUM:
2165           compiling_enum = 0;
2166           if (!seen_enumerator)
2167             gfc_error ("ENUM declaration at %C has no ENUMERATORS");
2168           accept_statement (st);
2169           break;
2170
2171         default:
2172           gfc_free_enum_history ();
2173           unexpected_statement (st);
2174           break;
2175         }
2176     }
2177   pop_state ();
2178 }
2179
2180
2181 /* Parse an interface.  We must be able to deal with the possibility
2182    of recursive interfaces.  The parse_spec() subroutine is mutually
2183    recursive with parse_interface().  */
2184
2185 static gfc_statement parse_spec (gfc_statement);
2186
2187 static void
2188 parse_interface (void)
2189 {
2190   gfc_compile_state new_state = COMP_NONE, current_state;
2191   gfc_symbol *prog_unit, *sym;
2192   gfc_interface_info save;
2193   gfc_state_data s1, s2;
2194   gfc_statement st;
2195   locus proc_locus;
2196
2197   accept_statement (ST_INTERFACE);
2198
2199   current_interface.ns = gfc_current_ns;
2200   save = current_interface;
2201
2202   sym = (current_interface.type == INTERFACE_GENERIC
2203          || current_interface.type == INTERFACE_USER_OP)
2204         ? gfc_new_block : NULL;
2205
2206   push_state (&s1, COMP_INTERFACE, sym);
2207   current_state = COMP_NONE;
2208
2209 loop:
2210   gfc_current_ns = gfc_get_namespace (current_interface.ns, 0);
2211
2212   st = next_statement ();
2213   switch (st)
2214     {
2215     case ST_NONE:
2216       unexpected_eof ();
2217
2218     case ST_SUBROUTINE:
2219     case ST_FUNCTION:
2220       if (st == ST_SUBROUTINE)
2221         new_state = COMP_SUBROUTINE;
2222       else if (st == ST_FUNCTION)
2223         new_state = COMP_FUNCTION;
2224       if (gfc_new_block->attr.pointer)
2225         {
2226           gfc_new_block->attr.pointer = 0;
2227           gfc_new_block->attr.proc_pointer = 1;
2228         }
2229       if (gfc_add_explicit_interface (gfc_new_block, IFSRC_IFBODY,
2230                                   gfc_new_block->formal, NULL) == FAILURE)
2231         {
2232           reject_statement ();
2233           gfc_free_namespace (gfc_current_ns);
2234           goto loop;
2235         }
2236       break;
2237
2238     case ST_PROCEDURE:
2239     case ST_MODULE_PROC:        /* The module procedure matcher makes
2240                                    sure the context is correct.  */
2241       accept_statement (st);
2242       gfc_free_namespace (gfc_current_ns);
2243       goto loop;
2244
2245     case ST_END_INTERFACE:
2246       gfc_free_namespace (gfc_current_ns);
2247       gfc_current_ns = current_interface.ns;
2248       goto done;
2249
2250     default:
2251       gfc_error ("Unexpected %s statement in INTERFACE block at %C",
2252                  gfc_ascii_statement (st));
2253       reject_statement ();
2254       gfc_free_namespace (gfc_current_ns);
2255       goto loop;
2256     }
2257
2258
2259   /* Make sure that a generic interface has only subroutines or
2260      functions and that the generic name has the right attribute.  */
2261   if (current_interface.type == INTERFACE_GENERIC)
2262     {
2263       if (current_state == COMP_NONE)
2264         {
2265           if (new_state == COMP_FUNCTION && sym)
2266             gfc_add_function (&sym->attr, sym->name, NULL);
2267           else if (new_state == COMP_SUBROUTINE && sym)
2268             gfc_add_subroutine (&sym->attr, sym->name, NULL);
2269
2270           current_state = new_state;
2271         }
2272       else
2273         {
2274           if (new_state != current_state)
2275             {
2276               if (new_state == COMP_SUBROUTINE)
2277                 gfc_error ("SUBROUTINE at %C does not belong in a "
2278                            "generic function interface");
2279
2280               if (new_state == COMP_FUNCTION)
2281                 gfc_error ("FUNCTION at %C does not belong in a "
2282                            "generic subroutine interface");
2283             }
2284         }
2285     }
2286
2287   if (current_interface.type == INTERFACE_ABSTRACT)
2288     {
2289       gfc_add_abstract (&gfc_new_block->attr, &gfc_current_locus);
2290       if (gfc_is_intrinsic_typename (gfc_new_block->name))
2291         gfc_error ("Name '%s' of ABSTRACT INTERFACE at %C "
2292                    "cannot be the same as an intrinsic type",
2293                    gfc_new_block->name);
2294     }
2295
2296   push_state (&s2, new_state, gfc_new_block);
2297   accept_statement (st);
2298   prog_unit = gfc_new_block;
2299   prog_unit->formal_ns = gfc_current_ns;
2300   proc_locus = gfc_current_locus;
2301
2302 decl:
2303   /* Read data declaration statements.  */
2304   st = parse_spec (ST_NONE);
2305
2306   /* Since the interface block does not permit an IMPLICIT statement,
2307      the default type for the function or the result must be taken
2308      from the formal namespace.  */
2309   if (new_state == COMP_FUNCTION)
2310     {
2311         if (prog_unit->result == prog_unit
2312               && prog_unit->ts.type == BT_UNKNOWN)
2313           gfc_set_default_type (prog_unit, 1, prog_unit->formal_ns);
2314         else if (prog_unit->result != prog_unit
2315                    && prog_unit->result->ts.type == BT_UNKNOWN)
2316           gfc_set_default_type (prog_unit->result, 1,
2317                                 prog_unit->formal_ns);
2318     }
2319
2320   if (st != ST_END_SUBROUTINE && st != ST_END_FUNCTION)
2321     {
2322       gfc_error ("Unexpected %s statement at %C in INTERFACE body",
2323                  gfc_ascii_statement (st));
2324       reject_statement ();
2325       goto decl;
2326     }
2327
2328   /* Add EXTERNAL attribute to function or subroutine.  */
2329   if (current_interface.type != INTERFACE_ABSTRACT && !prog_unit->attr.dummy)
2330     gfc_add_external (&prog_unit->attr, &gfc_current_locus);
2331
2332   current_interface = save;
2333   gfc_add_interface (prog_unit);
2334   pop_state ();
2335
2336   if (current_interface.ns
2337         && current_interface.ns->proc_name
2338         && strcmp (current_interface.ns->proc_name->name,
2339                    prog_unit->name) == 0)
2340     gfc_error ("INTERFACE procedure '%s' at %L has the same name as the "
2341                "enclosing procedure", prog_unit->name, &proc_locus);
2342
2343   goto loop;
2344
2345 done:
2346   pop_state ();
2347 }
2348
2349
2350 /* Associate function characteristics by going back to the function
2351    declaration and rematching the prefix.  */
2352
2353 static match
2354 match_deferred_characteristics (gfc_typespec * ts)
2355 {
2356   locus loc;
2357   match m = MATCH_ERROR;
2358   char name[GFC_MAX_SYMBOL_LEN + 1];
2359
2360   loc = gfc_current_locus;
2361
2362   gfc_current_locus = gfc_current_block ()->declared_at;
2363
2364   gfc_clear_error ();
2365   gfc_buffer_error (1);
2366   m = gfc_match_prefix (ts);
2367   gfc_buffer_error (0);
2368
2369   if (ts->type == BT_DERIVED)
2370     {
2371       ts->kind = 0;
2372
2373       if (!ts->u.derived)
2374         m = MATCH_ERROR;
2375     }
2376
2377   /* Only permit one go at the characteristic association.  */
2378   if (ts->kind == -1)
2379     ts->kind = 0;
2380
2381   /* Set the function locus correctly.  If we have not found the
2382      function name, there is an error.  */
2383   if (m == MATCH_YES
2384       && gfc_match ("function% %n", name) == MATCH_YES
2385       && strcmp (name, gfc_current_block ()->name) == 0)
2386     {
2387       gfc_current_block ()->declared_at = gfc_current_locus;
2388       gfc_commit_symbols ();
2389     }
2390   else
2391     {
2392       gfc_error_check ();
2393       gfc_undo_symbols ();
2394     }
2395
2396   gfc_current_locus =loc;
2397   return m;
2398 }
2399
2400
2401 /* Check specification-expressions in the function result of the currently
2402    parsed block and ensure they are typed (give an IMPLICIT type if necessary).
2403    For return types specified in a FUNCTION prefix, the IMPLICIT rules of the
2404    scope are not yet parsed so this has to be delayed up to parse_spec.  */
2405
2406 static void
2407 check_function_result_typed (void)
2408 {
2409   gfc_typespec* ts = &gfc_current_ns->proc_name->result->ts;
2410
2411   gcc_assert (gfc_current_state () == COMP_FUNCTION);
2412   gcc_assert (ts->type != BT_UNKNOWN);
2413
2414   /* Check type-parameters, at the moment only CHARACTER lengths possible.  */
2415   /* TODO:  Extend when KIND type parameters are implemented.  */
2416   if (ts->type == BT_CHARACTER && ts->u.cl && ts->u.cl->length)
2417     gfc_expr_check_typed (ts->u.cl->length, gfc_current_ns, true);
2418 }
2419
2420
2421 /* Parse a set of specification statements.  Returns the statement
2422    that doesn't fit.  */
2423
2424 static gfc_statement
2425 parse_spec (gfc_statement st)
2426 {
2427   st_state ss;
2428   bool function_result_typed = false;
2429   bool bad_characteristic = false;
2430   gfc_typespec *ts;
2431
2432   verify_st_order (&ss, ST_NONE, false);
2433   if (st == ST_NONE)
2434     st = next_statement ();
2435
2436   /* If we are not inside a function or don't have a result specified so far,
2437      do nothing special about it.  */
2438   if (gfc_current_state () != COMP_FUNCTION)
2439     function_result_typed = true;
2440   else
2441     {
2442       gfc_symbol* proc = gfc_current_ns->proc_name;
2443       gcc_assert (proc);
2444
2445       if (proc->result->ts.type == BT_UNKNOWN)
2446         function_result_typed = true;
2447     }
2448
2449 loop:
2450
2451   /* If we're inside a BLOCK construct, some statements are disallowed.
2452      Check this here.  Attribute declaration statements like INTENT, OPTIONAL
2453      or VALUE are also disallowed, but they don't have a particular ST_*
2454      key so we have to check for them individually in their matcher routine.  */
2455   if (gfc_current_state () == COMP_BLOCK)
2456     switch (st)
2457       {
2458         case ST_IMPLICIT:
2459         case ST_IMPLICIT_NONE:
2460         case ST_NAMELIST:
2461         case ST_COMMON:
2462         case ST_EQUIVALENCE:
2463         case ST_STATEMENT_FUNCTION:
2464           gfc_error ("%s statement is not allowed inside of BLOCK at %C",
2465                      gfc_ascii_statement (st));
2466           reject_statement ();
2467           break;
2468
2469         default:
2470           break;
2471       }
2472
2473   /* If we find a statement that can not be followed by an IMPLICIT statement
2474      (and thus we can expect to see none any further), type the function result
2475      if it has not yet been typed.  Be careful not to give the END statement
2476      to verify_st_order!  */
2477   if (!function_result_typed && st != ST_GET_FCN_CHARACTERISTICS)
2478     {
2479       bool verify_now = false;
2480
2481       if (st == ST_END_FUNCTION || st == ST_CONTAINS)
2482         verify_now = true;
2483       else
2484         {
2485           st_state dummyss;
2486           verify_st_order (&dummyss, ST_NONE, false);
2487           verify_st_order (&dummyss, st, false);
2488
2489           if (verify_st_order (&dummyss, ST_IMPLICIT, true) == FAILURE)
2490             verify_now = true;
2491         }
2492
2493       if (verify_now)
2494         {
2495           check_function_result_typed ();
2496           function_result_typed = true;
2497         }
2498     }
2499
2500   switch (st)
2501     {
2502     case ST_NONE:
2503       unexpected_eof ();
2504
2505     case ST_IMPLICIT_NONE:
2506     case ST_IMPLICIT:
2507       if (!function_result_typed)
2508         {
2509           check_function_result_typed ();
2510           function_result_typed = true;
2511         }
2512       goto declSt;
2513
2514     case ST_FORMAT:
2515     case ST_ENTRY:
2516     case ST_DATA:       /* Not allowed in interfaces */
2517       if (gfc_current_state () == COMP_INTERFACE)
2518         break;
2519
2520       /* Fall through */
2521
2522     case ST_USE:
2523     case ST_IMPORT:
2524     case ST_PARAMETER:
2525     case ST_PUBLIC:
2526     case ST_PRIVATE:
2527     case ST_DERIVED_DECL:
2528     case_decl:
2529 declSt:
2530       if (verify_st_order (&ss, st, false) == FAILURE)
2531         {
2532           reject_statement ();
2533           st = next_statement ();
2534           goto loop;
2535         }
2536
2537       switch (st)
2538         {
2539         case ST_INTERFACE:
2540           parse_interface ();
2541           break;
2542
2543         case ST_DERIVED_DECL:
2544           parse_derived ();
2545           break;
2546
2547         case ST_PUBLIC:
2548         case ST_PRIVATE:
2549           if (gfc_current_state () != COMP_MODULE)
2550             {
2551               gfc_error ("%s statement must appear in a MODULE",
2552                          gfc_ascii_statement (st));
2553               reject_statement ();
2554               break;
2555             }
2556
2557           if (gfc_current_ns->default_access != ACCESS_UNKNOWN)
2558             {
2559               gfc_error ("%s statement at %C follows another accessibility "
2560                          "specification", gfc_ascii_statement (st));
2561               reject_statement ();
2562               break;
2563             }
2564
2565           gfc_current_ns->default_access = (st == ST_PUBLIC)
2566             ? ACCESS_PUBLIC : ACCESS_PRIVATE;
2567
2568           break;
2569
2570         case ST_STATEMENT_FUNCTION:
2571           if (gfc_current_state () == COMP_MODULE)
2572             {
2573               unexpected_statement (st);
2574               break;
2575             }
2576
2577         default:
2578           break;
2579         }
2580
2581       accept_statement (st);
2582       st = next_statement ();
2583       goto loop;
2584
2585     case ST_ENUM:
2586       accept_statement (st);
2587       parse_enum();
2588       st = next_statement ();
2589       goto loop;
2590
2591     case ST_GET_FCN_CHARACTERISTICS:
2592       /* This statement triggers the association of a function's result
2593          characteristics.  */
2594       ts = &gfc_current_block ()->result->ts;
2595       if (match_deferred_characteristics (ts) != MATCH_YES)
2596         bad_characteristic = true;
2597
2598       st = next_statement ();
2599       goto loop;
2600
2601     default:
2602       break;
2603     }
2604
2605   /* If match_deferred_characteristics failed, then there is an error. */
2606   if (bad_characteristic)
2607     {
2608       ts = &gfc_current_block ()->result->ts;
2609       if (ts->type != BT_DERIVED)
2610         gfc_error ("Bad kind expression for function '%s' at %L",
2611                    gfc_current_block ()->name,
2612                    &gfc_current_block ()->declared_at);
2613       else
2614         gfc_error ("The type for function '%s' at %L is not accessible",
2615                    gfc_current_block ()->name,
2616                    &gfc_current_block ()->declared_at);
2617
2618       gfc_current_block ()->ts.kind = 0;
2619       /* Keep the derived type; if it's bad, it will be discovered later.  */
2620       if (!(ts->type == BT_DERIVED && ts->u.derived))
2621         ts->type = BT_UNKNOWN;
2622     }
2623
2624   return st;
2625 }
2626
2627
2628 /* Parse a WHERE block, (not a simple WHERE statement).  */
2629
2630 static void
2631 parse_where_block (void)
2632 {
2633   int seen_empty_else;
2634   gfc_code *top, *d;
2635   gfc_state_data s;
2636   gfc_statement st;
2637
2638   accept_statement (ST_WHERE_BLOCK);
2639   top = gfc_state_stack->tail;
2640
2641   push_state (&s, COMP_WHERE, gfc_new_block);
2642
2643   d = add_statement ();
2644   d->expr1 = top->expr1;
2645   d->op = EXEC_WHERE;
2646
2647   top->expr1 = NULL;
2648   top->block = d;
2649
2650   seen_empty_else = 0;
2651
2652   do
2653     {
2654       st = next_statement ();
2655       switch (st)
2656         {
2657         case ST_NONE:
2658           unexpected_eof ();
2659
2660         case ST_WHERE_BLOCK:
2661           parse_where_block ();
2662           break;
2663
2664         case ST_ASSIGNMENT:
2665         case ST_WHERE:
2666           accept_statement (st);
2667           break;
2668
2669         case ST_ELSEWHERE:
2670           if (seen_empty_else)
2671             {
2672               gfc_error ("ELSEWHERE statement at %C follows previous "
2673                          "unmasked ELSEWHERE");
2674               break;
2675             }
2676
2677           if (new_st.expr1 == NULL)
2678             seen_empty_else = 1;
2679
2680           d = new_level (gfc_state_stack->head);
2681           d->op = EXEC_WHERE;
2682           d->expr1 = new_st.expr1;
2683
2684           accept_statement (st);
2685
2686           break;
2687
2688         case ST_END_WHERE:
2689           accept_statement (st);
2690           break;
2691
2692         default:
2693           gfc_error ("Unexpected %s statement in WHERE block at %C",
2694                      gfc_ascii_statement (st));
2695           reject_statement ();
2696           break;
2697         }
2698     }
2699   while (st != ST_END_WHERE);
2700
2701   pop_state ();
2702 }
2703
2704
2705 /* Parse a FORALL block (not a simple FORALL statement).  */
2706
2707 static void
2708 parse_forall_block (void)
2709 {
2710   gfc_code *top, *d;
2711   gfc_state_data s;
2712   gfc_statement st;
2713
2714   accept_statement (ST_FORALL_BLOCK);
2715   top = gfc_state_stack->tail;
2716
2717   push_state (&s, COMP_FORALL, gfc_new_block);
2718
2719   d = add_statement ();
2720   d->op = EXEC_FORALL;
2721   top->block = d;
2722
2723   do
2724     {
2725       st = next_statement ();
2726       switch (st)
2727         {
2728
2729         case ST_ASSIGNMENT:
2730         case ST_POINTER_ASSIGNMENT:
2731         case ST_WHERE:
2732         case ST_FORALL:
2733           accept_statement (st);
2734           break;
2735
2736         case ST_WHERE_BLOCK:
2737           parse_where_block ();
2738           break;
2739
2740         case ST_FORALL_BLOCK:
2741           parse_forall_block ();
2742           break;
2743
2744         case ST_END_FORALL:
2745           accept_statement (st);
2746           break;
2747
2748         case ST_NONE:
2749           unexpected_eof ();
2750
2751         default:
2752           gfc_error ("Unexpected %s statement in FORALL block at %C",
2753                      gfc_ascii_statement (st));
2754
2755           reject_statement ();
2756           break;
2757         }
2758     }
2759   while (st != ST_END_FORALL);
2760
2761   pop_state ();
2762 }
2763
2764
2765 static gfc_statement parse_executable (gfc_statement);
2766
2767 /* parse the statements of an IF-THEN-ELSEIF-ELSE-ENDIF block.  */
2768
2769 static void
2770 parse_if_block (void)
2771 {
2772   gfc_code *top, *d;
2773   gfc_statement st;
2774   locus else_locus;
2775   gfc_state_data s;
2776   int seen_else;
2777
2778   seen_else = 0;
2779   accept_statement (ST_IF_BLOCK);
2780
2781   top = gfc_state_stack->tail;
2782   push_state (&s, COMP_IF, gfc_new_block);
2783
2784   new_st.op = EXEC_IF;
2785   d = add_statement ();
2786
2787   d->expr1 = top->expr1;
2788   top->expr1 = NULL;
2789   top->block = d;
2790
2791   do
2792     {
2793       st = parse_executable (ST_NONE);
2794
2795       switch (st)
2796         {
2797         case ST_NONE:
2798           unexpected_eof ();
2799
2800         case ST_ELSEIF:
2801           if (seen_else)
2802             {
2803               gfc_error ("ELSE IF statement at %C cannot follow ELSE "
2804                          "statement at %L", &else_locus);
2805
2806               reject_statement ();
2807               break;
2808             }
2809
2810           d = new_level (gfc_state_stack->head);
2811           d->op = EXEC_IF;
2812           d->expr1 = new_st.expr1;
2813
2814           accept_statement (st);
2815
2816           break;
2817
2818         case ST_ELSE:
2819           if (seen_else)
2820             {
2821               gfc_error ("Duplicate ELSE statements at %L and %C",
2822                          &else_locus);
2823               reject_statement ();
2824               break;
2825             }
2826
2827           seen_else = 1;
2828           else_locus = gfc_current_locus;
2829
2830           d = new_level (gfc_state_stack->head);
2831           d->op = EXEC_IF;
2832
2833           accept_statement (st);
2834
2835           break;
2836
2837         case ST_ENDIF:
2838           break;
2839
2840         default:
2841           unexpected_statement (st);
2842           break;
2843         }
2844     }
2845   while (st != ST_ENDIF);
2846
2847   pop_state ();
2848   accept_statement (st);
2849 }
2850
2851
2852 /* Parse a SELECT block.  */
2853
2854 static void
2855 parse_select_block (void)
2856 {
2857   gfc_statement st;
2858   gfc_code *cp;
2859   gfc_state_data s;
2860
2861   accept_statement (ST_SELECT_CASE);
2862
2863   cp = gfc_state_stack->tail;
2864   push_state (&s, COMP_SELECT, gfc_new_block);
2865
2866   /* Make sure that the next statement is a CASE or END SELECT.  */
2867   for (;;)
2868     {
2869       st = next_statement ();
2870       if (st == ST_NONE)
2871         unexpected_eof ();
2872       if (st == ST_END_SELECT)
2873         {
2874           /* Empty SELECT CASE is OK.  */
2875           accept_statement (st);
2876           pop_state ();
2877           return;
2878         }
2879       if (st == ST_CASE)
2880         break;
2881
2882       gfc_error ("Expected a CASE or END SELECT statement following SELECT "
2883                  "CASE at %C");
2884
2885       reject_statement ();
2886     }
2887
2888   /* At this point, we're got a nonempty select block.  */
2889   cp = new_level (cp);
2890   *cp = new_st;
2891
2892   accept_statement (st);
2893
2894   do
2895     {
2896       st = parse_executable (ST_NONE);
2897       switch (st)
2898         {
2899         case ST_NONE:
2900           unexpected_eof ();
2901
2902         case ST_CASE:
2903           cp = new_level (gfc_state_stack->head);
2904           *cp = new_st;
2905           gfc_clear_new_st ();
2906
2907           accept_statement (st);
2908           /* Fall through */
2909
2910         case ST_END_SELECT:
2911           break;
2912
2913         /* Can't have an executable statement because of
2914            parse_executable().  */
2915         default:
2916           unexpected_statement (st);
2917           break;
2918         }
2919     }
2920   while (st != ST_END_SELECT);
2921
2922   pop_state ();
2923   accept_statement (st);
2924 }
2925
2926
2927 /* Pop the current selector from the SELECT TYPE stack.  */
2928
2929 static void
2930 select_type_pop (void)
2931 {
2932   gfc_select_type_stack *old = select_type_stack;
2933   select_type_stack = old->prev;
2934   gfc_free (old);
2935 }
2936
2937
2938 /* Parse a SELECT TYPE construct (F03:R821).  */
2939
2940 static void
2941 parse_select_type_block (void)
2942 {
2943   gfc_statement st;
2944   gfc_code *cp;
2945   gfc_state_data s;
2946
2947   accept_statement (ST_SELECT_TYPE);
2948
2949   cp = gfc_state_stack->tail;
2950   push_state (&s, COMP_SELECT_TYPE, gfc_new_block);
2951
2952   /* Make sure that the next statement is a TYPE IS, CLASS IS, CLASS DEFAULT
2953      or END SELECT.  */
2954   for (;;)
2955     {
2956       st = next_statement ();
2957       if (st == ST_NONE)
2958         unexpected_eof ();
2959       if (st == ST_END_SELECT)
2960         /* Empty SELECT CASE is OK.  */
2961         goto done;
2962       if (st == ST_TYPE_IS || st == ST_CLASS_IS)
2963         break;
2964
2965       gfc_error ("Expected TYPE IS, CLASS IS or END SELECT statement "
2966                  "following SELECT TYPE at %C");
2967
2968       reject_statement ();
2969     }
2970
2971   /* At this point, we're got a nonempty select block.  */
2972   cp = new_level (cp);
2973   *cp = new_st;
2974
2975   accept_statement (st);
2976
2977   do
2978     {
2979       st = parse_executable (ST_NONE);
2980       switch (st)
2981         {
2982         case ST_NONE:
2983           unexpected_eof ();
2984
2985         case ST_TYPE_IS:
2986         case ST_CLASS_IS:
2987           cp = new_level (gfc_state_stack->head);
2988           *cp = new_st;
2989           gfc_clear_new_st ();
2990
2991           accept_statement (st);
2992           /* Fall through */
2993
2994         case ST_END_SELECT:
2995           break;
2996
2997         /* Can't have an executable statement because of
2998            parse_executable().  */
2999         default:
3000           unexpected_statement (st);
3001           break;
3002         }
3003     }
3004   while (st != ST_END_SELECT);
3005
3006 done:
3007   pop_state ();
3008   accept_statement (st);
3009   gfc_current_ns = gfc_current_ns->parent;
3010   select_type_pop ();
3011 }
3012
3013
3014 /* Given a symbol, make sure it is not an iteration variable for a DO
3015    statement.  This subroutine is called when the symbol is seen in a
3016    context that causes it to become redefined.  If the symbol is an
3017    iterator, we generate an error message and return nonzero.  */
3018
3019 int
3020 gfc_check_do_variable (gfc_symtree *st)
3021 {
3022   gfc_state_data *s;
3023
3024   for (s=gfc_state_stack; s; s = s->previous)
3025     if (s->do_variable == st)
3026       {
3027         gfc_error_now("Variable '%s' at %C cannot be redefined inside "
3028                       "loop beginning at %L", st->name, &s->head->loc);
3029         return 1;
3030       }
3031
3032   return 0;
3033 }
3034
3035
3036 /* Checks to see if the current statement label closes an enddo.
3037    Returns 0 if not, 1 if closes an ENDDO correctly, or 2 (and issues
3038    an error) if it incorrectly closes an ENDDO.  */
3039
3040 static int
3041 check_do_closure (void)
3042 {
3043   gfc_state_data *p;
3044
3045   if (gfc_statement_label == NULL)
3046     return 0;
3047
3048   for (p = gfc_state_stack; p; p = p->previous)
3049     if (p->state == COMP_DO)
3050       break;
3051
3052   if (p == NULL)
3053     return 0;           /* No loops to close */
3054
3055   if (p->ext.end_do_label == gfc_statement_label)
3056     {
3057       if (p == gfc_state_stack)
3058         return 1;
3059
3060       gfc_error ("End of nonblock DO statement at %C is within another block");
3061       return 2;
3062     }
3063
3064   /* At this point, the label doesn't terminate the innermost loop.
3065      Make sure it doesn't terminate another one.  */
3066   for (; p; p = p->previous)
3067     if (p->state == COMP_DO && p->ext.end_do_label == gfc_statement_label)
3068       {
3069         gfc_error ("End of nonblock DO statement at %C is interwoven "
3070                    "with another DO loop");
3071         return 2;
3072       }
3073
3074   return 0;
3075 }
3076
3077
3078 /* Parse a series of contained program units.  */
3079
3080 static void parse_progunit (gfc_statement);
3081
3082
3083 /* Parse a CRITICAL block.  */
3084
3085 static void
3086 parse_critical_block (void)
3087 {
3088   gfc_code *top, *d;
3089   gfc_state_data s;
3090   gfc_statement st;
3091
3092   s.ext.end_do_label = new_st.label1;
3093
3094   accept_statement (ST_CRITICAL);
3095   top = gfc_state_stack->tail;
3096
3097   push_state (&s, COMP_CRITICAL, gfc_new_block);
3098
3099   d = add_statement ();
3100   d->op = EXEC_CRITICAL;
3101   top->block = d;
3102
3103   do
3104     {
3105       st = parse_executable (ST_NONE);
3106
3107       switch (st)
3108         {
3109           case ST_NONE:
3110             unexpected_eof ();
3111             break;
3112
3113           case ST_END_CRITICAL:
3114             if (s.ext.end_do_label != NULL
3115                 && s.ext.end_do_label != gfc_statement_label)
3116               gfc_error_now ("Statement label in END CRITICAL at %C does not "
3117                              "match CRITIAL label");
3118
3119             if (gfc_statement_label != NULL)
3120               {
3121                 new_st.op = EXEC_NOP;
3122                 add_statement ();
3123               }
3124             break;
3125
3126           default:
3127             unexpected_statement (st);
3128             break;
3129         }
3130     }
3131   while (st != ST_END_CRITICAL);
3132
3133   pop_state ();
3134   accept_statement (st);
3135 }
3136
3137
3138 /* Set up the local namespace for a BLOCK construct.  */
3139
3140 gfc_namespace*
3141 gfc_build_block_ns (gfc_namespace *parent_ns)
3142 {
3143   gfc_namespace* my_ns;
3144
3145   my_ns = gfc_get_namespace (parent_ns, 1);
3146   my_ns->construct_entities = 1;
3147
3148   /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3149      code generation (so it must not be NULL).
3150      We set its recursive argument if our container procedure is recursive, so
3151      that local variables are accordingly placed on the stack when it
3152      will be necessary.  */
3153   if (gfc_new_block)
3154     my_ns->proc_name = gfc_new_block;
3155   else
3156     {
3157       gfc_try t;
3158
3159       gfc_get_symbol ("block@", my_ns, &my_ns->proc_name);
3160       t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3161                           my_ns->proc_name->name, NULL);
3162       gcc_assert (t == SUCCESS);
3163     }
3164
3165   if (parent_ns->proc_name)
3166     my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3167
3168   return my_ns;
3169 }
3170
3171
3172 /* Parse a BLOCK construct.  */
3173
3174 static void
3175 parse_block_construct (void)
3176 {
3177   gfc_namespace* my_ns;
3178   gfc_state_data s;
3179
3180   gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
3181
3182   my_ns = gfc_build_block_ns (gfc_current_ns);
3183
3184   new_st.op = EXEC_BLOCK;
3185   new_st.ext.block.ns = my_ns;
3186   new_st.ext.block.assoc = NULL;
3187   accept_statement (ST_BLOCK);
3188
3189   push_state (&s, COMP_BLOCK, my_ns->proc_name);
3190   gfc_current_ns = my_ns;
3191
3192   parse_progunit (ST_NONE);
3193
3194   gfc_current_ns = gfc_current_ns->parent;
3195   pop_state ();
3196 }
3197
3198
3199 /* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
3200    behind the scenes with compiler-generated variables.  */
3201
3202 static void
3203 parse_associate (void)
3204 {
3205   gfc_namespace* my_ns;
3206   gfc_state_data s;
3207   gfc_statement st;
3208   gfc_association_list* a;
3209   gfc_code* assignTail;
3210
3211   gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
3212
3213   my_ns = gfc_build_block_ns (gfc_current_ns);
3214
3215   new_st.op = EXEC_BLOCK;
3216   new_st.ext.block.ns = my_ns;
3217   gcc_assert (new_st.ext.block.assoc);
3218
3219   /* Add all associations to expressions as BLOCK variables, and create
3220      assignments to them giving their values.  */
3221   gfc_current_ns = my_ns;
3222   assignTail = NULL;
3223   for (a = new_st.ext.block.assoc; a; a = a->next)
3224     if (!a->variable)
3225       {
3226         gfc_code* newAssign;
3227
3228         if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
3229           gcc_unreachable ();
3230
3231         /* Note that in certain cases, the target-expression's type is not yet
3232            known and so we have to adapt the symbol's ts also during resolution
3233            for these cases.  */
3234         a->st->n.sym->ts = a->target->ts;
3235         a->st->n.sym->attr.flavor = FL_VARIABLE;
3236         a->st->n.sym->assoc = a;
3237         gfc_set_sym_referenced (a->st->n.sym);
3238
3239         /* Create the assignment to calculate the expression and set it.  */
3240         newAssign = gfc_get_code ();
3241         newAssign->op = EXEC_ASSIGN;
3242         newAssign->loc = gfc_current_locus;
3243         newAssign->expr1 = gfc_get_variable_expr (a->st);
3244         newAssign->expr2 = a->target;
3245
3246         /* Hang it in.  */
3247         if (assignTail)
3248           assignTail->next = newAssign;
3249         else
3250           gfc_current_ns->code = newAssign;
3251         assignTail = newAssign;
3252       }
3253     else
3254       {
3255         gfc_error ("Association to variables is not yet supported at %C");
3256         return;
3257       }
3258   gcc_assert (assignTail);
3259
3260   accept_statement (ST_ASSOCIATE);
3261   push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
3262
3263 loop:
3264   st = parse_executable (ST_NONE);
3265   switch (st)
3266     {
3267     case ST_NONE:
3268       unexpected_eof ();
3269
3270     case_end:
3271       accept_statement (st);
3272       assignTail->next = gfc_state_stack->head;
3273       break;
3274
3275     default:
3276       unexpected_statement (st);
3277       goto loop;
3278     }
3279
3280   gfc_current_ns = gfc_current_ns->parent;
3281   pop_state ();
3282 }
3283
3284
3285 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
3286    handled inside of parse_executable(), because they aren't really
3287    loop statements.  */
3288
3289 static void
3290 parse_do_block (void)
3291 {
3292   gfc_statement st;
3293   gfc_code *top;
3294   gfc_state_data s;
3295   gfc_symtree *stree;
3296
3297   s.ext.end_do_label = new_st.label1;
3298
3299   if (new_st.ext.iterator != NULL)
3300     stree = new_st.ext.iterator->var->symtree;
3301   else
3302     stree = NULL;
3303
3304   accept_statement (ST_DO);
3305
3306   top = gfc_state_stack->tail;
3307   push_state (&s, COMP_DO, gfc_new_block);
3308
3309   s.do_variable = stree;
3310
3311   top->block = new_level (top);
3312   top->block->op = EXEC_DO;
3313
3314 loop:
3315   st = parse_executable (ST_NONE);
3316
3317   switch (st)
3318     {
3319     case ST_NONE:
3320       unexpected_eof ();
3321
3322     case ST_ENDDO:
3323       if (s.ext.end_do_label != NULL
3324           && s.ext.end_do_label != gfc_statement_label)
3325         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3326                        "DO label");
3327
3328       if (gfc_statement_label != NULL)
3329         {
3330           new_st.op = EXEC_NOP;
3331           add_statement ();
3332         }
3333       break;
3334
3335     case ST_IMPLIED_ENDDO:
3336      /* If the do-stmt of this DO construct has a do-construct-name,
3337         the corresponding end-do must be an end-do-stmt (with a matching
3338         name, but in that case we must have seen ST_ENDDO first).
3339         We only complain about this in pedantic mode.  */
3340      if (gfc_current_block () != NULL)
3341         gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3342                        &gfc_current_block()->declared_at);
3343
3344       break;
3345
3346     default:
3347       unexpected_statement (st);
3348       goto loop;
3349     }
3350
3351   pop_state ();
3352   accept_statement (st);
3353 }
3354
3355
3356 /* Parse the statements of OpenMP do/parallel do.  */
3357
3358 static gfc_statement
3359 parse_omp_do (gfc_statement omp_st)
3360 {
3361   gfc_statement st;
3362   gfc_code *cp, *np;
3363   gfc_state_data s;
3364
3365   accept_statement (omp_st);
3366
3367   cp = gfc_state_stack->tail;
3368   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3369   np = new_level (cp);
3370   np->op = cp->op;
3371   np->block = NULL;
3372
3373   for (;;)
3374     {
3375       st = next_statement ();
3376       if (st == ST_NONE)
3377         unexpected_eof ();
3378       else if (st == ST_DO)
3379         break;
3380       else
3381         unexpected_statement (st);
3382     }
3383
3384   parse_do_block ();
3385   if (gfc_statement_label != NULL
3386       && gfc_state_stack->previous != NULL
3387       && gfc_state_stack->previous->state == COMP_DO
3388       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3389     {
3390       /* In
3391          DO 100 I=1,10
3392            !$OMP DO
3393              DO J=1,10
3394              ...
3395              100 CONTINUE
3396          there should be no !$OMP END DO.  */
3397       pop_state ();
3398       return ST_IMPLIED_ENDDO;
3399     }
3400
3401   check_do_closure ();
3402   pop_state ();
3403
3404   st = next_statement ();
3405   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3406     {
3407       if (new_st.op == EXEC_OMP_END_NOWAIT)
3408         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3409       else
3410         gcc_assert (new_st.op == EXEC_NOP);
3411       gfc_clear_new_st ();
3412       gfc_commit_symbols ();
3413       gfc_warning_check ();
3414       st = next_statement ();
3415     }
3416   return st;
3417 }
3418
3419
3420 /* Parse the statements of OpenMP atomic directive.  */
3421
3422 static void
3423 parse_omp_atomic (void)
3424 {
3425   gfc_statement st;
3426   gfc_code *cp, *np;
3427   gfc_state_data s;
3428
3429   accept_statement (ST_OMP_ATOMIC);
3430
3431   cp = gfc_state_stack->tail;
3432   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3433   np = new_level (cp);
3434   np->op = cp->op;
3435   np->block = NULL;
3436
3437   for (;;)
3438     {
3439       st = next_statement ();
3440       if (st == ST_NONE)
3441         unexpected_eof ();
3442       else if (st == ST_ASSIGNMENT)
3443         break;
3444       else
3445         unexpected_statement (st);
3446     }
3447
3448   accept_statement (st);
3449
3450   pop_state ();
3451 }
3452
3453
3454 /* Parse the statements of an OpenMP structured block.  */
3455
3456 static void
3457 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3458 {
3459   gfc_statement st, omp_end_st;
3460   gfc_code *cp, *np;
3461   gfc_state_data s;
3462
3463   accept_statement (omp_st);
3464
3465   cp = gfc_state_stack->tail;
3466   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3467   np = new_level (cp);
3468   np->op = cp->op;
3469   np->block = NULL;
3470
3471   switch (omp_st)
3472     {
3473     case ST_OMP_PARALLEL:
3474       omp_end_st = ST_OMP_END_PARALLEL;
3475       break;
3476     case ST_OMP_PARALLEL_SECTIONS:
3477       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3478       break;
3479     case ST_OMP_SECTIONS:
3480       omp_end_st = ST_OMP_END_SECTIONS;
3481       break;
3482     case ST_OMP_ORDERED:
3483       omp_end_st = ST_OMP_END_ORDERED;
3484       break;
3485     case ST_OMP_CRITICAL:
3486       omp_end_st = ST_OMP_END_CRITICAL;
3487       break;
3488     case ST_OMP_MASTER:
3489       omp_end_st = ST_OMP_END_MASTER;
3490       break;
3491     case ST_OMP_SINGLE:
3492       omp_end_st = ST_OMP_END_SINGLE;
3493       break;
3494     case ST_OMP_TASK:
3495       omp_end_st = ST_OMP_END_TASK;
3496       break;
3497     case ST_OMP_WORKSHARE:
3498       omp_end_st = ST_OMP_END_WORKSHARE;
3499       break;
3500     case ST_OMP_PARALLEL_WORKSHARE:
3501       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3502       break;
3503     default:
3504       gcc_unreachable ();
3505     }
3506
3507   do
3508     {
3509       if (workshare_stmts_only)
3510         {
3511           /* Inside of !$omp workshare, only
3512              scalar assignments
3513              array assignments
3514              where statements and constructs
3515              forall statements and constructs
3516              !$omp atomic
3517              !$omp critical
3518              !$omp parallel
3519              are allowed.  For !$omp critical these
3520              restrictions apply recursively.  */
3521           bool cycle = true;
3522
3523           st = next_statement ();
3524           for (;;)
3525             {
3526               switch (st)
3527                 {
3528                 case ST_NONE:
3529                   unexpected_eof ();
3530
3531                 case ST_ASSIGNMENT:
3532                 case ST_WHERE:
3533                 case ST_FORALL:
3534                   accept_statement (st);
3535                   break;
3536
3537                 case ST_WHERE_BLOCK:
3538                   parse_where_block ();
3539                   break;
3540
3541                 case ST_FORALL_BLOCK:
3542                   parse_forall_block ();
3543                   break;
3544
3545                 case ST_OMP_PARALLEL:
3546                 case ST_OMP_PARALLEL_SECTIONS:
3547                   parse_omp_structured_block (st, false);
3548                   break;
3549
3550                 case ST_OMP_PARALLEL_WORKSHARE:
3551                 case ST_OMP_CRITICAL:
3552                   parse_omp_structured_block (st, true);
3553                   break;
3554
3555                 case ST_OMP_PARALLEL_DO:
3556                   st = parse_omp_do (st);
3557                   continue;
3558
3559                 case ST_OMP_ATOMIC:
3560                   parse_omp_atomic ();
3561                   break;
3562
3563                 default:
3564                   cycle = false;
3565                   break;
3566                 }
3567
3568               if (!cycle)
3569                 break;
3570
3571               st = next_statement ();
3572             }
3573         }
3574       else
3575         st = parse_executable (ST_NONE);
3576       if (st == ST_NONE)
3577         unexpected_eof ();
3578       else if (st == ST_OMP_SECTION
3579                && (omp_st == ST_OMP_SECTIONS
3580                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
3581         {
3582           np = new_level (np);
3583           np->op = cp->op;
3584           np->block = NULL;
3585         }
3586       else if (st != omp_end_st)
3587         unexpected_statement (st);
3588     }
3589   while (st != omp_end_st);
3590
3591   switch (new_st.op)
3592     {
3593     case EXEC_OMP_END_NOWAIT:
3594       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3595       break;
3596     case EXEC_OMP_CRITICAL:
3597       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3598           || (new_st.ext.omp_name != NULL
3599               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3600         gfc_error ("Name after !$omp critical and !$omp end critical does "
3601                    "not match at %C");
3602       gfc_free (CONST_CAST (char *, new_st.ext.omp_name));
3603       break;
3604     case EXEC_OMP_END_SINGLE:
3605       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3606         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3607       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3608       gfc_free_omp_clauses (new_st.ext.omp_clauses);
3609       break;
3610     case EXEC_NOP:
3611       break;
3612     default:
3613       gcc_unreachable ();
3614     }
3615
3616   gfc_clear_new_st ();
3617   gfc_commit_symbols ();
3618   gfc_warning_check ();
3619   pop_state ();
3620 }
3621
3622
3623 /* Accept a series of executable statements.  We return the first
3624    statement that doesn't fit to the caller.  Any block statements are
3625    passed on to the correct handler, which usually passes the buck
3626    right back here.  */
3627
3628 static gfc_statement
3629 parse_executable (gfc_statement st)
3630 {
3631   int close_flag;
3632
3633   if (st == ST_NONE)
3634     st = next_statement ();
3635
3636   for (;;)
3637     {
3638       close_flag = check_do_closure ();
3639       if (close_flag)
3640         switch (st)
3641           {
3642           case ST_GOTO:
3643           case ST_END_PROGRAM:
3644           case ST_RETURN:
3645           case ST_EXIT:
3646           case ST_END_FUNCTION:
3647           case ST_CYCLE:
3648           case ST_PAUSE:
3649           case ST_STOP:
3650           case ST_ERROR_STOP:
3651           case ST_END_SUBROUTINE:
3652
3653           case ST_DO:
3654           case ST_FORALL:
3655           case ST_WHERE:
3656           case ST_SELECT_CASE:
3657             gfc_error ("%s statement at %C cannot terminate a non-block "
3658                        "DO loop", gfc_ascii_statement (st));
3659             break;
3660
3661           default:
3662             break;
3663           }
3664
3665       switch (st)
3666         {
3667         case ST_NONE:
3668           unexpected_eof ();
3669
3670         case ST_FORMAT:
3671         case ST_DATA:
3672         case ST_ENTRY:
3673         case_executable:
3674           accept_statement (st);
3675           if (close_flag == 1)
3676             return ST_IMPLIED_ENDDO;
3677           break;
3678
3679         case ST_BLOCK:
3680           parse_block_construct ();
3681           break;
3682
3683         case ST_ASSOCIATE:
3684           parse_associate ();
3685           break;
3686
3687         case ST_IF_BLOCK:
3688           parse_if_block ();
3689           break;
3690
3691         case ST_SELECT_CASE:
3692           parse_select_block ();
3693           break;
3694
3695         case ST_SELECT_TYPE:
3696           parse_select_type_block();
3697           break;
3698
3699         case ST_DO:
3700           parse_do_block ();
3701           if (check_do_closure () == 1)
3702             return ST_IMPLIED_ENDDO;
3703           break;
3704
3705         case ST_CRITICAL:
3706           parse_critical_block ();
3707           break;
3708
3709         case ST_WHERE_BLOCK:
3710           parse_where_block ();
3711           break;
3712
3713         case ST_FORALL_BLOCK:
3714           parse_forall_block ();
3715           break;
3716
3717         case ST_OMP_PARALLEL:
3718         case ST_OMP_PARALLEL_SECTIONS:
3719         case ST_OMP_SECTIONS:
3720         case ST_OMP_ORDERED:
3721         case ST_OMP_CRITICAL:
3722         case ST_OMP_MASTER:
3723         case ST_OMP_SINGLE:
3724         case ST_OMP_TASK:
3725           parse_omp_structured_block (st, false);
3726           break;
3727
3728         case ST_OMP_WORKSHARE:
3729         case ST_OMP_PARALLEL_WORKSHARE:
3730           parse_omp_structured_block (st, true);
3731           break;
3732
3733         case ST_OMP_DO:
3734         case ST_OMP_PARALLEL_DO:
3735           st = parse_omp_do (st);
3736           if (st == ST_IMPLIED_ENDDO)
3737             return st;
3738           continue;
3739
3740         case ST_OMP_ATOMIC:
3741           parse_omp_atomic ();
3742           break;
3743
3744         default:
3745           return st;
3746         }
3747
3748       st = next_statement ();
3749     }
3750 }
3751
3752
3753 /* Fix the symbols for sibling functions.  These are incorrectly added to
3754    the child namespace as the parser didn't know about this procedure.  */
3755
3756 static void
3757 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3758 {
3759   gfc_namespace *ns;
3760   gfc_symtree *st;
3761   gfc_symbol *old_sym;
3762
3763   sym->attr.referenced = 1;
3764   for (ns = siblings; ns; ns = ns->sibling)
3765     {
3766       st = gfc_find_symtree (ns->sym_root, sym->name);
3767
3768       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3769         goto fixup_contained;
3770
3771       old_sym = st->n.sym;
3772       if (old_sym->ns == ns
3773             && !old_sym->attr.contained
3774
3775             /* By 14.6.1.3, host association should be excluded
3776                for the following.  */
3777             && !(old_sym->attr.external
3778                   || (old_sym->ts.type != BT_UNKNOWN
3779                         && !old_sym->attr.implicit_type)
3780                   || old_sym->attr.flavor == FL_PARAMETER
3781                   || old_sym->attr.use_assoc
3782                   || old_sym->attr.in_common
3783                   || old_sym->attr.in_equivalence
3784                   || old_sym->attr.data
3785                   || old_sym->attr.dummy
3786                   || old_sym->attr.result
3787                   || old_sym->attr.dimension
3788                   || old_sym->attr.allocatable
3789                   || old_sym->attr.intrinsic
3790                   || old_sym->attr.generic
3791                   || old_sym->attr.flavor == FL_NAMELIST
3792                   || old_sym->attr.proc == PROC_ST_FUNCTION))
3793         {
3794           /* Replace it with the symbol from the parent namespace.  */
3795           st->n.sym = sym;
3796           sym->refs++;
3797
3798           gfc_release_symbol (old_sym);
3799         }
3800
3801 fixup_contained:
3802       /* Do the same for any contained procedures.  */
3803       gfc_fixup_sibling_symbols (sym, ns->contained);
3804     }
3805 }
3806
3807 static void
3808 parse_contained (int module)
3809 {
3810   gfc_namespace *ns, *parent_ns, *tmp;
3811   gfc_state_data s1, s2;
3812   gfc_statement st;
3813   gfc_symbol *sym;
3814   gfc_entry_list *el;
3815   int contains_statements = 0;
3816   int seen_error = 0;
3817
3818   push_state (&s1, COMP_CONTAINS, NULL);
3819   parent_ns = gfc_current_ns;
3820
3821   do
3822     {
3823       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3824
3825       gfc_current_ns->sibling = parent_ns->contained;
3826       parent_ns->contained = gfc_current_ns;
3827
3828  next:
3829       /* Process the next available statement.  We come here if we got an error
3830          and rejected the last statement.  */
3831       st = next_statement ();
3832
3833       switch (st)
3834         {
3835         case ST_NONE:
3836           unexpected_eof ();
3837
3838         case ST_FUNCTION:
3839         case ST_SUBROUTINE:
3840           contains_statements = 1;
3841           accept_statement (st);
3842
3843           push_state (&s2,
3844                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3845                       gfc_new_block);
3846
3847           /* For internal procedures, create/update the symbol in the
3848              parent namespace.  */
3849
3850           if (!module)
3851             {
3852               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3853                 gfc_error ("Contained procedure '%s' at %C is already "
3854                            "ambiguous", gfc_new_block->name);
3855               else
3856                 {
3857                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3858                                          &gfc_new_block->declared_at) ==
3859                       SUCCESS)
3860                     {
3861                       if (st == ST_FUNCTION)
3862                         gfc_add_function (&sym->attr, sym->name,
3863                                           &gfc_new_block->declared_at);
3864                       else
3865                         gfc_add_subroutine (&sym->attr, sym->name,
3866                                             &gfc_new_block->declared_at);
3867                     }
3868                 }
3869
3870               gfc_commit_symbols ();
3871             }
3872           else
3873             sym = gfc_new_block;
3874
3875           /* Mark this as a contained function, so it isn't replaced
3876              by other module functions.  */
3877           sym->attr.contained = 1;
3878           sym->attr.referenced = 1;
3879
3880           parse_progunit (ST_NONE);
3881
3882           /* Fix up any sibling functions that refer to this one.  */
3883           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3884           /* Or refer to any of its alternate entry points.  */
3885           for (el = gfc_current_ns->entries; el; el = el->next)
3886             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3887
3888           gfc_current_ns->code = s2.head;
3889           gfc_current_ns = parent_ns;
3890
3891           pop_state ();
3892           break;
3893
3894         /* These statements are associated with the end of the host unit.  */
3895         case ST_END_FUNCTION:
3896         case ST_END_MODULE:
3897         case ST_END_PROGRAM:
3898         case ST_END_SUBROUTINE:
3899           accept_statement (st);
3900           break;
3901
3902         default:
3903           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3904                      gfc_ascii_statement (st));
3905           reject_statement ();
3906           seen_error = 1;
3907           goto next;
3908           break;
3909         }
3910     }
3911   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3912          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3913
3914   /* The first namespace in the list is guaranteed to not have
3915      anything (worthwhile) in it.  */
3916   tmp = gfc_current_ns;
3917   gfc_current_ns = parent_ns;
3918   if (seen_error && tmp->refs > 1)
3919     gfc_free_namespace (tmp);
3920
3921   ns = gfc_current_ns->contained;
3922   gfc_current_ns->contained = ns->sibling;
3923   gfc_free_namespace (ns);
3924
3925   pop_state ();
3926   if (!contains_statements)
3927     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3928                     "FUNCTION or SUBROUTINE statement at %C");
3929 }
3930
3931
3932 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
3933
3934 static void
3935 parse_progunit (gfc_statement st)
3936 {
3937   gfc_state_data *p;
3938   int n;
3939
3940   st = parse_spec (st);
3941   switch (st)
3942     {
3943     case ST_NONE:
3944       unexpected_eof ();
3945
3946     case ST_CONTAINS:
3947       /* This is not allowed within BLOCK!  */
3948       if (gfc_current_state () != COMP_BLOCK)
3949         goto contains;
3950       break;
3951
3952     case_end:
3953       accept_statement (st);
3954       goto done;
3955
3956     default:
3957       break;
3958     }
3959
3960   if (gfc_current_state () == COMP_FUNCTION)
3961     gfc_check_function_type (gfc_current_ns);
3962
3963 loop:
3964   for (;;)
3965     {
3966       st = parse_executable (st);
3967
3968       switch (st)
3969         {
3970         case ST_NONE:
3971           unexpected_eof ();
3972
3973         case ST_CONTAINS:
3974           /* This is not allowed within BLOCK!  */
3975           if (gfc_current_state () != COMP_BLOCK)
3976             goto contains;
3977           break;
3978
3979         case_end:
3980           accept_statement (st);
3981           goto done;
3982
3983         default:
3984           break;
3985         }
3986
3987       unexpected_statement (st);
3988       reject_statement ();
3989       st = next_statement ();
3990     }
3991
3992 contains:
3993   n = 0;
3994
3995   for (p = gfc_state_stack; p; p = p->previous)
3996     if (p->state == COMP_CONTAINS)
3997       n++;
3998
3999   if (gfc_find_state (COMP_MODULE) == SUCCESS)
4000     n--;
4001
4002   if (n > 0)
4003     {
4004       gfc_error ("CONTAINS statement at %C is already in a contained "
4005                  "program unit");
4006       reject_statement ();
4007       st = next_statement ();
4008       goto loop;
4009     }
4010
4011   parse_contained (0);
4012
4013 done:
4014   gfc_current_ns->code = gfc_state_stack->head;
4015 }
4016
4017
4018 /* Come here to complain about a global symbol already in use as
4019    something else.  */
4020
4021 void
4022 gfc_global_used (gfc_gsymbol *sym, locus *where)
4023 {
4024   const char *name;
4025
4026   if (where == NULL)
4027     where = &gfc_current_locus;
4028
4029   switch(sym->type)
4030     {
4031     case GSYM_PROGRAM:
4032       name = "PROGRAM";
4033       break;
4034     case GSYM_FUNCTION:
4035       name = "FUNCTION";
4036       break;
4037     case GSYM_SUBROUTINE:
4038       name = "SUBROUTINE";
4039       break;
4040     case GSYM_COMMON:
4041       name = "COMMON";
4042       break;
4043     case GSYM_BLOCK_DATA:
4044       name = "BLOCK DATA";
4045       break;
4046     case GSYM_MODULE:
4047       name = "MODULE";
4048       break;
4049     default:
4050       gfc_internal_error ("gfc_global_used(): Bad type");
4051       name = NULL;
4052     }
4053
4054   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
4055               sym->name, where, name, &sym->where);
4056 }
4057
4058
4059 /* Parse a block data program unit.  */
4060
4061 static void
4062 parse_block_data (void)
4063 {
4064   gfc_statement st;
4065   static locus blank_locus;
4066   static int blank_block=0;
4067   gfc_gsymbol *s;
4068
4069   gfc_current_ns->proc_name = gfc_new_block;
4070   gfc_current_ns->is_block_data = 1;
4071
4072   if (gfc_new_block == NULL)
4073     {
4074       if (blank_block)
4075        gfc_error ("Blank BLOCK DATA at %C conflicts with "
4076                   "prior BLOCK DATA at %L", &blank_locus);
4077       else
4078        {
4079          blank_block = 1;
4080          blank_locus = gfc_current_locus;
4081        }
4082     }
4083   else
4084     {
4085       s = gfc_get_gsymbol (gfc_new_block->name);
4086       if (s->defined
4087           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
4088        gfc_global_used(s, NULL);
4089       else
4090        {
4091          s->type = GSYM_BLOCK_DATA;
4092          s->where = gfc_current_locus;
4093          s->defined = 1;
4094        }
4095     }
4096
4097   st = parse_spec (ST_NONE);
4098
4099   while (st != ST_END_BLOCK_DATA)
4100     {
4101       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4102                  gfc_ascii_statement (st));
4103       reject_statement ();
4104       st = next_statement ();
4105     }
4106 }
4107
4108
4109 /* Parse a module subprogram.  */
4110
4111 static void
4112 parse_module (void)
4113 {
4114   gfc_statement st;
4115   gfc_gsymbol *s;
4116
4117   s = gfc_get_gsymbol (gfc_new_block->name);
4118   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4119     gfc_global_used(s, NULL);
4120   else
4121     {
4122       s->type = GSYM_MODULE;
4123       s->where = gfc_current_locus;
4124       s->defined = 1;
4125     }
4126
4127   st = parse_spec (ST_NONE);
4128
4129 loop:
4130   switch (st)
4131     {
4132     case ST_NONE:
4133       unexpected_eof ();
4134
4135     case ST_CONTAINS:
4136       parse_contained (1);
4137       break;
4138
4139     case ST_END_MODULE:
4140       accept_statement (st);
4141       break;
4142
4143     default:
4144       gfc_error ("Unexpected %s statement in MODULE at %C",
4145                  gfc_ascii_statement (st));
4146
4147       reject_statement ();
4148       st = next_statement ();
4149       goto loop;
4150     }
4151
4152   s->ns = gfc_current_ns;
4153 }
4154
4155
4156 /* Add a procedure name to the global symbol table.  */
4157
4158 static void
4159 add_global_procedure (int sub)
4160 {
4161   gfc_gsymbol *s;
4162
4163   s = gfc_get_gsymbol(gfc_new_block->name);
4164
4165   if (s->defined
4166       || (s->type != GSYM_UNKNOWN
4167           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4168     gfc_global_used(s, NULL);
4169   else
4170     {
4171       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4172       s->where = gfc_current_locus;
4173       s->defined = 1;
4174       s->ns = gfc_current_ns;
4175     }
4176 }
4177
4178
4179 /* Add a program to the global symbol table.  */
4180
4181 static void
4182 add_global_program (void)
4183 {
4184   gfc_gsymbol *s;
4185
4186   if (gfc_new_block == NULL)
4187     return;
4188   s = gfc_get_gsymbol (gfc_new_block->name);
4189
4190   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4191     gfc_global_used(s, NULL);
4192   else
4193     {
4194       s->type = GSYM_PROGRAM;
4195       s->where = gfc_current_locus;
4196       s->defined = 1;
4197       s->ns = gfc_current_ns;
4198     }
4199 }
4200
4201
4202 /* Resolve all the program units when whole file scope option
4203    is active. */
4204 static void
4205 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4206 {
4207   gfc_free_dt_list ();
4208   gfc_current_ns = gfc_global_ns_list;
4209   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4210     {
4211       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4212       gfc_resolve (gfc_current_ns);
4213       gfc_current_ns->derived_types = gfc_derived_types;
4214       gfc_derived_types = NULL;
4215     }
4216 }
4217
4218
4219 static void
4220 clean_up_modules (gfc_gsymbol *gsym)
4221 {
4222   if (gsym == NULL)
4223     return;
4224
4225   clean_up_modules (gsym->left);
4226   clean_up_modules (gsym->right);
4227
4228   if (gsym->type != GSYM_MODULE || !gsym->ns)
4229     return;
4230
4231   gfc_current_ns = gsym->ns;
4232   gfc_derived_types = gfc_current_ns->derived_types;
4233   gfc_done_2 ();
4234   gsym->ns = NULL;
4235   return;
4236 }
4237
4238
4239 /* Translate all the program units when whole file scope option
4240    is active. This could be in a different order to resolution if
4241    there are forward references in the file.  */
4242 static void
4243 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4244 {
4245   int errors;
4246
4247   gfc_current_ns = gfc_global_ns_list;
4248   gfc_get_errors (NULL, &errors);
4249
4250   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4251     {
4252       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4253       gfc_derived_types = gfc_current_ns->derived_types;
4254       gfc_generate_code (gfc_current_ns);
4255       gfc_current_ns->translated = 1;
4256     }
4257
4258   /* Clean up all the namespaces after translation.  */
4259   gfc_current_ns = gfc_global_ns_list;
4260   for (;gfc_current_ns;)
4261     {
4262       gfc_namespace *ns = gfc_current_ns->sibling;
4263       gfc_derived_types = gfc_current_ns->derived_types;
4264       gfc_done_2 ();
4265       gfc_current_ns = ns;
4266     }
4267
4268   clean_up_modules (gfc_gsym_root);
4269 }
4270
4271
4272 /* Top level parser.  */
4273
4274 gfc_try
4275 gfc_parse_file (void)
4276 {
4277   int seen_program, errors_before, errors;
4278   gfc_state_data top, s;
4279   gfc_statement st;
4280   locus prog_locus;
4281   gfc_namespace *next;
4282
4283   gfc_start_source_files ();
4284
4285   top.state = COMP_NONE;
4286   top.sym = NULL;
4287   top.previous = NULL;
4288   top.head = top.tail = NULL;
4289   top.do_variable = NULL;
4290
4291   gfc_state_stack = &top;
4292
4293   gfc_clear_new_st ();
4294
4295   gfc_statement_label = NULL;
4296
4297   if (setjmp (eof_buf))
4298     return FAILURE;     /* Come here on unexpected EOF */
4299
4300   /* Prepare the global namespace that will contain the
4301      program units.  */
4302   gfc_global_ns_list = next = NULL;
4303
4304   seen_program = 0;
4305
4306   /* Exit early for empty files.  */
4307   if (gfc_at_eof ())
4308     goto done;
4309
4310 loop:
4311   gfc_init_2 ();
4312   st = next_statement ();
4313   switch (st)
4314     {
4315     case ST_NONE:
4316       gfc_done_2 ();
4317       goto done;
4318
4319     case ST_PROGRAM:
4320       if (seen_program)
4321         goto duplicate_main;
4322       seen_program = 1;
4323       prog_locus = gfc_current_locus;
4324
4325       push_state (&s, COMP_PROGRAM, gfc_new_block);
4326       main_program_symbol(gfc_current_ns, gfc_new_block->name);
4327       accept_statement (st);
4328       add_global_program ();
4329       parse_progunit (ST_NONE);
4330       if (gfc_option.flag_whole_file)
4331         goto prog_units;
4332       break;
4333
4334     case ST_SUBROUTINE:
4335       add_global_procedure (1);
4336       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4337       accept_statement (st);
4338       parse_progunit (ST_NONE);
4339       if (gfc_option.flag_whole_file)
4340         goto prog_units;
4341       break;
4342
4343     case ST_FUNCTION:
4344       add_global_procedure (0);
4345       push_state (&s, COMP_FUNCTION, gfc_new_block);
4346       accept_statement (st);
4347       parse_progunit (ST_NONE);
4348       if (gfc_option.flag_whole_file)
4349         goto prog_units;
4350       break;
4351
4352     case ST_BLOCK_DATA:
4353       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4354       accept_statement (st);
4355       parse_block_data ();
4356       break;
4357
4358     case ST_MODULE:
4359       push_state (&s, COMP_MODULE, gfc_new_block);
4360       accept_statement (st);
4361
4362       gfc_get_errors (NULL, &errors_before);
4363       parse_module ();
4364       break;
4365
4366     /* Anything else starts a nameless main program block.  */
4367     default:
4368       if (seen_program)
4369         goto duplicate_main;
4370       seen_program = 1;
4371       prog_locus = gfc_current_locus;
4372
4373       push_state (&s, COMP_PROGRAM, gfc_new_block);
4374       main_program_symbol (gfc_current_ns, "MAIN__");
4375       parse_progunit (st);
4376       if (gfc_option.flag_whole_file)
4377         goto prog_units;
4378       break;
4379     }
4380
4381   /* Handle the non-program units.  */
4382   gfc_current_ns->code = s.head;
4383
4384   gfc_resolve (gfc_current_ns);
4385
4386   /* Dump the parse tree if requested.  */
4387   if (gfc_option.dump_parse_tree)
4388     gfc_dump_parse_tree (gfc_current_ns, stdout);
4389
4390   gfc_get_errors (NULL, &errors);
4391   if (s.state == COMP_MODULE)
4392     {
4393       gfc_dump_module (s.sym->name, errors_before == errors);
4394       if (errors == 0)
4395         gfc_generate_module_code (gfc_current_ns);
4396       pop_state ();
4397       if (!gfc_option.flag_whole_file)
4398         gfc_done_2 ();
4399       else
4400         {
4401           gfc_current_ns->derived_types = gfc_derived_types;
4402           gfc_derived_types = NULL;
4403           gfc_current_ns = NULL;
4404         }
4405     }
4406   else
4407     {
4408       if (errors == 0)
4409         gfc_generate_code (gfc_current_ns);
4410       pop_state ();
4411       gfc_done_2 ();
4412     }
4413
4414   goto loop;
4415
4416 prog_units:
4417   /* The main program and non-contained procedures are put
4418      in the global namespace list, so that they can be processed
4419      later and all their interfaces resolved.  */
4420   gfc_current_ns->code = s.head;
4421   if (next)
4422     {
4423       for (; next->sibling; next = next->sibling)
4424         ;
4425       next->sibling = gfc_current_ns;
4426     }
4427   else
4428     gfc_global_ns_list = gfc_current_ns;
4429
4430   next = gfc_current_ns;
4431
4432   pop_state ();
4433   goto loop;
4434
4435   done:
4436
4437   if (!gfc_option.flag_whole_file)
4438     goto termination;
4439
4440   /* Do the resolution.  */
4441   resolve_all_program_units (gfc_global_ns_list);
4442
4443   /* Do the parse tree dump.  */
4444   gfc_current_ns
4445         = gfc_option.dump_parse_tree ? gfc_global_ns_list : NULL;
4446
4447   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4448     {
4449       gfc_dump_parse_tree (gfc_current_ns, stdout);
4450       fputs ("------------------------------------------\n\n", stdout);
4451     }
4452
4453   /* Do the translation.  */
4454   translate_all_program_units (gfc_global_ns_list);
4455
4456 termination:
4457
4458   gfc_end_source_files ();
4459   return SUCCESS;
4460
4461 duplicate_main:
4462   /* If we see a duplicate main program, shut down.  If the second
4463      instance is an implied main program, i.e. data decls or executable
4464      statements, we're in for lots of errors.  */
4465   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
4466   reject_statement ();
4467   gfc_done_2 ();
4468   return SUCCESS;
4469 }