gcc/fortran/parse.c

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