gcc/fortran/parse.c

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