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