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