gcc/fortran/parse.c

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