gcc/fortran/parse.c

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