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   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   static int numblock = 1;
3139
3140   my_ns = gfc_get_namespace (parent_ns, 1);
3141   my_ns->construct_entities = 1;
3142
3143   /* Give the BLOCK a symbol of flavor LABEL; this is later needed for correct
3144      code generation (so it must not be NULL).
3145      We set its recursive argument if our container procedure is recursive, so
3146      that local variables are accordingly placed on the stack when it
3147      will be necessary.  */
3148   if (gfc_new_block)
3149     my_ns->proc_name = gfc_new_block;
3150   else
3151     {
3152       gfc_try t;
3153       char buffer[20];  /* Enough to hold "block@2147483648\n".  */
3154
3155       snprintf(buffer, sizeof(buffer), "block@%d", numblock++);
3156       gfc_get_symbol (buffer, my_ns, &my_ns->proc_name);
3157       t = gfc_add_flavor (&my_ns->proc_name->attr, FL_LABEL,
3158                           my_ns->proc_name->name, NULL);
3159       gcc_assert (t == SUCCESS);
3160       gfc_commit_symbol (my_ns->proc_name);
3161     }
3162
3163   if (parent_ns->proc_name)
3164     my_ns->proc_name->attr.recursive = parent_ns->proc_name->attr.recursive;
3165
3166   return my_ns;
3167 }
3168
3169
3170 /* Parse a BLOCK construct.  */
3171
3172 static void
3173 parse_block_construct (void)
3174 {
3175   gfc_namespace* my_ns;
3176   gfc_state_data s;
3177
3178   gfc_notify_std (GFC_STD_F2008, "Fortran 2008: BLOCK construct at %C");
3179
3180   my_ns = gfc_build_block_ns (gfc_current_ns);
3181
3182   new_st.op = EXEC_BLOCK;
3183   new_st.ext.block.ns = my_ns;
3184   new_st.ext.block.assoc = NULL;
3185   accept_statement (ST_BLOCK);
3186
3187   push_state (&s, COMP_BLOCK, my_ns->proc_name);
3188   gfc_current_ns = my_ns;
3189
3190   parse_progunit (ST_NONE);
3191
3192   gfc_current_ns = gfc_current_ns->parent;
3193   pop_state ();
3194 }
3195
3196
3197 /* Parse an ASSOCIATE construct.  This is essentially a BLOCK construct
3198    behind the scenes with compiler-generated variables.  */
3199
3200 static void
3201 parse_associate (void)
3202 {
3203   gfc_namespace* my_ns;
3204   gfc_state_data s;
3205   gfc_statement st;
3206   gfc_association_list* a;
3207
3208   gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ASSOCIATE construct at %C");
3209
3210   my_ns = gfc_build_block_ns (gfc_current_ns);
3211
3212   new_st.op = EXEC_BLOCK;
3213   new_st.ext.block.ns = my_ns;
3214   gcc_assert (new_st.ext.block.assoc);
3215
3216   /* Add all associate-names as BLOCK variables.  Creating them is enough
3217      for now, they'll get their values during trans-* phase.  */
3218   gfc_current_ns = my_ns;
3219   for (a = new_st.ext.block.assoc; a; a = a->next)
3220     {
3221       gfc_symbol* sym;
3222
3223       if (gfc_get_sym_tree (a->name, NULL, &a->st, false))
3224         gcc_unreachable ();
3225
3226       sym = a->st->n.sym;
3227       sym->attr.flavor = FL_VARIABLE;
3228       sym->assoc = a;
3229       sym->declared_at = a->where;
3230       gfc_set_sym_referenced (sym);
3231
3232       /* Initialize the typespec.  It is not available in all cases,
3233          however, as it may only be set on the target during resolution.
3234          Still, sometimes it helps to have it right now -- especially
3235          for parsing component references on the associate-name
3236          in case of assication to a derived-type.  */
3237       sym->ts = a->target->ts;
3238     }
3239
3240   accept_statement (ST_ASSOCIATE);
3241   push_state (&s, COMP_ASSOCIATE, my_ns->proc_name);
3242
3243 loop:
3244   st = parse_executable (ST_NONE);
3245   switch (st)
3246     {
3247     case ST_NONE:
3248       unexpected_eof ();
3249
3250     case_end:
3251       accept_statement (st);
3252       my_ns->code = gfc_state_stack->head;
3253       break;
3254
3255     default:
3256       unexpected_statement (st);
3257       goto loop;
3258     }
3259
3260   gfc_current_ns = gfc_current_ns->parent;
3261   pop_state ();
3262 }
3263
3264
3265 /* Parse a DO loop.  Note that the ST_CYCLE and ST_EXIT statements are
3266    handled inside of parse_executable(), because they aren't really
3267    loop statements.  */
3268
3269 static void
3270 parse_do_block (void)
3271 {
3272   gfc_statement st;
3273   gfc_code *top;
3274   gfc_state_data s;
3275   gfc_symtree *stree;
3276
3277   s.ext.end_do_label = new_st.label1;
3278
3279   if (new_st.ext.iterator != NULL)
3280     stree = new_st.ext.iterator->var->symtree;
3281   else
3282     stree = NULL;
3283
3284   accept_statement (ST_DO);
3285
3286   top = gfc_state_stack->tail;
3287   push_state (&s, COMP_DO, gfc_new_block);
3288
3289   s.do_variable = stree;
3290
3291   top->block = new_level (top);
3292   top->block->op = EXEC_DO;
3293
3294 loop:
3295   st = parse_executable (ST_NONE);
3296
3297   switch (st)
3298     {
3299     case ST_NONE:
3300       unexpected_eof ();
3301
3302     case ST_ENDDO:
3303       if (s.ext.end_do_label != NULL
3304           && s.ext.end_do_label != gfc_statement_label)
3305         gfc_error_now ("Statement label in ENDDO at %C doesn't match "
3306                        "DO label");
3307
3308       if (gfc_statement_label != NULL)
3309         {
3310           new_st.op = EXEC_NOP;
3311           add_statement ();
3312         }
3313       break;
3314
3315     case ST_IMPLIED_ENDDO:
3316      /* If the do-stmt of this DO construct has a do-construct-name,
3317         the corresponding end-do must be an end-do-stmt (with a matching
3318         name, but in that case we must have seen ST_ENDDO first).
3319         We only complain about this in pedantic mode.  */
3320      if (gfc_current_block () != NULL)
3321         gfc_error_now ("Named block DO at %L requires matching ENDDO name",
3322                        &gfc_current_block()->declared_at);
3323
3324       break;
3325
3326     default:
3327       unexpected_statement (st);
3328       goto loop;
3329     }
3330
3331   pop_state ();
3332   accept_statement (st);
3333 }
3334
3335
3336 /* Parse the statements of OpenMP do/parallel do.  */
3337
3338 static gfc_statement
3339 parse_omp_do (gfc_statement omp_st)
3340 {
3341   gfc_statement st;
3342   gfc_code *cp, *np;
3343   gfc_state_data s;
3344
3345   accept_statement (omp_st);
3346
3347   cp = gfc_state_stack->tail;
3348   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3349   np = new_level (cp);
3350   np->op = cp->op;
3351   np->block = NULL;
3352
3353   for (;;)
3354     {
3355       st = next_statement ();
3356       if (st == ST_NONE)
3357         unexpected_eof ();
3358       else if (st == ST_DO)
3359         break;
3360       else
3361         unexpected_statement (st);
3362     }
3363
3364   parse_do_block ();
3365   if (gfc_statement_label != NULL
3366       && gfc_state_stack->previous != NULL
3367       && gfc_state_stack->previous->state == COMP_DO
3368       && gfc_state_stack->previous->ext.end_do_label == gfc_statement_label)
3369     {
3370       /* In
3371          DO 100 I=1,10
3372            !$OMP DO
3373              DO J=1,10
3374              ...
3375              100 CONTINUE
3376          there should be no !$OMP END DO.  */
3377       pop_state ();
3378       return ST_IMPLIED_ENDDO;
3379     }
3380
3381   check_do_closure ();
3382   pop_state ();
3383
3384   st = next_statement ();
3385   if (st == (omp_st == ST_OMP_DO ? ST_OMP_END_DO : ST_OMP_END_PARALLEL_DO))
3386     {
3387       if (new_st.op == EXEC_OMP_END_NOWAIT)
3388         cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3389       else
3390         gcc_assert (new_st.op == EXEC_NOP);
3391       gfc_clear_new_st ();
3392       gfc_commit_symbols ();
3393       gfc_warning_check ();
3394       st = next_statement ();
3395     }
3396   return st;
3397 }
3398
3399
3400 /* Parse the statements of OpenMP atomic directive.  */
3401
3402 static void
3403 parse_omp_atomic (void)
3404 {
3405   gfc_statement st;
3406   gfc_code *cp, *np;
3407   gfc_state_data s;
3408
3409   accept_statement (ST_OMP_ATOMIC);
3410
3411   cp = gfc_state_stack->tail;
3412   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3413   np = new_level (cp);
3414   np->op = cp->op;
3415   np->block = NULL;
3416
3417   for (;;)
3418     {
3419       st = next_statement ();
3420       if (st == ST_NONE)
3421         unexpected_eof ();
3422       else if (st == ST_ASSIGNMENT)
3423         break;
3424       else
3425         unexpected_statement (st);
3426     }
3427
3428   accept_statement (st);
3429
3430   pop_state ();
3431 }
3432
3433
3434 /* Parse the statements of an OpenMP structured block.  */
3435
3436 static void
3437 parse_omp_structured_block (gfc_statement omp_st, bool workshare_stmts_only)
3438 {
3439   gfc_statement st, omp_end_st;
3440   gfc_code *cp, *np;
3441   gfc_state_data s;
3442
3443   accept_statement (omp_st);
3444
3445   cp = gfc_state_stack->tail;
3446   push_state (&s, COMP_OMP_STRUCTURED_BLOCK, NULL);
3447   np = new_level (cp);
3448   np->op = cp->op;
3449   np->block = NULL;
3450
3451   switch (omp_st)
3452     {
3453     case ST_OMP_PARALLEL:
3454       omp_end_st = ST_OMP_END_PARALLEL;
3455       break;
3456     case ST_OMP_PARALLEL_SECTIONS:
3457       omp_end_st = ST_OMP_END_PARALLEL_SECTIONS;
3458       break;
3459     case ST_OMP_SECTIONS:
3460       omp_end_st = ST_OMP_END_SECTIONS;
3461       break;
3462     case ST_OMP_ORDERED:
3463       omp_end_st = ST_OMP_END_ORDERED;
3464       break;
3465     case ST_OMP_CRITICAL:
3466       omp_end_st = ST_OMP_END_CRITICAL;
3467       break;
3468     case ST_OMP_MASTER:
3469       omp_end_st = ST_OMP_END_MASTER;
3470       break;
3471     case ST_OMP_SINGLE:
3472       omp_end_st = ST_OMP_END_SINGLE;
3473       break;
3474     case ST_OMP_TASK:
3475       omp_end_st = ST_OMP_END_TASK;
3476       break;
3477     case ST_OMP_WORKSHARE:
3478       omp_end_st = ST_OMP_END_WORKSHARE;
3479       break;
3480     case ST_OMP_PARALLEL_WORKSHARE:
3481       omp_end_st = ST_OMP_END_PARALLEL_WORKSHARE;
3482       break;
3483     default:
3484       gcc_unreachable ();
3485     }
3486
3487   do
3488     {
3489       if (workshare_stmts_only)
3490         {
3491           /* Inside of !$omp workshare, only
3492              scalar assignments
3493              array assignments
3494              where statements and constructs
3495              forall statements and constructs
3496              !$omp atomic
3497              !$omp critical
3498              !$omp parallel
3499              are allowed.  For !$omp critical these
3500              restrictions apply recursively.  */
3501           bool cycle = true;
3502
3503           st = next_statement ();
3504           for (;;)
3505             {
3506               switch (st)
3507                 {
3508                 case ST_NONE:
3509                   unexpected_eof ();
3510
3511                 case ST_ASSIGNMENT:
3512                 case ST_WHERE:
3513                 case ST_FORALL:
3514                   accept_statement (st);
3515                   break;
3516
3517                 case ST_WHERE_BLOCK:
3518                   parse_where_block ();
3519                   break;
3520
3521                 case ST_FORALL_BLOCK:
3522                   parse_forall_block ();
3523                   break;
3524
3525                 case ST_OMP_PARALLEL:
3526                 case ST_OMP_PARALLEL_SECTIONS:
3527                   parse_omp_structured_block (st, false);
3528                   break;
3529
3530                 case ST_OMP_PARALLEL_WORKSHARE:
3531                 case ST_OMP_CRITICAL:
3532                   parse_omp_structured_block (st, true);
3533                   break;
3534
3535                 case ST_OMP_PARALLEL_DO:
3536                   st = parse_omp_do (st);
3537                   continue;
3538
3539                 case ST_OMP_ATOMIC:
3540                   parse_omp_atomic ();
3541                   break;
3542
3543                 default:
3544                   cycle = false;
3545                   break;
3546                 }
3547
3548               if (!cycle)
3549                 break;
3550
3551               st = next_statement ();
3552             }
3553         }
3554       else
3555         st = parse_executable (ST_NONE);
3556       if (st == ST_NONE)
3557         unexpected_eof ();
3558       else if (st == ST_OMP_SECTION
3559                && (omp_st == ST_OMP_SECTIONS
3560                    || omp_st == ST_OMP_PARALLEL_SECTIONS))
3561         {
3562           np = new_level (np);
3563           np->op = cp->op;
3564           np->block = NULL;
3565         }
3566       else if (st != omp_end_st)
3567         unexpected_statement (st);
3568     }
3569   while (st != omp_end_st);
3570
3571   switch (new_st.op)
3572     {
3573     case EXEC_OMP_END_NOWAIT:
3574       cp->ext.omp_clauses->nowait |= new_st.ext.omp_bool;
3575       break;
3576     case EXEC_OMP_CRITICAL:
3577       if (((cp->ext.omp_name == NULL) ^ (new_st.ext.omp_name == NULL))
3578           || (new_st.ext.omp_name != NULL
3579               && strcmp (cp->ext.omp_name, new_st.ext.omp_name) != 0))
3580         gfc_error ("Name after !$omp critical and !$omp end critical does "
3581                    "not match at %C");
3582       free (CONST_CAST (char *, new_st.ext.omp_name));
3583       break;
3584     case EXEC_OMP_END_SINGLE:
3585       cp->ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE]
3586         = new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE];
3587       new_st.ext.omp_clauses->lists[OMP_LIST_COPYPRIVATE] = NULL;
3588       gfc_free_omp_clauses (new_st.ext.omp_clauses);
3589       break;
3590     case EXEC_NOP:
3591       break;
3592     default:
3593       gcc_unreachable ();
3594     }
3595
3596   gfc_clear_new_st ();
3597   gfc_commit_symbols ();
3598   gfc_warning_check ();
3599   pop_state ();
3600 }
3601
3602
3603 /* Accept a series of executable statements.  We return the first
3604    statement that doesn't fit to the caller.  Any block statements are
3605    passed on to the correct handler, which usually passes the buck
3606    right back here.  */
3607
3608 static gfc_statement
3609 parse_executable (gfc_statement st)
3610 {
3611   int close_flag;
3612
3613   if (st == ST_NONE)
3614     st = next_statement ();
3615
3616   for (;;)
3617     {
3618       close_flag = check_do_closure ();
3619       if (close_flag)
3620         switch (st)
3621           {
3622           case ST_GOTO:
3623           case ST_END_PROGRAM:
3624           case ST_RETURN:
3625           case ST_EXIT:
3626           case ST_END_FUNCTION:
3627           case ST_CYCLE:
3628           case ST_PAUSE:
3629           case ST_STOP:
3630           case ST_ERROR_STOP:
3631           case ST_END_SUBROUTINE:
3632
3633           case ST_DO:
3634           case ST_FORALL:
3635           case ST_WHERE:
3636           case ST_SELECT_CASE:
3637             gfc_error ("%s statement at %C cannot terminate a non-block "
3638                        "DO loop", gfc_ascii_statement (st));
3639             break;
3640
3641           default:
3642             break;
3643           }
3644
3645       switch (st)
3646         {
3647         case ST_NONE:
3648           unexpected_eof ();
3649
3650         case ST_FORMAT:
3651         case ST_DATA:
3652         case ST_ENTRY:
3653         case_executable:
3654           accept_statement (st);
3655           if (close_flag == 1)
3656             return ST_IMPLIED_ENDDO;
3657           break;
3658
3659         case ST_BLOCK:
3660           parse_block_construct ();
3661           break;
3662
3663         case ST_ASSOCIATE:
3664           parse_associate ();
3665           break;
3666
3667         case ST_IF_BLOCK:
3668           parse_if_block ();
3669           break;
3670
3671         case ST_SELECT_CASE:
3672           parse_select_block ();
3673           break;
3674
3675         case ST_SELECT_TYPE:
3676           parse_select_type_block();
3677           break;
3678
3679         case ST_DO:
3680           parse_do_block ();
3681           if (check_do_closure () == 1)
3682             return ST_IMPLIED_ENDDO;
3683           break;
3684
3685         case ST_CRITICAL:
3686           parse_critical_block ();
3687           break;
3688
3689         case ST_WHERE_BLOCK:
3690           parse_where_block ();
3691           break;
3692
3693         case ST_FORALL_BLOCK:
3694           parse_forall_block ();
3695           break;
3696
3697         case ST_OMP_PARALLEL:
3698         case ST_OMP_PARALLEL_SECTIONS:
3699         case ST_OMP_SECTIONS:
3700         case ST_OMP_ORDERED:
3701         case ST_OMP_CRITICAL:
3702         case ST_OMP_MASTER:
3703         case ST_OMP_SINGLE:
3704         case ST_OMP_TASK:
3705           parse_omp_structured_block (st, false);
3706           break;
3707
3708         case ST_OMP_WORKSHARE:
3709         case ST_OMP_PARALLEL_WORKSHARE:
3710           parse_omp_structured_block (st, true);
3711           break;
3712
3713         case ST_OMP_DO:
3714         case ST_OMP_PARALLEL_DO:
3715           st = parse_omp_do (st);
3716           if (st == ST_IMPLIED_ENDDO)
3717             return st;
3718           continue;
3719
3720         case ST_OMP_ATOMIC:
3721           parse_omp_atomic ();
3722           break;
3723
3724         default:
3725           return st;
3726         }
3727
3728       st = next_statement ();
3729     }
3730 }
3731
3732
3733 /* Fix the symbols for sibling functions.  These are incorrectly added to
3734    the child namespace as the parser didn't know about this procedure.  */
3735
3736 static void
3737 gfc_fixup_sibling_symbols (gfc_symbol *sym, gfc_namespace *siblings)
3738 {
3739   gfc_namespace *ns;
3740   gfc_symtree *st;
3741   gfc_symbol *old_sym;
3742
3743   sym->attr.referenced = 1;
3744   for (ns = siblings; ns; ns = ns->sibling)
3745     {
3746       st = gfc_find_symtree (ns->sym_root, sym->name);
3747
3748       if (!st || (st->n.sym->attr.dummy && ns == st->n.sym->ns))
3749         goto fixup_contained;
3750
3751       old_sym = st->n.sym;
3752       if (old_sym->ns == ns
3753             && !old_sym->attr.contained
3754
3755             /* By 14.6.1.3, host association should be excluded
3756                for the following.  */
3757             && !(old_sym->attr.external
3758                   || (old_sym->ts.type != BT_UNKNOWN
3759                         && !old_sym->attr.implicit_type)
3760                   || old_sym->attr.flavor == FL_PARAMETER
3761                   || old_sym->attr.use_assoc
3762                   || old_sym->attr.in_common
3763                   || old_sym->attr.in_equivalence
3764                   || old_sym->attr.data
3765                   || old_sym->attr.dummy
3766                   || old_sym->attr.result
3767                   || old_sym->attr.dimension
3768                   || old_sym->attr.allocatable
3769                   || old_sym->attr.intrinsic
3770                   || old_sym->attr.generic
3771                   || old_sym->attr.flavor == FL_NAMELIST
3772                   || old_sym->attr.proc == PROC_ST_FUNCTION))
3773         {
3774           /* Replace it with the symbol from the parent namespace.  */
3775           st->n.sym = sym;
3776           sym->refs++;
3777
3778           gfc_release_symbol (old_sym);
3779         }
3780
3781 fixup_contained:
3782       /* Do the same for any contained procedures.  */
3783       gfc_fixup_sibling_symbols (sym, ns->contained);
3784     }
3785 }
3786
3787 static void
3788 parse_contained (int module)
3789 {
3790   gfc_namespace *ns, *parent_ns, *tmp;
3791   gfc_state_data s1, s2;
3792   gfc_statement st;
3793   gfc_symbol *sym;
3794   gfc_entry_list *el;
3795   int contains_statements = 0;
3796   int seen_error = 0;
3797
3798   push_state (&s1, COMP_CONTAINS, NULL);
3799   parent_ns = gfc_current_ns;
3800
3801   do
3802     {
3803       gfc_current_ns = gfc_get_namespace (parent_ns, 1);
3804
3805       gfc_current_ns->sibling = parent_ns->contained;
3806       parent_ns->contained = gfc_current_ns;
3807
3808  next:
3809       /* Process the next available statement.  We come here if we got an error
3810          and rejected the last statement.  */
3811       st = next_statement ();
3812
3813       switch (st)
3814         {
3815         case ST_NONE:
3816           unexpected_eof ();
3817
3818         case ST_FUNCTION:
3819         case ST_SUBROUTINE:
3820           contains_statements = 1;
3821           accept_statement (st);
3822
3823           push_state (&s2,
3824                       (st == ST_FUNCTION) ? COMP_FUNCTION : COMP_SUBROUTINE,
3825                       gfc_new_block);
3826
3827           /* For internal procedures, create/update the symbol in the
3828              parent namespace.  */
3829
3830           if (!module)
3831             {
3832               if (gfc_get_symbol (gfc_new_block->name, parent_ns, &sym))
3833                 gfc_error ("Contained procedure '%s' at %C is already "
3834                            "ambiguous", gfc_new_block->name);
3835               else
3836                 {
3837                   if (gfc_add_procedure (&sym->attr, PROC_INTERNAL, sym->name,
3838                                          &gfc_new_block->declared_at) ==
3839                       SUCCESS)
3840                     {
3841                       if (st == ST_FUNCTION)
3842                         gfc_add_function (&sym->attr, sym->name,
3843                                           &gfc_new_block->declared_at);
3844                       else
3845                         gfc_add_subroutine (&sym->attr, sym->name,
3846                                             &gfc_new_block->declared_at);
3847                     }
3848                 }
3849
3850               gfc_commit_symbols ();
3851             }
3852           else
3853             sym = gfc_new_block;
3854
3855           /* Mark this as a contained function, so it isn't replaced
3856              by other module functions.  */
3857           sym->attr.contained = 1;
3858           sym->attr.referenced = 1;
3859
3860           /* Set implicit_pure so that it can be reset if any of the
3861              tests for purity fail.  This is used for some optimisation
3862              during translation.  */
3863           if (!sym->attr.pure)
3864             sym->attr.implicit_pure = 1;
3865
3866           parse_progunit (ST_NONE);
3867
3868           /* Fix up any sibling functions that refer to this one.  */
3869           gfc_fixup_sibling_symbols (sym, gfc_current_ns);
3870           /* Or refer to any of its alternate entry points.  */
3871           for (el = gfc_current_ns->entries; el; el = el->next)
3872             gfc_fixup_sibling_symbols (el->sym, gfc_current_ns);
3873
3874           gfc_current_ns->code = s2.head;
3875           gfc_current_ns = parent_ns;
3876
3877           pop_state ();
3878           break;
3879
3880         /* These statements are associated with the end of the host unit.  */
3881         case ST_END_FUNCTION:
3882         case ST_END_MODULE:
3883         case ST_END_PROGRAM:
3884         case ST_END_SUBROUTINE:
3885           accept_statement (st);
3886           break;
3887
3888         default:
3889           gfc_error ("Unexpected %s statement in CONTAINS section at %C",
3890                      gfc_ascii_statement (st));
3891           reject_statement ();
3892           seen_error = 1;
3893           goto next;
3894           break;
3895         }
3896     }
3897   while (st != ST_END_FUNCTION && st != ST_END_SUBROUTINE
3898          && st != ST_END_MODULE && st != ST_END_PROGRAM);
3899
3900   /* The first namespace in the list is guaranteed to not have
3901      anything (worthwhile) in it.  */
3902   tmp = gfc_current_ns;
3903   gfc_current_ns = parent_ns;
3904   if (seen_error && tmp->refs > 1)
3905     gfc_free_namespace (tmp);
3906
3907   ns = gfc_current_ns->contained;
3908   gfc_current_ns->contained = ns->sibling;
3909   gfc_free_namespace (ns);
3910
3911   pop_state ();
3912   if (!contains_statements)
3913     gfc_notify_std (GFC_STD_F2008, "Fortran 2008: CONTAINS statement without "
3914                     "FUNCTION or SUBROUTINE statement at %C");
3915 }
3916
3917
3918 /* Parse a PROGRAM, SUBROUTINE, FUNCTION unit or BLOCK construct.  */
3919
3920 static void
3921 parse_progunit (gfc_statement st)
3922 {
3923   gfc_state_data *p;
3924   int n;
3925
3926   st = parse_spec (st);
3927   switch (st)
3928     {
3929     case ST_NONE:
3930       unexpected_eof ();
3931
3932     case ST_CONTAINS:
3933       /* This is not allowed within BLOCK!  */
3934       if (gfc_current_state () != COMP_BLOCK)
3935         goto contains;
3936       break;
3937
3938     case_end:
3939       accept_statement (st);
3940       goto done;
3941
3942     default:
3943       break;
3944     }
3945
3946   if (gfc_current_state () == COMP_FUNCTION)
3947     gfc_check_function_type (gfc_current_ns);
3948
3949 loop:
3950   for (;;)
3951     {
3952       st = parse_executable (st);
3953
3954       switch (st)
3955         {
3956         case ST_NONE:
3957           unexpected_eof ();
3958
3959         case ST_CONTAINS:
3960           /* This is not allowed within BLOCK!  */
3961           if (gfc_current_state () != COMP_BLOCK)
3962             goto contains;
3963           break;
3964
3965         case_end:
3966           accept_statement (st);
3967           goto done;
3968
3969         default:
3970           break;
3971         }
3972
3973       unexpected_statement (st);
3974       reject_statement ();
3975       st = next_statement ();
3976     }
3977
3978 contains:
3979   n = 0;
3980
3981   for (p = gfc_state_stack; p; p = p->previous)
3982     if (p->state == COMP_CONTAINS)
3983       n++;
3984
3985   if (gfc_find_state (COMP_MODULE) == SUCCESS)
3986     n--;
3987
3988   if (n > 0)
3989     {
3990       gfc_error ("CONTAINS statement at %C is already in a contained "
3991                  "program unit");
3992       reject_statement ();
3993       st = next_statement ();
3994       goto loop;
3995     }
3996
3997   parse_contained (0);
3998
3999 done:
4000   gfc_current_ns->code = gfc_state_stack->head;
4001 }
4002
4003
4004 /* Come here to complain about a global symbol already in use as
4005    something else.  */
4006
4007 void
4008 gfc_global_used (gfc_gsymbol *sym, locus *where)
4009 {
4010   const char *name;
4011
4012   if (where == NULL)
4013     where = &gfc_current_locus;
4014
4015   switch(sym->type)
4016     {
4017     case GSYM_PROGRAM:
4018       name = "PROGRAM";
4019       break;
4020     case GSYM_FUNCTION:
4021       name = "FUNCTION";
4022       break;
4023     case GSYM_SUBROUTINE:
4024       name = "SUBROUTINE";
4025       break;
4026     case GSYM_COMMON:
4027       name = "COMMON";
4028       break;
4029     case GSYM_BLOCK_DATA:
4030       name = "BLOCK DATA";
4031       break;
4032     case GSYM_MODULE:
4033       name = "MODULE";
4034       break;
4035     default:
4036       gfc_internal_error ("gfc_global_used(): Bad type");
4037       name = NULL;
4038     }
4039
4040   gfc_error("Global name '%s' at %L is already being used as a %s at %L",
4041               sym->name, where, name, &sym->where);
4042 }
4043
4044
4045 /* Parse a block data program unit.  */
4046
4047 static void
4048 parse_block_data (void)
4049 {
4050   gfc_statement st;
4051   static locus blank_locus;
4052   static int blank_block=0;
4053   gfc_gsymbol *s;
4054
4055   gfc_current_ns->proc_name = gfc_new_block;
4056   gfc_current_ns->is_block_data = 1;
4057
4058   if (gfc_new_block == NULL)
4059     {
4060       if (blank_block)
4061        gfc_error ("Blank BLOCK DATA at %C conflicts with "
4062                   "prior BLOCK DATA at %L", &blank_locus);
4063       else
4064        {
4065          blank_block = 1;
4066          blank_locus = gfc_current_locus;
4067        }
4068     }
4069   else
4070     {
4071       s = gfc_get_gsymbol (gfc_new_block->name);
4072       if (s->defined
4073           || (s->type != GSYM_UNKNOWN && s->type != GSYM_BLOCK_DATA))
4074        gfc_global_used(s, NULL);
4075       else
4076        {
4077          s->type = GSYM_BLOCK_DATA;
4078          s->where = gfc_current_locus;
4079          s->defined = 1;
4080        }
4081     }
4082
4083   st = parse_spec (ST_NONE);
4084
4085   while (st != ST_END_BLOCK_DATA)
4086     {
4087       gfc_error ("Unexpected %s statement in BLOCK DATA at %C",
4088                  gfc_ascii_statement (st));
4089       reject_statement ();
4090       st = next_statement ();
4091     }
4092 }
4093
4094
4095 /* Parse a module subprogram.  */
4096
4097 static void
4098 parse_module (void)
4099 {
4100   gfc_statement st;
4101   gfc_gsymbol *s;
4102
4103   s = gfc_get_gsymbol (gfc_new_block->name);
4104   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_MODULE))
4105     gfc_global_used(s, NULL);
4106   else
4107     {
4108       s->type = GSYM_MODULE;
4109       s->where = gfc_current_locus;
4110       s->defined = 1;
4111     }
4112
4113   st = parse_spec (ST_NONE);
4114
4115 loop:
4116   switch (st)
4117     {
4118     case ST_NONE:
4119       unexpected_eof ();
4120
4121     case ST_CONTAINS:
4122       parse_contained (1);
4123       break;
4124
4125     case ST_END_MODULE:
4126       accept_statement (st);
4127       break;
4128
4129     default:
4130       gfc_error ("Unexpected %s statement in MODULE at %C",
4131                  gfc_ascii_statement (st));
4132
4133       reject_statement ();
4134       st = next_statement ();
4135       goto loop;
4136     }
4137
4138   s->ns = gfc_current_ns;
4139 }
4140
4141
4142 /* Add a procedure name to the global symbol table.  */
4143
4144 static void
4145 add_global_procedure (int sub)
4146 {
4147   gfc_gsymbol *s;
4148
4149   s = gfc_get_gsymbol(gfc_new_block->name);
4150
4151   if (s->defined
4152       || (s->type != GSYM_UNKNOWN
4153           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
4154     gfc_global_used(s, NULL);
4155   else
4156     {
4157       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
4158       s->where = gfc_current_locus;
4159       s->defined = 1;
4160       s->ns = gfc_current_ns;
4161     }
4162 }
4163
4164
4165 /* Add a program to the global symbol table.  */
4166
4167 static void
4168 add_global_program (void)
4169 {
4170   gfc_gsymbol *s;
4171
4172   if (gfc_new_block == NULL)
4173     return;
4174   s = gfc_get_gsymbol (gfc_new_block->name);
4175
4176   if (s->defined || (s->type != GSYM_UNKNOWN && s->type != GSYM_PROGRAM))
4177     gfc_global_used(s, NULL);
4178   else
4179     {
4180       s->type = GSYM_PROGRAM;
4181       s->where = gfc_current_locus;
4182       s->defined = 1;
4183       s->ns = gfc_current_ns;
4184     }
4185 }
4186
4187
4188 /* Resolve all the program units when whole file scope option
4189    is active. */
4190 static void
4191 resolve_all_program_units (gfc_namespace *gfc_global_ns_list)
4192 {
4193   gfc_free_dt_list ();
4194   gfc_current_ns = gfc_global_ns_list;
4195   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4196     {
4197       if (gfc_current_ns->proc_name
4198           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4199         continue; /* Already resolved.  */
4200
4201       if (gfc_current_ns->proc_name)
4202         gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4203       gfc_resolve (gfc_current_ns);
4204       gfc_current_ns->derived_types = gfc_derived_types;
4205       gfc_derived_types = NULL;
4206     }
4207 }
4208
4209
4210 static void
4211 clean_up_modules (gfc_gsymbol *gsym)
4212 {
4213   if (gsym == NULL)
4214     return;
4215
4216   clean_up_modules (gsym->left);
4217   clean_up_modules (gsym->right);
4218
4219   if (gsym->type != GSYM_MODULE || !gsym->ns)
4220     return;
4221
4222   gfc_current_ns = gsym->ns;
4223   gfc_derived_types = gfc_current_ns->derived_types;
4224   gfc_done_2 ();
4225   gsym->ns = NULL;
4226   return;
4227 }
4228
4229
4230 /* Translate all the program units when whole file scope option
4231    is active. This could be in a different order to resolution if
4232    there are forward references in the file.  */
4233 static void
4234 translate_all_program_units (gfc_namespace *gfc_global_ns_list)
4235 {
4236   int errors;
4237
4238   gfc_current_ns = gfc_global_ns_list;
4239   gfc_get_errors (NULL, &errors);
4240
4241   /* We first translate all modules to make sure that later parts
4242      of the program can use the decl. Then we translate the nonmodules.  */
4243
4244   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4245     {
4246       if (!gfc_current_ns->proc_name
4247           || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4248         continue;
4249
4250       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4251       gfc_derived_types = gfc_current_ns->derived_types;
4252       gfc_generate_module_code (gfc_current_ns);
4253       gfc_current_ns->translated = 1;
4254     }
4255
4256   gfc_current_ns = gfc_global_ns_list;
4257   for (; !errors && gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4258     {
4259       if (gfc_current_ns->proc_name
4260           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4261         continue;
4262
4263       gfc_current_locus = gfc_current_ns->proc_name->declared_at;
4264       gfc_derived_types = gfc_current_ns->derived_types;
4265       gfc_generate_code (gfc_current_ns);
4266       gfc_current_ns->translated = 1;
4267     }
4268
4269   /* Clean up all the namespaces after translation.  */
4270   gfc_current_ns = gfc_global_ns_list;
4271   for (;gfc_current_ns;)
4272     {
4273       gfc_namespace *ns;
4274
4275       if (gfc_current_ns->proc_name
4276           && gfc_current_ns->proc_name->attr.flavor == FL_MODULE)
4277         {
4278           gfc_current_ns = gfc_current_ns->sibling;
4279           continue;
4280         }
4281
4282       ns = gfc_current_ns->sibling;
4283       gfc_derived_types = gfc_current_ns->derived_types;
4284       gfc_done_2 ();
4285       gfc_current_ns = ns;
4286     }
4287
4288   clean_up_modules (gfc_gsym_root);
4289 }
4290
4291
4292 /* Top level parser.  */
4293
4294 gfc_try
4295 gfc_parse_file (void)
4296 {
4297   int seen_program, errors_before, errors;
4298   gfc_state_data top, s;
4299   gfc_statement st;
4300   locus prog_locus;
4301   gfc_namespace *next;
4302
4303   gfc_start_source_files ();
4304
4305   top.state = COMP_NONE;
4306   top.sym = NULL;
4307   top.previous = NULL;
4308   top.head = top.tail = NULL;
4309   top.do_variable = NULL;
4310
4311   gfc_state_stack = &top;
4312
4313   gfc_clear_new_st ();
4314
4315   gfc_statement_label = NULL;
4316
4317   if (setjmp (eof_buf))
4318     return FAILURE;     /* Come here on unexpected EOF */
4319
4320   /* Prepare the global namespace that will contain the
4321      program units.  */
4322   gfc_global_ns_list = next = NULL;
4323
4324   seen_program = 0;
4325
4326   /* Exit early for empty files.  */
4327   if (gfc_at_eof ())
4328     goto done;
4329
4330 loop:
4331   gfc_init_2 ();
4332   st = next_statement ();
4333   switch (st)
4334     {
4335     case ST_NONE:
4336       gfc_done_2 ();
4337       goto done;
4338
4339     case ST_PROGRAM:
4340       if (seen_program)
4341         goto duplicate_main;
4342       seen_program = 1;
4343       prog_locus = gfc_current_locus;
4344
4345       push_state (&s, COMP_PROGRAM, gfc_new_block);
4346       main_program_symbol(gfc_current_ns, gfc_new_block->name);
4347       accept_statement (st);
4348       add_global_program ();
4349       parse_progunit (ST_NONE);
4350       if (gfc_option.flag_whole_file)
4351         goto prog_units;
4352       break;
4353
4354     case ST_SUBROUTINE:
4355       add_global_procedure (1);
4356       push_state (&s, COMP_SUBROUTINE, gfc_new_block);
4357       accept_statement (st);
4358       parse_progunit (ST_NONE);
4359       if (gfc_option.flag_whole_file)
4360         goto prog_units;
4361       break;
4362
4363     case ST_FUNCTION:
4364       add_global_procedure (0);
4365       push_state (&s, COMP_FUNCTION, gfc_new_block);
4366       accept_statement (st);
4367       parse_progunit (ST_NONE);
4368       if (gfc_option.flag_whole_file)
4369         goto prog_units;
4370       break;
4371
4372     case ST_BLOCK_DATA:
4373       push_state (&s, COMP_BLOCK_DATA, gfc_new_block);
4374       accept_statement (st);
4375       parse_block_data ();
4376       break;
4377
4378     case ST_MODULE:
4379       push_state (&s, COMP_MODULE, gfc_new_block);
4380       accept_statement (st);
4381
4382       gfc_get_errors (NULL, &errors_before);
4383       parse_module ();
4384       break;
4385
4386     /* Anything else starts a nameless main program block.  */
4387     default:
4388       if (seen_program)
4389         goto duplicate_main;
4390       seen_program = 1;
4391       prog_locus = gfc_current_locus;
4392
4393       push_state (&s, COMP_PROGRAM, gfc_new_block);
4394       main_program_symbol (gfc_current_ns, "MAIN__");
4395       parse_progunit (st);
4396       if (gfc_option.flag_whole_file)
4397         goto prog_units;
4398       break;
4399     }
4400
4401   /* Handle the non-program units.  */
4402   gfc_current_ns->code = s.head;
4403
4404   gfc_resolve (gfc_current_ns);
4405
4406   /* Dump the parse tree if requested.  */
4407   if (gfc_option.dump_fortran_original)
4408     gfc_dump_parse_tree (gfc_current_ns, stdout);
4409
4410   gfc_get_errors (NULL, &errors);
4411   if (s.state == COMP_MODULE)
4412     {
4413       gfc_dump_module (s.sym->name, errors_before == errors);
4414       if (!gfc_option.flag_whole_file)
4415         {
4416           if (errors == 0)
4417             gfc_generate_module_code (gfc_current_ns);
4418           pop_state ();
4419           gfc_done_2 ();
4420         }
4421       else
4422         {
4423           gfc_current_ns->derived_types = gfc_derived_types;
4424           gfc_derived_types = NULL;
4425           goto prog_units;
4426         }
4427     }
4428   else
4429     {
4430       if (errors == 0)
4431         gfc_generate_code (gfc_current_ns);
4432       pop_state ();
4433       gfc_done_2 ();
4434     }
4435
4436   goto loop;
4437
4438 prog_units:
4439   /* The main program and non-contained procedures are put
4440      in the global namespace list, so that they can be processed
4441      later and all their interfaces resolved.  */
4442   gfc_current_ns->code = s.head;
4443   if (next)
4444     {
4445       for (; next->sibling; next = next->sibling)
4446         ;
4447       next->sibling = gfc_current_ns;
4448     }
4449   else
4450     gfc_global_ns_list = gfc_current_ns;
4451
4452   next = gfc_current_ns;
4453
4454   pop_state ();
4455   goto loop;
4456
4457   done:
4458
4459   if (!gfc_option.flag_whole_file)
4460     goto termination;
4461
4462   /* Do the resolution.  */
4463   resolve_all_program_units (gfc_global_ns_list);
4464
4465   /* Do the parse tree dump.  */
4466   gfc_current_ns
4467         = gfc_option.dump_fortran_original ? gfc_global_ns_list : NULL;
4468
4469   for (; gfc_current_ns; gfc_current_ns = gfc_current_ns->sibling)
4470     if (!gfc_current_ns->proc_name
4471         || gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
4472       {
4473         gfc_dump_parse_tree (gfc_current_ns, stdout);
4474         fputs ("------------------------------------------\n\n", stdout);
4475       }
4476
4477   /* Do the translation.  */
4478   translate_all_program_units (gfc_global_ns_list);
4479
4480 termination:
4481
4482   gfc_end_source_files ();
4483   return SUCCESS;
4484
4485 duplicate_main:
4486   /* If we see a duplicate main program, shut down.  If the second
4487      instance is an implied main program, i.e. data decls or executable
4488      statements, we're in for lots of errors.  */
4489   gfc_error ("Two main PROGRAMs at %L and %C", &prog_locus);
4490   reject_statement ();
4491   gfc_done_2 ();
4492   return SUCCESS;
4493 }