gcc/fortran/decl.c

   1 /* Declaration statement matcher
   2    Copyright (C) 2002, 2004, 2005, 2006, 2007
   3    Free Software Foundation, Inc.
   4    Contributed by Andy Vaught
   5
   6 This file is part of GCC.
   7
   8 GCC is free software; you can redistribute it and/or modify it under
   9 the terms of the GNU General Public License as published by the Free
  10 Software Foundation; either version 2, or (at your option) any later
  11 version.
  12
  13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
  14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
  15 FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
  16 for more details.
  17
  18 You should have received a copy of the GNU General Public License
  19 along with GCC; see the file COPYING.  If not, write to the Free
  20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
  21 02110-1301, USA.  */
  22
  23 #include "config.h"
  24 #include "system.h"
  25 #include "gfortran.h"
  26 #include "match.h"
  27 #include "parse.h"
  28
  29 /* This flag is set if an old-style length selector is matched
  30    during a type-declaration statement.  */
  31
  32 static int old_char_selector;
  33
  34 /* When variables acquire types and attributes from a declaration
  35    statement, they get them from the following static variables.  The
  36    first part of a declaration sets these variables and the second
  37    part copies these into symbol structures.  */
  38
  39 static gfc_typespec current_ts;
  40
  41 static symbol_attribute current_attr;
  42 static gfc_array_spec *current_as;
  43 static int colon_seen;
  44
  45 /* Initializer of the previous enumerator.  */
  46
  47 static gfc_expr *last_initializer;
  48
  49 /* History of all the enumerators is maintained, so that
  50    kind values of all the enumerators could be updated depending
  51    upon the maximum initialized value.  */
  52
  53 typedef struct enumerator_history
  54 {
  55   gfc_symbol *sym;
  56   gfc_expr *initializer;
  57   struct enumerator_history *next;
  58 }
  59 enumerator_history;
  60
  61 /* Header of enum history chain.  */
  62
  63 static enumerator_history *enum_history = NULL;
  64
  65 /* Pointer of enum history node containing largest initializer.  */
  66
  67 static enumerator_history *max_enum = NULL;
  68
  69 /* gfc_new_block points to the symbol of a newly matched block.  */
  70
  71 gfc_symbol *gfc_new_block;
  72
  73
  74 /********************* DATA statement subroutines *********************/
  75
  76 static bool in_match_data = false;
  77
  78 bool
  79 gfc_in_match_data (void)
  80 {
  81   return in_match_data;
  82 }
  83
  84 void
  85 gfc_set_in_match_data (bool set_value)
  86 {
  87   in_match_data = set_value;
  88 }
  89
  90 /* Free a gfc_data_variable structure and everything beneath it.  */
  91
  92 static void
  93 free_variable (gfc_data_variable *p)
  94 {
  95   gfc_data_variable *q;
  96
  97   for (; p; p = q)
  98     {
  99       q = p->next;
 100       gfc_free_expr (p->expr);
 101       gfc_free_iterator (&p->iter, 0);
 102       free_variable (p->list);
 103       gfc_free (p);
 104     }
 105 }
 106
 107
 108 /* Free a gfc_data_value structure and everything beneath it.  */
 109
 110 static void
 111 free_value (gfc_data_value *p)
 112 {
 113   gfc_data_value *q;
 114
 115   for (; p; p = q)
 116     {
 117       q = p->next;
 118       gfc_free_expr (p->expr);
 119       gfc_free (p);
 120     }
 121 }
 122
 123
 124 /* Free a list of gfc_data structures.  */
 125
 126 void
 127 gfc_free_data (gfc_data *p)
 128 {
 129   gfc_data *q;
 130
 131   for (; p; p = q)
 132     {
 133       q = p->next;
 134       free_variable (p->var);
 135       free_value (p->value);
 136       gfc_free (p);
 137     }
 138 }
 139
 140
 141 /* Free all data in a namespace.  */
 142
 143 static void
 144 gfc_free_data_all (gfc_namespace *ns)
 145 {
 146   gfc_data *d;
 147
 148   for (;ns->data;)
 149     {
 150       d = ns->data->next;
 151       gfc_free (ns->data);
 152       ns->data = d;
 153     }
 154 }
 155
 156
 157 static match var_element (gfc_data_variable *);
 158
 159 /* Match a list of variables terminated by an iterator and a right
 160    parenthesis.  */
 161
 162 static match
 163 var_list (gfc_data_variable *parent)
 164 {
 165   gfc_data_variable *tail, var;
 166   match m;
 167
 168   m = var_element (&var);
 169   if (m == MATCH_ERROR)
 170     return MATCH_ERROR;
 171   if (m == MATCH_NO)
 172     goto syntax;
 173
 174   tail = gfc_get_data_variable ();
 175   *tail = var;
 176
 177   parent->list = tail;
 178
 179   for (;;)
 180     {
 181       if (gfc_match_char (',') != MATCH_YES)
 182         goto syntax;
 183
 184       m = gfc_match_iterator (&parent->iter, 1);
 185       if (m == MATCH_YES)
 186         break;
 187       if (m == MATCH_ERROR)
 188         return MATCH_ERROR;
 189
 190       m = var_element (&var);
 191       if (m == MATCH_ERROR)
 192         return MATCH_ERROR;
 193       if (m == MATCH_NO)
 194         goto syntax;
 195
 196       tail->next = gfc_get_data_variable ();
 197       tail = tail->next;
 198
 199       *tail = var;
 200     }
 201
 202   if (gfc_match_char (')') != MATCH_YES)
 203     goto syntax;
 204   return MATCH_YES;
 205
 206 syntax:
 207   gfc_syntax_error (ST_DATA);
 208   return MATCH_ERROR;
 209 }
 210
 211
 212 /* Match a single element in a data variable list, which can be a
 213    variable-iterator list.  */
 214
 215 static match
 216 var_element (gfc_data_variable *new)
 217 {
 218   match m;
 219   gfc_symbol *sym;
 220
 221   memset (new, 0, sizeof (gfc_data_variable));
 222
 223   if (gfc_match_char ('(') == MATCH_YES)
 224     return var_list (new);
 225
 226   m = gfc_match_variable (&new->expr, 0);
 227   if (m != MATCH_YES)
 228     return m;
 229
 230   sym = new->expr->symtree->n.sym;
 231
 232   if (!sym->attr.function && gfc_current_ns->parent
 233       && gfc_current_ns->parent == sym->ns)
 234     {
 235       gfc_error ("Host associated variable '%s' may not be in the DATA "
 236                  "statement at %C", sym->name);
 237       return MATCH_ERROR;
 238     }
 239
 240   if (gfc_current_state () != COMP_BLOCK_DATA
 241       && sym->attr.in_common
 242       && gfc_notify_std (GFC_STD_GNU, "Extension: initialization of "
 243                          "common block variable '%s' in DATA statement at %C",
 244                          sym->name) == FAILURE)
 245     return MATCH_ERROR;
 246
 247   if (gfc_add_data (&sym->attr, sym->name, &new->expr->where) == FAILURE)
 248     return MATCH_ERROR;
 249
 250   return MATCH_YES;
 251 }
 252
 253
 254 /* Match the top-level list of data variables.  */
 255
 256 static match
 257 top_var_list (gfc_data *d)
 258 {
 259   gfc_data_variable var, *tail, *new;
 260   match m;
 261
 262   tail = NULL;
 263
 264   for (;;)
 265     {
 266       m = var_element (&var);
 267       if (m == MATCH_NO)
 268         goto syntax;
 269       if (m == MATCH_ERROR)
 270         return MATCH_ERROR;
 271
 272       new = gfc_get_data_variable ();
 273       *new = var;
 274
 275       if (tail == NULL)
 276         d->var = new;
 277       else
 278         tail->next = new;
 279
 280       tail = new;
 281
 282       if (gfc_match_char ('/') == MATCH_YES)
 283         break;
 284       if (gfc_match_char (',') != MATCH_YES)
 285         goto syntax;
 286     }
 287
 288   return MATCH_YES;
 289
 290 syntax:
 291   gfc_syntax_error (ST_DATA);
 292   gfc_free_data_all (gfc_current_ns);
 293   return MATCH_ERROR;
 294 }
 295
 296
 297 static match
 298 match_data_constant (gfc_expr **result)
 299 {
 300   char name[GFC_MAX_SYMBOL_LEN + 1];
 301   gfc_symbol *sym;
 302   gfc_expr *expr;
 303   match m;
 304   locus old_loc;
 305
 306   m = gfc_match_literal_constant (&expr, 1);
 307   if (m == MATCH_YES)
 308     {
 309       *result = expr;
 310       return MATCH_YES;
 311     }
 312
 313   if (m == MATCH_ERROR)
 314     return MATCH_ERROR;
 315
 316   m = gfc_match_null (result);
 317   if (m != MATCH_NO)
 318     return m;
 319
 320   old_loc = gfc_current_locus;
 321
 322   /* Should this be a structure component, try to match it
 323      before matching a name.  */
 324   m = gfc_match_rvalue (result);
 325   if (m == MATCH_ERROR)
 326     return m;
 327
 328   if (m == MATCH_YES && (*result)->expr_type == EXPR_STRUCTURE)
 329     {
 330       if (gfc_simplify_expr (*result, 0) == FAILURE)
 331         m = MATCH_ERROR;
 332       return m;
 333     }
 334
 335   gfc_current_locus = old_loc;
 336
 337   m = gfc_match_name (name);
 338   if (m != MATCH_YES)
 339     return m;
 340
 341   if (gfc_find_symbol (name, NULL, 1, &sym))
 342     return MATCH_ERROR;
 343
 344   if (sym == NULL
 345       || (sym->attr.flavor != FL_PARAMETER && sym->attr.flavor != FL_DERIVED))
 346     {
 347       gfc_error ("Symbol '%s' must be a PARAMETER in DATA statement at %C",
 348                  name);
 349       return MATCH_ERROR;
 350     }
 351   else if (sym->attr.flavor == FL_DERIVED)
 352     return gfc_match_structure_constructor (sym, result);
 353
 354   *result = gfc_copy_expr (sym->value);
 355   return MATCH_YES;
 356 }
 357
 358
 359 /* Match a list of values in a DATA statement.  The leading '/' has
 360    already been seen at this point.  */
 361
 362 static match
 363 top_val_list (gfc_data *data)
 364 {
 365   gfc_data_value *new, *tail;
 366   gfc_expr *expr;
 367   const char *msg;
 368   match m;
 369
 370   tail = NULL;
 371
 372   for (;;)
 373     {
 374       m = match_data_constant (&expr);
 375       if (m == MATCH_NO)
 376         goto syntax;
 377       if (m == MATCH_ERROR)
 378         return MATCH_ERROR;
 379
 380       new = gfc_get_data_value ();
 381
 382       if (tail == NULL)
 383         data->value = new;
 384       else
 385         tail->next = new;
 386
 387       tail = new;
 388
 389       if (expr->ts.type != BT_INTEGER || gfc_match_char ('*') != MATCH_YES)
 390         {
 391           tail->expr = expr;
 392           tail->repeat = 1;
 393         }
 394       else
 395         {
 396           signed int tmp;
 397           msg = gfc_extract_int (expr, &tmp);
 398           gfc_free_expr (expr);
 399           if (msg != NULL)
 400             {
 401               gfc_error (msg);
 402               return MATCH_ERROR;
 403             }
 404           tail->repeat = tmp;
 405
 406           m = match_data_constant (&tail->expr);
 407           if (m == MATCH_NO)
 408             goto syntax;
 409           if (m == MATCH_ERROR)
 410             return MATCH_ERROR;
 411         }
 412
 413       if (gfc_match_char ('/') == MATCH_YES)
 414         break;
 415       if (gfc_match_char (',') == MATCH_NO)
 416         goto syntax;
 417     }
 418
 419   return MATCH_YES;
 420
 421 syntax:
 422   gfc_syntax_error (ST_DATA);
 423   gfc_free_data_all (gfc_current_ns);
 424   return MATCH_ERROR;
 425 }
 426
 427
 428 /* Matches an old style initialization.  */
 429
 430 static match
 431 match_old_style_init (const char *name)
 432 {
 433   match m;
 434   gfc_symtree *st;
 435   gfc_symbol *sym;
 436   gfc_data *newdata;
 437
 438   /* Set up data structure to hold initializers.  */
 439   gfc_find_sym_tree (name, NULL, 0, &st);
 440   sym = st->n.sym;
 441
 442   newdata = gfc_get_data ();
 443   newdata->var = gfc_get_data_variable ();
 444   newdata->var->expr = gfc_get_variable_expr (st);
 445   newdata->where = gfc_current_locus;
 446
 447   /* Match initial value list. This also eats the terminal '/'.  */
 448   m = top_val_list (newdata);
 449   if (m != MATCH_YES)
 450     {
 451       gfc_free (newdata);
 452       return m;
 453     }
 454
 455   if (gfc_pure (NULL))
 456     {
 457       gfc_error ("Initialization at %C is not allowed in a PURE procedure");
 458       gfc_free (newdata);
 459       return MATCH_ERROR;
 460     }
 461
 462   /* Mark the variable as having appeared in a data statement.  */
 463   if (gfc_add_data (&sym->attr, sym->name, &sym->declared_at) == FAILURE)
 464     {
 465       gfc_free (newdata);
 466       return MATCH_ERROR;
 467     }
 468
 469   /* Chain in namespace list of DATA initializers.  */
 470   newdata->next = gfc_current_ns->data;
 471   gfc_current_ns->data = newdata;
 472
 473   return m;
 474 }
 475
 476
 477 /* Match the stuff following a DATA statement. If ERROR_FLAG is set,
 478    we are matching a DATA statement and are therefore issuing an error
 479    if we encounter something unexpected, if not, we're trying to match
 480    an old-style initialization expression of the form INTEGER I /2/.  */
 481
 482 match
 483 gfc_match_data (void)
 484 {
 485   gfc_data *new;
 486   match m;
 487
 488   gfc_set_in_match_data (true);
 489
 490   for (;;)
 491     {
 492       new = gfc_get_data ();
 493       new->where = gfc_current_locus;
 494
 495       m = top_var_list (new);
 496       if (m != MATCH_YES)
 497         goto cleanup;
 498
 499       m = top_val_list (new);
 500       if (m != MATCH_YES)
 501         goto cleanup;
 502
 503       new->next = gfc_current_ns->data;
 504       gfc_current_ns->data = new;
 505
 506       if (gfc_match_eos () == MATCH_YES)
 507         break;
 508
 509       gfc_match_char (',');     /* Optional comma */
 510     }
 511
 512   gfc_set_in_match_data (false);
 513
 514   if (gfc_pure (NULL))
 515     {
 516       gfc_error ("DATA statement at %C is not allowed in a PURE procedure");
 517       return MATCH_ERROR;
 518     }
 519
 520   return MATCH_YES;
 521
 522 cleanup:
 523   gfc_set_in_match_data (false);
 524   gfc_free_data (new);
 525   return MATCH_ERROR;
 526 }
 527
 528
 529 /************************ Declaration statements *********************/
 530
 531 /* Match an intent specification.  Since this can only happen after an
 532    INTENT word, a legal intent-spec must follow.  */
 533
 534 static sym_intent
 535 match_intent_spec (void)
 536 {
 537
 538   if (gfc_match (" ( in out )") == MATCH_YES)
 539     return INTENT_INOUT;
 540   if (gfc_match (" ( in )") == MATCH_YES)
 541     return INTENT_IN;
 542   if (gfc_match (" ( out )") == MATCH_YES)
 543     return INTENT_OUT;
 544
 545   gfc_error ("Bad INTENT specification at %C");
 546   return INTENT_UNKNOWN;
 547 }
 548
 549
 550 /* Matches a character length specification, which is either a
 551    specification expression or a '*'.  */
 552
 553 static match
 554 char_len_param_value (gfc_expr **expr)
 555 {
 556   if (gfc_match_char ('*') == MATCH_YES)
 557     {
 558       *expr = NULL;
 559       return MATCH_YES;
 560     }
 561
 562   return gfc_match_expr (expr);
 563 }
 564
 565
 566 /* A character length is a '*' followed by a literal integer or a
 567    char_len_param_value in parenthesis.  */
 568
 569 static match
 570 match_char_length (gfc_expr **expr)
 571 {
 572   int length;
 573   match m;
 574
 575   m = gfc_match_char ('*');
 576   if (m != MATCH_YES)
 577     return m;
 578
 579   m = gfc_match_small_literal_int (&length, NULL);
 580   if (m == MATCH_ERROR)
 581     return m;
 582
 583   if (m == MATCH_YES)
 584     {
 585       *expr = gfc_int_expr (length);
 586       return m;
 587     }
 588
 589   if (gfc_match_char ('(') == MATCH_NO)
 590     goto syntax;
 591
 592   m = char_len_param_value (expr);
 593   if (m == MATCH_ERROR)
 594     return m;
 595   if (m == MATCH_NO)
 596     goto syntax;
 597
 598   if (gfc_match_char (')') == MATCH_NO)
 599     {
 600       gfc_free_expr (*expr);
 601       *expr = NULL;
 602       goto syntax;
 603     }
 604
 605   return MATCH_YES;
 606
 607 syntax:
 608   gfc_error ("Syntax error in character length specification at %C");
 609   return MATCH_ERROR;
 610 }
 611
 612
 613 /* Special subroutine for finding a symbol.  Check if the name is found
 614    in the current name space.  If not, and we're compiling a function or
 615    subroutine and the parent compilation unit is an interface, then check
 616    to see if the name we've been given is the name of the interface
 617    (located in another namespace).  */
 618
 619 static int
 620 find_special (const char *name, gfc_symbol **result)
 621 {
 622   gfc_state_data *s;
 623   int i;
 624
 625   i = gfc_get_symbol (name, NULL, result);
 626   if (i == 0)
 627     goto end;
 628
 629   if (gfc_current_state () != COMP_SUBROUTINE
 630       && gfc_current_state () != COMP_FUNCTION)
 631     goto end;
 632
 633   s = gfc_state_stack->previous;
 634   if (s == NULL)
 635     goto end;
 636
 637   if (s->state != COMP_INTERFACE)
 638     goto end;
 639   if (s->sym == NULL)
 640     goto end;             /* Nameless interface.  */
 641
 642   if (strcmp (name, s->sym->name) == 0)
 643     {
 644       *result = s->sym;
 645       return 0;
 646     }
 647
 648 end:
 649   return i;
 650 }
 651
 652
 653 /* Special subroutine for getting a symbol node associated with a
 654    procedure name, used in SUBROUTINE and FUNCTION statements.  The
 655    symbol is created in the parent using with symtree node in the
 656    child unit pointing to the symbol.  If the current namespace has no
 657    parent, then the symbol is just created in the current unit.  */
 658
 659 static int
 660 get_proc_name (const char *name, gfc_symbol **result, bool module_fcn_entry)
 661 {
 662   gfc_symtree *st;
 663   gfc_symbol *sym;
 664   int rc;
 665
 666   /* Module functions have to be left in their own namespace because
 667      they have potentially (almost certainly!) already been referenced.
 668      In this sense, they are rather like external functions.  This is
 669      fixed up in resolve.c(resolve_entries), where the symbol name-
 670      space is set to point to the master function, so that the fake
 671      result mechanism can work.  */
 672   if (module_fcn_entry)
 673     {
 674       /* Present if entry is declared to be a module procedure.  */
 675       rc = gfc_find_symbol (name, gfc_current_ns->parent, 0, result);
 676       if (*result == NULL)
 677         rc = gfc_get_symbol (name, NULL, result);
 678     }
 679   else
 680     rc = gfc_get_symbol (name, gfc_current_ns->parent, result);
 681
 682   sym = *result;
 683   gfc_current_ns->refs++;
 684
 685   if (sym && !sym->new && gfc_current_state () != COMP_INTERFACE)
 686     {
 687       /* Trap another encompassed procedure with the same name.  All
 688          these conditions are necessary to avoid picking up an entry
 689          whose name clashes with that of the encompassing procedure;
 690          this is handled using gsymbols to register unique,globally
 691          accessible names.  */
 692       if (sym->attr.flavor != 0
 693           && sym->attr.proc != 0
 694           && (sym->attr.subroutine || sym->attr.function)
 695           && sym->attr.if_source != IFSRC_UNKNOWN)
 696         gfc_error_now ("Procedure '%s' at %C is already defined at %L",
 697                        name, &sym->declared_at);
 698
 699       /* Trap declarations of attributes in encompassing scope.  The
 700          signature for this is that ts.kind is set.  Legitimate
 701          references only set ts.type.  */
 702       if (sym->ts.kind != 0
 703           && !sym->attr.implicit_type
 704           && sym->attr.proc == 0
 705           && gfc_current_ns->parent != NULL
 706           && sym->attr.access == 0
 707           && !module_fcn_entry)
 708         gfc_error_now ("Procedure '%s' at %C has an explicit interface "
 709                        "and must not have attributes declared at %L",
 710                        name, &sym->declared_at);
 711     }
 712
 713   if (gfc_current_ns->parent == NULL || *result == NULL)
 714     return rc;
 715
 716   /* Module function entries will already have a symtree in
 717      the current namespace but will need one at module level.  */
 718   if (module_fcn_entry)
 719     {
 720       /* Present if entry is declared to be a module procedure.  */
 721       rc = gfc_find_sym_tree (name, gfc_current_ns->parent, 0, &st);
 722       if (st == NULL)
 723         st = gfc_new_symtree (&gfc_current_ns->parent->sym_root, name);
 724     }
 725   else
 726     st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
 727
 728   st->n.sym = sym;
 729   sym->refs++;
 730
 731   /* See if the procedure should be a module procedure.  */
 732
 733   if (((sym->ns->proc_name != NULL
 734                 && sym->ns->proc_name->attr.flavor == FL_MODULE
 735                 && sym->attr.proc != PROC_MODULE)
 736             || (module_fcn_entry && sym->attr.proc != PROC_MODULE))
 737         && gfc_add_procedure (&sym->attr, PROC_MODULE,
 738                               sym->name, NULL) == FAILURE)
 739     rc = 2;
 740
 741   return rc;
 742 }
 743
 744
 745 /* Function called by variable_decl() that adds a name to the symbol
 746    table.  */
 747
 748 static try
 749 build_sym (const char *name, gfc_charlen *cl,
 750            gfc_array_spec **as, locus *var_locus)
 751 {
 752   symbol_attribute attr;
 753   gfc_symbol *sym;
 754
 755   if (gfc_get_symbol (name, NULL, &sym))
 756     return FAILURE;
 757
 758   /* Start updating the symbol table.  Add basic type attribute if present.  */
 759   if (current_ts.type != BT_UNKNOWN
 760       && (sym->attr.implicit_type == 0
 761           || !gfc_compare_types (&sym->ts, &current_ts))
 762       && gfc_add_type (sym, &current_ts, var_locus) == FAILURE)
 763     return FAILURE;
 764
 765   if (sym->ts.type == BT_CHARACTER)
 766     sym->ts.cl = cl;
 767
 768   /* Add dimension attribute if present.  */
 769   if (gfc_set_array_spec (sym, *as, var_locus) == FAILURE)
 770     return FAILURE;
 771   *as = NULL;
 772
 773   /* Add attribute to symbol.  The copy is so that we can reset the
 774      dimension attribute.  */
 775   attr = current_attr;
 776   attr.dimension = 0;
 777
 778   if (gfc_copy_attr (&sym->attr, &attr, var_locus) == FAILURE)
 779     return FAILURE;
 780
 781   sym->attr.implied_index = 0;
 782
 783   return SUCCESS;
 784 }
 785
 786
 787 /* Set character constant to the given length. The constant will be padded or
 788    truncated.  */
 789
 790 void
 791 gfc_set_constant_character_len (int len, gfc_expr *expr, bool array)
 792 {
 793   char *s;
 794   int slen;
 795
 796   gcc_assert (expr->expr_type == EXPR_CONSTANT);
 797   gcc_assert (expr->ts.type == BT_CHARACTER && expr->ts.kind == 1);
 798
 799   slen = expr->value.character.length;
 800   if (len != slen)
 801     {
 802       s = gfc_getmem (len + 1);
 803       memcpy (s, expr->value.character.string, MIN (len, slen));
 804       if (len > slen)
 805         memset (&s[slen], ' ', len - slen);
 806
 807       if (gfc_option.warn_character_truncation && slen > len)
 808         gfc_warning_now ("CHARACTER expression at %L is being truncated "
 809                          "(%d/%d)", &expr->where, slen, len);
 810
 811       /* Apply the standard by 'hand' otherwise it gets cleared for
 812          initializers.  */
 813       if (array && slen < len && !(gfc_option.allow_std & GFC_STD_GNU))
 814         gfc_error_now ("The CHARACTER elements of the array constructor "
 815                        "at %L must have the same length (%d/%d)",
 816                         &expr->where, slen, len);
 817
 818       s[len] = '\0';
 819       gfc_free (expr->value.character.string);
 820       expr->value.character.string = s;
 821       expr->value.character.length = len;
 822     }
 823 }
 824
 825
 826 /* Function to create and update the enumerator history
 827    using the information passed as arguments.
 828    Pointer "max_enum" is also updated, to point to
 829    enum history node containing largest initializer.
 830
 831    SYM points to the symbol node of enumerator.
 832    INIT points to its enumerator value.  */
 833
 834 static void
 835 create_enum_history (gfc_symbol *sym, gfc_expr *init)
 836 {
 837   enumerator_history *new_enum_history;
 838   gcc_assert (sym != NULL && init != NULL);
 839
 840   new_enum_history = gfc_getmem (sizeof (enumerator_history));
 841
 842   new_enum_history->sym = sym;
 843   new_enum_history->initializer = init;
 844   new_enum_history->next = NULL;
 845
 846   if (enum_history == NULL)
 847     {
 848       enum_history = new_enum_history;
 849       max_enum = enum_history;
 850     }
 851   else
 852     {
 853       new_enum_history->next = enum_history;
 854       enum_history = new_enum_history;
 855
 856       if (mpz_cmp (max_enum->initializer->value.integer,
 857                    new_enum_history->initializer->value.integer) < 0)
 858         max_enum = new_enum_history;
 859     }
 860 }
 861
 862
 863 /* Function to free enum kind history.  */
 864
 865 void
 866 gfc_free_enum_history (void)
 867 {
 868   enumerator_history *current = enum_history;
 869   enumerator_history *next;
 870
 871   while (current != NULL)
 872     {
 873       next = current->next;
 874       gfc_free (current);
 875       current = next;
 876     }
 877   max_enum = NULL;
 878   enum_history = NULL;
 879 }
 880
 881
 882 /* Function called by variable_decl() that adds an initialization
 883    expression to a symbol.  */
 884
 885 static try
 886 add_init_expr_to_sym (const char *name, gfc_expr **initp, locus *var_locus)
 887 {
 888   symbol_attribute attr;
 889   gfc_symbol *sym;
 890   gfc_expr *init;
 891
 892   init = *initp;
 893   if (find_special (name, &sym))
 894     return FAILURE;
 895
 896   attr = sym->attr;
 897
 898   /* If this symbol is confirming an implicit parameter type,
 899      then an initialization expression is not allowed.  */
 900   if (attr.flavor == FL_PARAMETER
 901       && sym->value != NULL
 902       && *initp != NULL)
 903     {
 904       gfc_error ("Initializer not allowed for PARAMETER '%s' at %C",
 905                  sym->name);
 906       return FAILURE;
 907     }
 908
 909   if (attr.in_common
 910       && !attr.data
 911       && *initp != NULL)
 912     {
 913       gfc_error ("Initializer not allowed for COMMON variable '%s' at %C",
 914                  sym->name);
 915       return FAILURE;
 916     }
 917
 918   if (init == NULL)
 919     {
 920       /* An initializer is required for PARAMETER declarations.  */
 921       if (attr.flavor == FL_PARAMETER)
 922         {
 923           gfc_error ("PARAMETER at %L is missing an initializer", var_locus);
 924           return FAILURE;
 925         }
 926     }
 927   else
 928     {
 929       /* If a variable appears in a DATA block, it cannot have an
 930          initializer.  */
 931       if (sym->attr.data)
 932         {
 933           gfc_error ("Variable '%s' at %C with an initializer already "
 934                      "appears in a DATA statement", sym->name);
 935           return FAILURE;
 936         }
 937
 938       /* Check if the assignment can happen. This has to be put off
 939          until later for a derived type variable.  */
 940       if (sym->ts.type != BT_DERIVED && init->ts.type != BT_DERIVED
 941           && gfc_check_assign_symbol (sym, init) == FAILURE)
 942         return FAILURE;
 943
 944       if (sym->ts.type == BT_CHARACTER && sym->ts.cl)
 945         {
 946           /* Update symbol character length according initializer.  */
 947           if (sym->ts.cl->length == NULL)
 948             {
 949               /* If there are multiple CHARACTER variables declared on the
 950                  same line, we don't want them to share the same length.  */
 951               sym->ts.cl = gfc_get_charlen ();
 952               sym->ts.cl->next = gfc_current_ns->cl_list;
 953               gfc_current_ns->cl_list = sym->ts.cl;
 954
 955               if (sym->attr.flavor == FL_PARAMETER
 956                   && init->expr_type == EXPR_ARRAY)
 957                 sym->ts.cl->length = gfc_copy_expr (init->ts.cl->length);
 958             }
 959           /* Update initializer character length according symbol.  */
 960           else if (sym->ts.cl->length->expr_type == EXPR_CONSTANT)
 961             {
 962               int len = mpz_get_si (sym->ts.cl->length->value.integer);
 963               gfc_constructor * p;
 964
 965               if (init->expr_type == EXPR_CONSTANT)
 966                 gfc_set_constant_character_len (len, init, false);
 967               else if (init->expr_type == EXPR_ARRAY)
 968                 {
 969                   /* Build a new charlen to prevent simplification from
 970                      deleting the length before it is resolved.  */
 971                   init->ts.cl = gfc_get_charlen ();
 972                   init->ts.cl->next = gfc_current_ns->cl_list;
 973                   gfc_current_ns->cl_list = sym->ts.cl;
 974                   init->ts.cl->length = gfc_copy_expr (sym->ts.cl->length);
 975
 976                   for (p = init->value.constructor; p; p = p->next)
 977                     gfc_set_constant_character_len (len, p->expr, false);
 978                 }
 979             }
 980         }
 981
 982       /* Add initializer.  Make sure we keep the ranks sane.  */
 983       if (sym->attr.dimension && init->rank == 0)
 984         {
 985           mpz_t size;
 986           gfc_expr *array;
 987           gfc_constructor *c;
 988           int n;
 989           if (sym->attr.flavor == FL_PARAMETER
 990                 && init->expr_type == EXPR_CONSTANT
 991                 && spec_size (sym->as, &size) == SUCCESS
 992                 && mpz_cmp_si (size, 0) > 0)
 993             {
 994               array = gfc_start_constructor (init->ts.type, init->ts.kind,
 995                                              &init->where);
 996
 997               array->value.constructor = c = NULL;
 998               for (n = 0; n < (int)mpz_get_si (size); n++)
 999                 {
1000                   if (array->value.constructor == NULL)
1001                     {
1002                       array->value.constructor = c = gfc_get_constructor ();
1003                       c->expr = init;
1004                     }
1005                   else
1006                     {
1007                       c->next = gfc_get_constructor ();
1008                       c = c->next;
1009                       c->expr = gfc_copy_expr (init);
1010                     }
1011                 }
1012
1013               array->shape = gfc_get_shape (sym->as->rank);
1014               for (n = 0; n < sym->as->rank; n++)
1015                 spec_dimen_size (sym->as, n, &array->shape[n]);
1016
1017               init = array;
1018               mpz_clear (size);
1019             }
1020           init->rank = sym->as->rank;
1021         }
1022
1023       sym->value = init;
1024       *initp = NULL;
1025     }
1026
1027   return SUCCESS;
1028 }
1029
1030
1031 /* Function called by variable_decl() that adds a name to a structure
1032    being built.  */
1033
1034 static try
1035 build_struct (const char *name, gfc_charlen *cl, gfc_expr **init,
1036               gfc_array_spec **as)
1037 {
1038   gfc_component *c;
1039
1040   /* If the current symbol is of the same derived type that we're
1041      constructing, it must have the pointer attribute.  */
1042   if (current_ts.type == BT_DERIVED
1043       && current_ts.derived == gfc_current_block ()
1044       && current_attr.pointer == 0)
1045     {
1046       gfc_error ("Component at %C must have the POINTER attribute");
1047       return FAILURE;
1048     }
1049
1050   if (gfc_current_block ()->attr.pointer && (*as)->rank != 0)
1051     {
1052       if ((*as)->type != AS_DEFERRED && (*as)->type != AS_EXPLICIT)
1053         {
1054           gfc_error ("Array component of structure at %C must have explicit "
1055                      "or deferred shape");
1056           return FAILURE;
1057         }
1058     }
1059
1060   if (gfc_add_component (gfc_current_block (), name, &c) == FAILURE)
1061     return FAILURE;
1062
1063   c->ts = current_ts;
1064   c->ts.cl = cl;
1065   gfc_set_component_attr (c, &current_attr);
1066
1067   c->initializer = *init;
1068   *init = NULL;
1069
1070   c->as = *as;
1071   if (c->as != NULL)
1072     c->dimension = 1;
1073   *as = NULL;
1074
1075   /* Check array components.  */
1076   if (!c->dimension)
1077     {
1078       if (c->allocatable)
1079         {
1080           gfc_error ("Allocatable component at %C must be an array");
1081           return FAILURE;
1082         }
1083       else
1084         return SUCCESS;
1085     }
1086
1087   if (c->pointer)
1088     {
1089       if (c->as->type != AS_DEFERRED)
1090         {
1091           gfc_error ("Pointer array component of structure at %C must have a "
1092                      "deferred shape");
1093           return FAILURE;
1094         }
1095     }
1096   else if (c->allocatable)
1097     {
1098       if (c->as->type != AS_DEFERRED)
1099         {
1100           gfc_error ("Allocatable component of structure at %C must have a "
1101                      "deferred shape");
1102           return FAILURE;
1103         }
1104     }
1105   else
1106     {
1107       if (c->as->type != AS_EXPLICIT)
1108         {
1109           gfc_error ("Array component of structure at %C must have an "
1110                      "explicit shape");
1111           return FAILURE;
1112         }
1113     }
1114
1115   return SUCCESS;
1116 }
1117
1118
1119 /* Match a 'NULL()', and possibly take care of some side effects.  */
1120
1121 match
1122 gfc_match_null (gfc_expr **result)
1123 {
1124   gfc_symbol *sym;
1125   gfc_expr *e;
1126   match m;
1127
1128   m = gfc_match (" null ( )");
1129   if (m != MATCH_YES)
1130     return m;
1131
1132   /* The NULL symbol now has to be/become an intrinsic function.  */
1133   if (gfc_get_symbol ("null", NULL, &sym))
1134     {
1135       gfc_error ("NULL() initialization at %C is ambiguous");
1136       return MATCH_ERROR;
1137     }
1138
1139   gfc_intrinsic_symbol (sym);
1140
1141   if (sym->attr.proc != PROC_INTRINSIC
1142       && (gfc_add_procedure (&sym->attr, PROC_INTRINSIC,
1143                              sym->name, NULL) == FAILURE
1144           || gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE))
1145     return MATCH_ERROR;
1146
1147   e = gfc_get_expr ();
1148   e->where = gfc_current_locus;
1149   e->expr_type = EXPR_NULL;
1150   e->ts.type = BT_UNKNOWN;
1151
1152   *result = e;
1153
1154   return MATCH_YES;
1155 }
1156
1157
1158 /* Match a variable name with an optional initializer.  When this
1159    subroutine is called, a variable is expected to be parsed next.
1160    Depending on what is happening at the moment, updates either the
1161    symbol table or the current interface.  */
1162
1163 static match
1164 variable_decl (int elem)
1165 {
1166   char name[GFC_MAX_SYMBOL_LEN + 1];
1167   gfc_expr *initializer, *char_len;
1168   gfc_array_spec *as;
1169   gfc_array_spec *cp_as; /* Extra copy for Cray Pointees.  */
1170   gfc_charlen *cl;
1171   locus var_locus;
1172   match m;
1173   try t;
1174   gfc_symbol *sym;
1175   locus old_locus;
1176
1177   initializer = NULL;
1178   as = NULL;
1179   cp_as = NULL;
1180   old_locus = gfc_current_locus;
1181
1182   /* When we get here, we've just matched a list of attributes and
1183      maybe a type and a double colon.  The next thing we expect to see
1184      is the name of the symbol.  */
1185   m = gfc_match_name (name);
1186   if (m != MATCH_YES)
1187     goto cleanup;
1188
1189   var_locus = gfc_current_locus;
1190
1191   /* Now we could see the optional array spec. or character length.  */
1192   m = gfc_match_array_spec (&as);
1193   if (gfc_option.flag_cray_pointer && m == MATCH_YES)
1194     cp_as = gfc_copy_array_spec (as);
1195   else if (m == MATCH_ERROR)
1196     goto cleanup;
1197
1198   if (m == MATCH_NO)
1199     as = gfc_copy_array_spec (current_as);
1200
1201   char_len = NULL;
1202   cl = NULL;
1203
1204   if (current_ts.type == BT_CHARACTER)
1205     {
1206       switch (match_char_length (&char_len))
1207         {
1208         case MATCH_YES:
1209           cl = gfc_get_charlen ();
1210           cl->next = gfc_current_ns->cl_list;
1211           gfc_current_ns->cl_list = cl;
1212
1213           cl->length = char_len;
1214           break;
1215
1216         /* Non-constant lengths need to be copied after the first
1217            element.  */
1218         case MATCH_NO:
1219           if (elem > 1 && current_ts.cl->length
1220               && current_ts.cl->length->expr_type != EXPR_CONSTANT)
1221             {
1222               cl = gfc_get_charlen ();
1223               cl->next = gfc_current_ns->cl_list;
1224               gfc_current_ns->cl_list = cl;
1225               cl->length = gfc_copy_expr (current_ts.cl->length);
1226             }
1227           else
1228             cl = current_ts.cl;
1229
1230           break;
1231
1232         case MATCH_ERROR:
1233           goto cleanup;
1234         }
1235     }
1236
1237   /*  If this symbol has already shown up in a Cray Pointer declaration,
1238       then we want to set the type & bail out.  */
1239   if (gfc_option.flag_cray_pointer)
1240     {
1241       gfc_find_symbol (name, gfc_current_ns, 1, &sym);
1242       if (sym != NULL && sym->attr.cray_pointee)
1243         {
1244           sym->ts.type = current_ts.type;
1245           sym->ts.kind = current_ts.kind;
1246           sym->ts.cl = cl;
1247           sym->ts.derived = current_ts.derived;
1248           m = MATCH_YES;
1249
1250           /* Check to see if we have an array specification.  */
1251           if (cp_as != NULL)
1252             {
1253               if (sym->as != NULL)
1254                 {
1255                   gfc_error ("Duplicate array spec for Cray pointee at %C");
1256                   gfc_free_array_spec (cp_as);
1257                   m = MATCH_ERROR;
1258                   goto cleanup;
1259                 }
1260               else
1261                 {
1262                   if (gfc_set_array_spec (sym, cp_as, &var_locus) == FAILURE)
1263                     gfc_internal_error ("Couldn't set pointee array spec.");
1264
1265                   /* Fix the array spec.  */
1266                   m = gfc_mod_pointee_as (sym->as);
1267                   if (m == MATCH_ERROR)
1268                     goto cleanup;
1269                 }
1270             }
1271           goto cleanup;
1272         }
1273       else
1274         {
1275           gfc_free_array_spec (cp_as);
1276         }
1277     }
1278
1279
1280   /* OK, we've successfully matched the declaration.  Now put the
1281      symbol in the current namespace, because it might be used in the
1282      optional initialization expression for this symbol, e.g. this is
1283      perfectly legal:
1284
1285      integer, parameter :: i = huge(i)
1286
1287      This is only true for parameters or variables of a basic type.
1288      For components of derived types, it is not true, so we don't
1289      create a symbol for those yet.  If we fail to create the symbol,
1290      bail out.  */
1291   if (gfc_current_state () != COMP_DERIVED
1292       && build_sym (name, cl, &as, &var_locus) == FAILURE)
1293     {
1294       m = MATCH_ERROR;
1295       goto cleanup;
1296     }
1297
1298   /* An interface body specifies all of the procedure's
1299      characteristics and these shall be consistent with those
1300      specified in the procedure definition, except that the interface
1301      may specify a procedure that is not pure if the procedure is
1302      defined to be pure(12.3.2).  */
1303   if (current_ts.type == BT_DERIVED
1304       && gfc_current_ns->proc_name
1305       && gfc_current_ns->proc_name->attr.if_source == IFSRC_IFBODY
1306       && current_ts.derived->ns != gfc_current_ns
1307       && !gfc_current_ns->has_import_set)
1308     {
1309       gfc_error ("the type of '%s' at %C has not been declared within the "
1310                  "interface", name);
1311       m = MATCH_ERROR;
1312       goto cleanup;
1313     }
1314
1315   /* In functions that have a RESULT variable defined, the function
1316      name always refers to function calls.  Therefore, the name is
1317      not allowed to appear in specification statements.  */
1318   if (gfc_current_state () == COMP_FUNCTION
1319       && gfc_current_block () != NULL
1320       && gfc_current_block ()->result != NULL
1321       && gfc_current_block ()->result != gfc_current_block ()
1322       && strcmp (gfc_current_block ()->name, name) == 0)
1323     {
1324       gfc_error ("Function name '%s' not allowed at %C", name);
1325       m = MATCH_ERROR;
1326       goto cleanup;
1327     }
1328
1329   /* We allow old-style initializations of the form
1330        integer i /2/, j(4) /3*3, 1/
1331      (if no colon has been seen). These are different from data
1332      statements in that initializers are only allowed to apply to the
1333      variable immediately preceding, i.e.
1334        integer i, j /1, 2/
1335      is not allowed. Therefore we have to do some work manually, that
1336      could otherwise be left to the matchers for DATA statements.  */
1337
1338   if (!colon_seen && gfc_match (" /") == MATCH_YES)
1339     {
1340       if (gfc_notify_std (GFC_STD_GNU, "Extension: Old-style "
1341                           "initialization at %C") == FAILURE)
1342         return MATCH_ERROR;
1343
1344       return match_old_style_init (name);
1345     }
1346
1347   /* The double colon must be present in order to have initializers.
1348      Otherwise the statement is ambiguous with an assignment statement.  */
1349   if (colon_seen)
1350     {
1351       if (gfc_match (" =>") == MATCH_YES)
1352         {
1353           if (!current_attr.pointer)
1354             {
1355               gfc_error ("Initialization at %C isn't for a pointer variable");
1356               m = MATCH_ERROR;
1357               goto cleanup;
1358             }
1359
1360           m = gfc_match_null (&initializer);
1361           if (m == MATCH_NO)
1362             {
1363               gfc_error ("Pointer initialization requires a NULL() at %C");
1364               m = MATCH_ERROR;
1365             }
1366
1367           if (gfc_pure (NULL))
1368             {
1369               gfc_error ("Initialization of pointer at %C is not allowed in "
1370                          "a PURE procedure");
1371               m = MATCH_ERROR;
1372             }
1373
1374           if (m != MATCH_YES)
1375             goto cleanup;
1376
1377         }
1378       else if (gfc_match_char ('=') == MATCH_YES)
1379         {
1380           if (current_attr.pointer)
1381             {
1382               gfc_error ("Pointer initialization at %C requires '=>', "
1383                          "not '='");
1384               m = MATCH_ERROR;
1385               goto cleanup;
1386             }
1387
1388           m = gfc_match_init_expr (&initializer);
1389           if (m == MATCH_NO)
1390             {
1391               gfc_error ("Expected an initialization expression at %C");
1392               m = MATCH_ERROR;
1393             }
1394
1395           if (current_attr.flavor != FL_PARAMETER && gfc_pure (NULL))
1396             {
1397               gfc_error ("Initialization of variable at %C is not allowed in "
1398                          "a PURE procedure");
1399               m = MATCH_ERROR;
1400             }
1401
1402           if (m != MATCH_YES)
1403             goto cleanup;
1404         }
1405     }
1406
1407   if (initializer != NULL && current_attr.allocatable
1408         && gfc_current_state () == COMP_DERIVED)
1409     {
1410       gfc_error ("Initialization of allocatable component at %C is not "
1411                  "allowed");
1412       m = MATCH_ERROR;
1413       goto cleanup;
1414     }
1415
1416   /* Add the initializer.  Note that it is fine if initializer is
1417      NULL here, because we sometimes also need to check if a
1418      declaration *must* have an initialization expression.  */
1419   if (gfc_current_state () != COMP_DERIVED)
1420     t = add_init_expr_to_sym (name, &initializer, &var_locus);
1421   else
1422     {
1423       if (current_ts.type == BT_DERIVED
1424           && !current_attr.pointer && !initializer)
1425         initializer = gfc_default_initializer (&current_ts);
1426       t = build_struct (name, cl, &initializer, &as);
1427     }
1428
1429   m = (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
1430
1431 cleanup:
1432   /* Free stuff up and return.  */
1433   gfc_free_expr (initializer);
1434   gfc_free_array_spec (as);
1435
1436   return m;
1437 }
1438
1439
1440 /* Match an extended-f77 "TYPESPEC*bytesize"-style kind specification.
1441    This assumes that the byte size is equal to the kind number for
1442    non-COMPLEX types, and equal to twice the kind number for COMPLEX.  */
1443
1444 match
1445 gfc_match_old_kind_spec (gfc_typespec *ts)
1446 {
1447   match m;
1448   int original_kind;
1449
1450   if (gfc_match_char ('*') != MATCH_YES)
1451     return MATCH_NO;
1452
1453   m = gfc_match_small_literal_int (&ts->kind, NULL);
1454   if (m != MATCH_YES)
1455     return MATCH_ERROR;
1456
1457   original_kind = ts->kind;
1458
1459   /* Massage the kind numbers for complex types.  */
1460   if (ts->type == BT_COMPLEX)
1461     {
1462       if (ts->kind % 2)
1463         {
1464           gfc_error ("Old-style type declaration %s*%d not supported at %C",
1465                      gfc_basic_typename (ts->type), original_kind);
1466           return MATCH_ERROR;
1467         }
1468       ts->kind /= 2;
1469     }
1470
1471   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1472     {
1473       gfc_error ("Old-style type declaration %s*%d not supported at %C",
1474                  gfc_basic_typename (ts->type), original_kind);
1475       return MATCH_ERROR;
1476     }
1477
1478   if (gfc_notify_std (GFC_STD_GNU, "Nonstandard type declaration %s*%d at %C",
1479                       gfc_basic_typename (ts->type), original_kind) == FAILURE)
1480     return MATCH_ERROR;
1481
1482   return MATCH_YES;
1483 }
1484
1485
1486 /* Match a kind specification.  Since kinds are generally optional, we
1487    usually return MATCH_NO if something goes wrong.  If a "kind="
1488    string is found, then we know we have an error.  */
1489
1490 match
1491 gfc_match_kind_spec (gfc_typespec *ts)
1492 {
1493   locus where;
1494   gfc_expr *e;
1495   match m, n;
1496   const char *msg;
1497
1498   m = MATCH_NO;
1499   e = NULL;
1500
1501   where = gfc_current_locus;
1502
1503   if (gfc_match_char ('(') == MATCH_NO)
1504     return MATCH_NO;
1505
1506   /* Also gobbles optional text.  */
1507   if (gfc_match (" kind = ") == MATCH_YES)
1508     m = MATCH_ERROR;
1509
1510   n = gfc_match_init_expr (&e);
1511   if (n == MATCH_NO)
1512     gfc_error ("Expected initialization expression at %C");
1513   if (n != MATCH_YES)
1514     return MATCH_ERROR;
1515
1516   if (e->rank != 0)
1517     {
1518       gfc_error ("Expected scalar initialization expression at %C");
1519       m = MATCH_ERROR;
1520       goto no_match;
1521     }
1522
1523   msg = gfc_extract_int (e, &ts->kind);
1524   if (msg != NULL)
1525     {
1526       gfc_error (msg);
1527       m = MATCH_ERROR;
1528       goto no_match;
1529     }
1530
1531   gfc_free_expr (e);
1532   e = NULL;
1533
1534   if (gfc_validate_kind (ts->type, ts->kind, true) < 0)
1535     {
1536       gfc_error ("Kind %d not supported for type %s at %C", ts->kind,
1537                  gfc_basic_typename (ts->type));
1538
1539       m = MATCH_ERROR;
1540       goto no_match;
1541     }
1542
1543   if (gfc_match_char (')') != MATCH_YES)
1544     {
1545       gfc_error ("Missing right parenthesis at %C");
1546       goto no_match;
1547     }
1548
1549   return MATCH_YES;
1550
1551 no_match:
1552   gfc_free_expr (e);
1553   gfc_current_locus = where;
1554   return m;
1555 }
1556
1557
1558 /* Match the various kind/length specifications in a CHARACTER
1559    declaration.  We don't return MATCH_NO.  */
1560
1561 static match
1562 match_char_spec (gfc_typespec *ts)
1563 {
1564   int kind, seen_length;
1565   gfc_charlen *cl;
1566   gfc_expr *len;
1567   match m;
1568
1569   kind = gfc_default_character_kind;
1570   len = NULL;
1571   seen_length = 0;
1572
1573   /* Try the old-style specification first.  */
1574   old_char_selector = 0;
1575
1576   m = match_char_length (&len);
1577   if (m != MATCH_NO)
1578     {
1579       if (m == MATCH_YES)
1580         old_char_selector = 1;
1581       seen_length = 1;
1582       goto done;
1583     }
1584
1585   m = gfc_match_char ('(');
1586   if (m != MATCH_YES)
1587     {
1588       m = MATCH_YES;    /* character without length is a single char */
1589       goto done;
1590     }
1591
1592   /* Try the weird case:  ( KIND = <int> [ , LEN = <len-param> ] )   */
1593   if (gfc_match (" kind =") == MATCH_YES)
1594     {
1595       m = gfc_match_small_int (&kind);
1596       if (m == MATCH_ERROR)
1597         goto done;
1598       if (m == MATCH_NO)
1599         goto syntax;
1600
1601       if (gfc_match (" , len =") == MATCH_NO)
1602         goto rparen;
1603
1604       m = char_len_param_value (&len);
1605       if (m == MATCH_NO)
1606         goto syntax;
1607       if (m == MATCH_ERROR)
1608         goto done;
1609       seen_length = 1;
1610
1611       goto rparen;
1612     }
1613
1614   /* Try to match "LEN = <len-param>" or "LEN = <len-param>, KIND = <int>".  */
1615   if (gfc_match (" len =") == MATCH_YES)
1616     {
1617       m = char_len_param_value (&len);
1618       if (m == MATCH_NO)
1619         goto syntax;
1620       if (m == MATCH_ERROR)
1621         goto done;
1622       seen_length = 1;
1623
1624       if (gfc_match_char (')') == MATCH_YES)
1625         goto done;
1626
1627       if (gfc_match (" , kind =") != MATCH_YES)
1628         goto syntax;
1629
1630       gfc_match_small_int (&kind);
1631
1632       if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1633         {
1634           gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1635           return MATCH_YES;
1636         }
1637
1638       goto rparen;
1639     }
1640
1641   /* Try to match ( <len-param> ) or ( <len-param> , [ KIND = ] <int> ).  */
1642   m = char_len_param_value (&len);
1643   if (m == MATCH_NO)
1644     goto syntax;
1645   if (m == MATCH_ERROR)
1646     goto done;
1647   seen_length = 1;
1648
1649   m = gfc_match_char (')');
1650   if (m == MATCH_YES)
1651     goto done;
1652
1653   if (gfc_match_char (',') != MATCH_YES)
1654     goto syntax;
1655
1656   gfc_match (" kind =");        /* Gobble optional text */
1657
1658   m = gfc_match_small_int (&kind);
1659   if (m == MATCH_ERROR)
1660     goto done;
1661   if (m == MATCH_NO)
1662     goto syntax;
1663
1664 rparen:
1665   /* Require a right-paren at this point.  */
1666   m = gfc_match_char (')');
1667   if (m == MATCH_YES)
1668     goto done;
1669
1670 syntax:
1671   gfc_error ("Syntax error in CHARACTER declaration at %C");
1672   m = MATCH_ERROR;
1673   gfc_free_expr (len);
1674   return m;
1675
1676 done:
1677   if (gfc_validate_kind (BT_CHARACTER, kind, true) < 0)
1678     {
1679       gfc_error ("Kind %d is not a CHARACTER kind at %C", kind);
1680       m = MATCH_ERROR;
1681     }
1682
1683   if (seen_length == 1 && len != NULL
1684       && len->ts.type != BT_INTEGER && len->ts.type != BT_UNKNOWN)
1685     {
1686       gfc_error ("Expression at %C must be of INTEGER type");
1687       m = MATCH_ERROR;
1688     }
1689
1690   if (m != MATCH_YES)
1691     {
1692       gfc_free_expr (len);
1693       return m;
1694     }
1695
1696   /* Do some final massaging of the length values.  */
1697   cl = gfc_get_charlen ();
1698   cl->next = gfc_current_ns->cl_list;
1699   gfc_current_ns->cl_list = cl;
1700
1701   if (seen_length == 0)
1702     cl->length = gfc_int_expr (1);
1703   else
1704     cl->length = len;
1705
1706   ts->cl = cl;
1707   ts->kind = kind;
1708
1709   return MATCH_YES;
1710 }
1711
1712
1713 /* Matches a type specification.  If successful, sets the ts structure
1714    to the matched specification.  This is necessary for FUNCTION and
1715    IMPLICIT statements.
1716
1717    If implicit_flag is nonzero, then we don't check for the optional
1718    kind specification.  Not doing so is needed for matching an IMPLICIT
1719    statement correctly.  */
1720
1721 static match
1722 match_type_spec (gfc_typespec *ts, int implicit_flag)
1723 {
1724   char name[GFC_MAX_SYMBOL_LEN + 1];
1725   gfc_symbol *sym;
1726   match m;
1727   int c;
1728
1729   gfc_clear_ts (ts);
1730
1731   if (gfc_match (" byte") == MATCH_YES)
1732     {
1733       if (gfc_notify_std(GFC_STD_GNU, "Extension: BYTE type at %C")
1734           == FAILURE)
1735         return MATCH_ERROR;
1736
1737       if (gfc_validate_kind (BT_INTEGER, 1, true) < 0)
1738         {
1739           gfc_error ("BYTE type used at %C "
1740                      "is not available on the target machine");
1741           return MATCH_ERROR;
1742         }
1743
1744       ts->type = BT_INTEGER;
1745       ts->kind = 1;
1746       return MATCH_YES;
1747     }
1748
1749   if (gfc_match (" integer") == MATCH_YES)
1750     {
1751       ts->type = BT_INTEGER;
1752       ts->kind = gfc_default_integer_kind;
1753       goto get_kind;
1754     }
1755
1756   if (gfc_match (" character") == MATCH_YES)
1757     {
1758       ts->type = BT_CHARACTER;
1759       if (implicit_flag == 0)
1760         return match_char_spec (ts);
1761       else
1762         return MATCH_YES;
1763     }
1764
1765   if (gfc_match (" real") == MATCH_YES)
1766     {
1767       ts->type = BT_REAL;
1768       ts->kind = gfc_default_real_kind;
1769       goto get_kind;
1770     }
1771
1772   if (gfc_match (" double precision") == MATCH_YES)
1773     {
1774       ts->type = BT_REAL;
1775       ts->kind = gfc_default_double_kind;
1776       return MATCH_YES;
1777     }
1778
1779   if (gfc_match (" complex") == MATCH_YES)
1780     {
1781       ts->type = BT_COMPLEX;
1782       ts->kind = gfc_default_complex_kind;
1783       goto get_kind;
1784     }
1785
1786   if (gfc_match (" double complex") == MATCH_YES)
1787     {
1788       if (gfc_notify_std (GFC_STD_GNU, "DOUBLE COMPLEX at %C does not "
1789                           "conform to the Fortran 95 standard") == FAILURE)
1790         return MATCH_ERROR;
1791
1792       ts->type = BT_COMPLEX;
1793       ts->kind = gfc_default_double_kind;
1794       return MATCH_YES;
1795     }
1796
1797   if (gfc_match (" logical") == MATCH_YES)
1798     {
1799       ts->type = BT_LOGICAL;
1800       ts->kind = gfc_default_logical_kind;
1801       goto get_kind;
1802     }
1803
1804   m = gfc_match (" type ( %n )", name);
1805   if (m != MATCH_YES)
1806     return m;
1807
1808   /* Search for the name but allow the components to be defined later.  */
1809   if (gfc_get_ha_symbol (name, &sym))
1810     {
1811       gfc_error ("Type name '%s' at %C is ambiguous", name);
1812       return MATCH_ERROR;
1813     }
1814
1815   if (sym->attr.flavor != FL_DERIVED
1816       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
1817     return MATCH_ERROR;
1818
1819   ts->type = BT_DERIVED;
1820   ts->kind = 0;
1821   ts->derived = sym;
1822
1823   return MATCH_YES;
1824
1825 get_kind:
1826   /* For all types except double, derived and character, look for an
1827      optional kind specifier.  MATCH_NO is actually OK at this point.  */
1828   if (implicit_flag == 1)
1829     return MATCH_YES;
1830
1831   if (gfc_current_form == FORM_FREE)
1832     {
1833       c = gfc_peek_char();
1834       if (!gfc_is_whitespace(c) && c != '*' && c != '('
1835           && c != ':' && c != ',')
1836        return MATCH_NO;
1837     }
1838
1839   m = gfc_match_kind_spec (ts);
1840   if (m == MATCH_NO && ts->type != BT_CHARACTER)
1841     m = gfc_match_old_kind_spec (ts);
1842
1843   if (m == MATCH_NO)
1844     m = MATCH_YES;              /* No kind specifier found.  */
1845
1846   return m;
1847 }
1848
1849
1850 /* Match an IMPLICIT NONE statement.  Actually, this statement is
1851    already matched in parse.c, or we would not end up here in the
1852    first place.  So the only thing we need to check, is if there is
1853    trailing garbage.  If not, the match is successful.  */
1854
1855 match
1856 gfc_match_implicit_none (void)
1857 {
1858   return (gfc_match_eos () == MATCH_YES) ? MATCH_YES : MATCH_NO;
1859 }
1860
1861
1862 /* Match the letter range(s) of an IMPLICIT statement.  */
1863
1864 static match
1865 match_implicit_range (void)
1866 {
1867   int c, c1, c2, inner;
1868   locus cur_loc;
1869
1870   cur_loc = gfc_current_locus;
1871
1872   gfc_gobble_whitespace ();
1873   c = gfc_next_char ();
1874   if (c != '(')
1875     {
1876       gfc_error ("Missing character range in IMPLICIT at %C");
1877       goto bad;
1878     }
1879
1880   inner = 1;
1881   while (inner)
1882     {
1883       gfc_gobble_whitespace ();
1884       c1 = gfc_next_char ();
1885       if (!ISALPHA (c1))
1886         goto bad;
1887
1888       gfc_gobble_whitespace ();
1889       c = gfc_next_char ();
1890
1891       switch (c)
1892         {
1893         case ')':
1894           inner = 0;            /* Fall through.  */
1895
1896         case ',':
1897           c2 = c1;
1898           break;
1899
1900         case '-':
1901           gfc_gobble_whitespace ();
1902           c2 = gfc_next_char ();
1903           if (!ISALPHA (c2))
1904             goto bad;
1905
1906           gfc_gobble_whitespace ();
1907           c = gfc_next_char ();
1908
1909           if ((c != ',') && (c != ')'))
1910             goto bad;
1911           if (c == ')')
1912             inner = 0;
1913
1914           break;
1915
1916         default:
1917           goto bad;
1918         }
1919
1920       if (c1 > c2)
1921         {
1922           gfc_error ("Letters must be in alphabetic order in "
1923                      "IMPLICIT statement at %C");
1924           goto bad;
1925         }
1926
1927       /* See if we can add the newly matched range to the pending
1928          implicits from this IMPLICIT statement.  We do not check for
1929          conflicts with whatever earlier IMPLICIT statements may have
1930          set.  This is done when we've successfully finished matching
1931          the current one.  */
1932       if (gfc_add_new_implicit_range (c1, c2) != SUCCESS)
1933         goto bad;
1934     }
1935
1936   return MATCH_YES;
1937
1938 bad:
1939   gfc_syntax_error (ST_IMPLICIT);
1940
1941   gfc_current_locus = cur_loc;
1942   return MATCH_ERROR;
1943 }
1944
1945
1946 /* Match an IMPLICIT statement, storing the types for
1947    gfc_set_implicit() if the statement is accepted by the parser.
1948    There is a strange looking, but legal syntactic construction
1949    possible.  It looks like:
1950
1951      IMPLICIT INTEGER (a-b) (c-d)
1952
1953    This is legal if "a-b" is a constant expression that happens to
1954    equal one of the legal kinds for integers.  The real problem
1955    happens with an implicit specification that looks like:
1956
1957      IMPLICIT INTEGER (a-b)
1958
1959    In this case, a typespec matcher that is "greedy" (as most of the
1960    matchers are) gobbles the character range as a kindspec, leaving
1961    nothing left.  We therefore have to go a bit more slowly in the
1962    matching process by inhibiting the kindspec checking during
1963    typespec matching and checking for a kind later.  */
1964
1965 match
1966 gfc_match_implicit (void)
1967 {
1968   gfc_typespec ts;
1969   locus cur_loc;
1970   int c;
1971   match m;
1972
1973   /* We don't allow empty implicit statements.  */
1974   if (gfc_match_eos () == MATCH_YES)
1975     {
1976       gfc_error ("Empty IMPLICIT statement at %C");
1977       return MATCH_ERROR;
1978     }
1979
1980   do
1981     {
1982       /* First cleanup.  */
1983       gfc_clear_new_implicit ();
1984
1985       /* A basic type is mandatory here.  */
1986       m = match_type_spec (&ts, 1);
1987       if (m == MATCH_ERROR)
1988         goto error;
1989       if (m == MATCH_NO)
1990         goto syntax;
1991
1992       cur_loc = gfc_current_locus;
1993       m = match_implicit_range ();
1994
1995       if (m == MATCH_YES)
1996         {
1997           /* We may have <TYPE> (<RANGE>).  */
1998           gfc_gobble_whitespace ();
1999           c = gfc_next_char ();
2000           if ((c == '\n') || (c == ','))
2001             {
2002               /* Check for CHARACTER with no length parameter.  */
2003               if (ts.type == BT_CHARACTER && !ts.cl)
2004                 {
2005                   ts.kind = gfc_default_character_kind;
2006                   ts.cl = gfc_get_charlen ();
2007                   ts.cl->next = gfc_current_ns->cl_list;
2008                   gfc_current_ns->cl_list = ts.cl;
2009                   ts.cl->length = gfc_int_expr (1);
2010                 }
2011
2012               /* Record the Successful match.  */
2013               if (gfc_merge_new_implicit (&ts) != SUCCESS)
2014                 return MATCH_ERROR;
2015               continue;
2016             }
2017
2018           gfc_current_locus = cur_loc;
2019         }
2020
2021       /* Discard the (incorrectly) matched range.  */
2022       gfc_clear_new_implicit ();
2023
2024       /* Last chance -- check <TYPE> <SELECTOR> (<RANGE>).  */
2025       if (ts.type == BT_CHARACTER)
2026         m = match_char_spec (&ts);
2027       else
2028         {
2029           m = gfc_match_kind_spec (&ts);
2030           if (m == MATCH_NO)
2031             {
2032               m = gfc_match_old_kind_spec (&ts);
2033               if (m == MATCH_ERROR)
2034                 goto error;
2035               if (m == MATCH_NO)
2036                 goto syntax;
2037             }
2038         }
2039       if (m == MATCH_ERROR)
2040         goto error;
2041
2042       m = match_implicit_range ();
2043       if (m == MATCH_ERROR)
2044         goto error;
2045       if (m == MATCH_NO)
2046         goto syntax;
2047
2048       gfc_gobble_whitespace ();
2049       c = gfc_next_char ();
2050       if ((c != '\n') && (c != ','))
2051         goto syntax;
2052
2053       if (gfc_merge_new_implicit (&ts) != SUCCESS)
2054         return MATCH_ERROR;
2055     }
2056   while (c == ',');
2057
2058   return MATCH_YES;
2059
2060 syntax:
2061   gfc_syntax_error (ST_IMPLICIT);
2062
2063 error:
2064   return MATCH_ERROR;
2065 }
2066
2067
2068 match
2069 gfc_match_import (void)
2070 {
2071   char name[GFC_MAX_SYMBOL_LEN + 1];
2072   match m;
2073   gfc_symbol *sym;
2074   gfc_symtree *st;
2075
2076   if (gfc_current_ns->proc_name == NULL
2077       || gfc_current_ns->proc_name->attr.if_source != IFSRC_IFBODY)
2078     {
2079       gfc_error ("IMPORT statement at %C only permitted in "
2080                  "an INTERFACE body");
2081       return MATCH_ERROR;
2082     }
2083
2084   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: IMPORT statement at %C")
2085       == FAILURE)
2086     return MATCH_ERROR;
2087
2088   if (gfc_match_eos () == MATCH_YES)
2089     {
2090       /* All host variables should be imported.  */
2091       gfc_current_ns->has_import_set = 1;
2092       return MATCH_YES;
2093     }
2094
2095   if (gfc_match (" ::") == MATCH_YES)
2096     {
2097       if (gfc_match_eos () == MATCH_YES)
2098         {
2099            gfc_error ("Expecting list of named entities at %C");
2100            return MATCH_ERROR;
2101         }
2102     }
2103
2104   for(;;)
2105     {
2106       m = gfc_match (" %n", name);
2107       switch (m)
2108         {
2109         case MATCH_YES:
2110           if (gfc_current_ns->parent !=  NULL
2111               && gfc_find_symbol (name, gfc_current_ns->parent, 1, &sym))
2112             {
2113                gfc_error ("Type name '%s' at %C is ambiguous", name);
2114                return MATCH_ERROR;
2115             }
2116           else if (gfc_current_ns->proc_name->ns->parent !=  NULL
2117                    && gfc_find_symbol (name,
2118                                        gfc_current_ns->proc_name->ns->parent,
2119                                        1, &sym))
2120             {
2121                gfc_error ("Type name '%s' at %C is ambiguous", name);
2122                return MATCH_ERROR;
2123             }
2124
2125           if (sym == NULL)
2126             {
2127               gfc_error ("Cannot IMPORT '%s' from host scoping unit "
2128                          "at %C - does not exist.", name);
2129               return MATCH_ERROR;
2130             }
2131
2132           if (gfc_find_symtree (gfc_current_ns->sym_root,name))
2133             {
2134               gfc_warning ("'%s' is already IMPORTed from host scoping unit "
2135                            "at %C.", name);
2136               goto next_item;
2137             }
2138
2139           st = gfc_new_symtree (&gfc_current_ns->sym_root, name);
2140           st->n.sym = sym;
2141           sym->refs++;
2142           sym->ns = gfc_current_ns;
2143
2144           goto next_item;
2145
2146         case MATCH_NO:
2147           break;
2148
2149         case MATCH_ERROR:
2150           return MATCH_ERROR;
2151         }
2152
2153     next_item:
2154       if (gfc_match_eos () == MATCH_YES)
2155         break;
2156       if (gfc_match_char (',') != MATCH_YES)
2157         goto syntax;
2158     }
2159
2160   return MATCH_YES;
2161
2162 syntax:
2163   gfc_error ("Syntax error in IMPORT statement at %C");
2164   return MATCH_ERROR;
2165 }
2166
2167
2168 /* Matches an attribute specification including array specs.  If
2169    successful, leaves the variables current_attr and current_as
2170    holding the specification.  Also sets the colon_seen variable for
2171    later use by matchers associated with initializations.
2172
2173    This subroutine is a little tricky in the sense that we don't know
2174    if we really have an attr-spec until we hit the double colon.
2175    Until that time, we can only return MATCH_NO.  This forces us to
2176    check for duplicate specification at this level.  */
2177
2178 static match
2179 match_attr_spec (void)
2180 {
2181   /* Modifiers that can exist in a type statement.  */
2182   typedef enum
2183   { GFC_DECL_BEGIN = 0,
2184     DECL_ALLOCATABLE = GFC_DECL_BEGIN, DECL_DIMENSION, DECL_EXTERNAL,
2185     DECL_IN, DECL_OUT, DECL_INOUT, DECL_INTRINSIC, DECL_OPTIONAL,
2186     DECL_PARAMETER, DECL_POINTER, DECL_PROTECTED, DECL_PRIVATE,
2187     DECL_PUBLIC, DECL_SAVE, DECL_TARGET, DECL_VALUE, DECL_VOLATILE,
2188     DECL_COLON, DECL_NONE,
2189     GFC_DECL_END /* Sentinel */
2190   }
2191   decl_types;
2192
2193 /* GFC_DECL_END is the sentinel, index starts at 0.  */
2194 #define NUM_DECL GFC_DECL_END
2195
2196   static mstring decls[] = {
2197     minit (", allocatable", DECL_ALLOCATABLE),
2198     minit (", dimension", DECL_DIMENSION),
2199     minit (", external", DECL_EXTERNAL),
2200     minit (", intent ( in )", DECL_IN),
2201     minit (", intent ( out )", DECL_OUT),
2202     minit (", intent ( in out )", DECL_INOUT),
2203     minit (", intrinsic", DECL_INTRINSIC),
2204     minit (", optional", DECL_OPTIONAL),
2205     minit (", parameter", DECL_PARAMETER),
2206     minit (", pointer", DECL_POINTER),
2207     minit (", protected", DECL_PROTECTED),
2208     minit (", private", DECL_PRIVATE),
2209     minit (", public", DECL_PUBLIC),
2210     minit (", save", DECL_SAVE),
2211     minit (", target", DECL_TARGET),
2212     minit (", value", DECL_VALUE),
2213     minit (", volatile", DECL_VOLATILE),
2214     minit ("::", DECL_COLON),
2215     minit (NULL, DECL_NONE)
2216   };
2217
2218   locus start, seen_at[NUM_DECL];
2219   int seen[NUM_DECL];
2220   decl_types d;
2221   const char *attr;
2222   match m;
2223   try t;
2224
2225   gfc_clear_attr (&current_attr);
2226   start = gfc_current_locus;
2227
2228   current_as = NULL;
2229   colon_seen = 0;
2230
2231   /* See if we get all of the keywords up to the final double colon.  */
2232   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2233     seen[d] = 0;
2234
2235   for (;;)
2236     {
2237       d = (decl_types) gfc_match_strings (decls);
2238       if (d == DECL_NONE || d == DECL_COLON)
2239         break;
2240
2241       seen[d]++;
2242       seen_at[d] = gfc_current_locus;
2243
2244       if (d == DECL_DIMENSION)
2245         {
2246           m = gfc_match_array_spec (&current_as);
2247
2248           if (m == MATCH_NO)
2249             {
2250               gfc_error ("Missing dimension specification at %C");
2251               m = MATCH_ERROR;
2252             }
2253
2254           if (m == MATCH_ERROR)
2255             goto cleanup;
2256         }
2257     }
2258
2259   /* No double colon, so assume that we've been looking at something
2260      else the whole time.  */
2261   if (d == DECL_NONE)
2262     {
2263       m = MATCH_NO;
2264       goto cleanup;
2265     }
2266
2267   /* Since we've seen a double colon, we have to be looking at an
2268      attr-spec.  This means that we can now issue errors.  */
2269   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2270     if (seen[d] > 1)
2271       {
2272         switch (d)
2273           {
2274           case DECL_ALLOCATABLE:
2275             attr = "ALLOCATABLE";
2276             break;
2277           case DECL_DIMENSION:
2278             attr = "DIMENSION";
2279             break;
2280           case DECL_EXTERNAL:
2281             attr = "EXTERNAL";
2282             break;
2283           case DECL_IN:
2284             attr = "INTENT (IN)";
2285             break;
2286           case DECL_OUT:
2287             attr = "INTENT (OUT)";
2288             break;
2289           case DECL_INOUT:
2290             attr = "INTENT (IN OUT)";
2291             break;
2292           case DECL_INTRINSIC:
2293             attr = "INTRINSIC";
2294             break;
2295           case DECL_OPTIONAL:
2296             attr = "OPTIONAL";
2297             break;
2298           case DECL_PARAMETER:
2299             attr = "PARAMETER";
2300             break;
2301           case DECL_POINTER:
2302             attr = "POINTER";
2303             break;
2304           case DECL_PROTECTED:
2305             attr = "PROTECTED";
2306             break;
2307           case DECL_PRIVATE:
2308             attr = "PRIVATE";
2309             break;
2310           case DECL_PUBLIC:
2311             attr = "PUBLIC";
2312             break;
2313           case DECL_SAVE:
2314             attr = "SAVE";
2315             break;
2316           case DECL_TARGET:
2317             attr = "TARGET";
2318             break;
2319           case DECL_VALUE:
2320             attr = "VALUE";
2321             break;
2322           case DECL_VOLATILE:
2323             attr = "VOLATILE";
2324             break;
2325           default:
2326             attr = NULL;        /* This shouldn't happen.  */
2327           }
2328
2329         gfc_error ("Duplicate %s attribute at %L", attr, &seen_at[d]);
2330         m = MATCH_ERROR;
2331         goto cleanup;
2332       }
2333
2334   /* Now that we've dealt with duplicate attributes, add the attributes
2335      to the current attribute.  */
2336   for (d = GFC_DECL_BEGIN; d != GFC_DECL_END; d++)
2337     {
2338       if (seen[d] == 0)
2339         continue;
2340
2341       if (gfc_current_state () == COMP_DERIVED
2342           && d != DECL_DIMENSION && d != DECL_POINTER
2343           && d != DECL_COLON     && d != DECL_PRIVATE
2344           && d != DECL_PUBLIC    && d != DECL_NONE)
2345         {
2346           if (d == DECL_ALLOCATABLE)
2347             {
2348               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ALLOCATABLE "
2349                                   "attribute at %C in a TYPE definition")
2350                   == FAILURE)
2351                 {
2352                   m = MATCH_ERROR;
2353                   goto cleanup;
2354                 }
2355             }
2356           else
2357             {
2358               gfc_error ("Attribute at %L is not allowed in a TYPE definition",
2359                          &seen_at[d]);
2360               m = MATCH_ERROR;
2361               goto cleanup;
2362             }
2363         }
2364
2365       if ((d == DECL_PRIVATE || d == DECL_PUBLIC)
2366           && gfc_current_state () != COMP_MODULE)
2367         {
2368           if (d == DECL_PRIVATE)
2369             attr = "PRIVATE";
2370           else
2371             attr = "PUBLIC";
2372           if (gfc_current_state () == COMP_DERIVED
2373               && gfc_state_stack->previous
2374               && gfc_state_stack->previous->state == COMP_MODULE)
2375             {
2376               if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: Attribute %s "
2377                                   "at %L in a TYPE definition", attr,
2378                                   &seen_at[d])
2379                   == FAILURE)
2380                 {
2381                   m = MATCH_ERROR;
2382                   goto cleanup;
2383                 }
2384             }
2385           else
2386             {
2387               gfc_error ("%s attribute at %L is not allowed outside of the "
2388                          "specification part of a module", attr, &seen_at[d]);
2389               m = MATCH_ERROR;
2390               goto cleanup;
2391             }
2392         }
2393
2394       switch (d)
2395         {
2396         case DECL_ALLOCATABLE:
2397           t = gfc_add_allocatable (&current_attr, &seen_at[d]);
2398           break;
2399
2400         case DECL_DIMENSION:
2401           t = gfc_add_dimension (&current_attr, NULL, &seen_at[d]);
2402           break;
2403
2404         case DECL_EXTERNAL:
2405           t = gfc_add_external (&current_attr, &seen_at[d]);
2406           break;
2407
2408         case DECL_IN:
2409           t = gfc_add_intent (&current_attr, INTENT_IN, &seen_at[d]);
2410           break;
2411
2412         case DECL_OUT:
2413           t = gfc_add_intent (&current_attr, INTENT_OUT, &seen_at[d]);
2414           break;
2415
2416         case DECL_INOUT:
2417           t = gfc_add_intent (&current_attr, INTENT_INOUT, &seen_at[d]);
2418           break;
2419
2420         case DECL_INTRINSIC:
2421           t = gfc_add_intrinsic (&current_attr, &seen_at[d]);
2422           break;
2423
2424         case DECL_OPTIONAL:
2425           t = gfc_add_optional (&current_attr, &seen_at[d]);
2426           break;
2427
2428         case DECL_PARAMETER:
2429           t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, &seen_at[d]);
2430           break;
2431
2432         case DECL_POINTER:
2433           t = gfc_add_pointer (&current_attr, &seen_at[d]);
2434           break;
2435
2436         case DECL_PROTECTED:
2437           if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
2438             {
2439                gfc_error ("PROTECTED at %C only allowed in specification "
2440                           "part of a module");
2441                t = FAILURE;
2442                break;
2443             }
2444
2445           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED "
2446                               "attribute at %C")
2447               == FAILURE)
2448             t = FAILURE;
2449           else
2450             t = gfc_add_protected (&current_attr, NULL, &seen_at[d]);
2451           break;
2452
2453         case DECL_PRIVATE:
2454           t = gfc_add_access (&current_attr, ACCESS_PRIVATE, NULL,
2455                               &seen_at[d]);
2456           break;
2457
2458         case DECL_PUBLIC:
2459           t = gfc_add_access (&current_attr, ACCESS_PUBLIC, NULL,
2460                               &seen_at[d]);
2461           break;
2462
2463         case DECL_SAVE:
2464           t = gfc_add_save (&current_attr, NULL, &seen_at[d]);
2465           break;
2466
2467         case DECL_TARGET:
2468           t = gfc_add_target (&current_attr, &seen_at[d]);
2469           break;
2470
2471         case DECL_VALUE:
2472           if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE attribute "
2473                               "at %C")
2474               == FAILURE)
2475             t = FAILURE;
2476           else
2477             t = gfc_add_value (&current_attr, NULL, &seen_at[d]);
2478           break;
2479
2480         case DECL_VOLATILE:
2481           if (gfc_notify_std (GFC_STD_F2003,
2482                               "Fortran 2003: VOLATILE attribute at %C")
2483               == FAILURE)
2484             t = FAILURE;
2485           else
2486             t = gfc_add_volatile (&current_attr, NULL, &seen_at[d]);
2487           break;
2488
2489         default:
2490           gfc_internal_error ("match_attr_spec(): Bad attribute");
2491         }
2492
2493       if (t == FAILURE)
2494         {
2495           m = MATCH_ERROR;
2496           goto cleanup;
2497         }
2498     }
2499
2500   colon_seen = 1;
2501   return MATCH_YES;
2502
2503 cleanup:
2504   gfc_current_locus = start;
2505   gfc_free_array_spec (current_as);
2506   current_as = NULL;
2507   return m;
2508 }
2509
2510
2511 /* Match a data declaration statement.  */
2512
2513 match
2514 gfc_match_data_decl (void)
2515 {
2516   gfc_symbol *sym;
2517   match m;
2518   int elem;
2519
2520   m = match_type_spec (&current_ts, 0);
2521   if (m != MATCH_YES)
2522     return m;
2523
2524   if (current_ts.type == BT_DERIVED && gfc_current_state () != COMP_DERIVED)
2525     {
2526       sym = gfc_use_derived (current_ts.derived);
2527
2528       if (sym == NULL)
2529         {
2530           m = MATCH_ERROR;
2531           goto cleanup;
2532         }
2533
2534       current_ts.derived = sym;
2535     }
2536
2537   m = match_attr_spec ();
2538   if (m == MATCH_ERROR)
2539     {
2540       m = MATCH_NO;
2541       goto cleanup;
2542     }
2543
2544   if (current_ts.type == BT_DERIVED && current_ts.derived->components == NULL)
2545     {
2546
2547       if (current_attr.pointer && gfc_current_state () == COMP_DERIVED)
2548         goto ok;
2549
2550       gfc_find_symbol (current_ts.derived->name,
2551                        current_ts.derived->ns->parent, 1, &sym);
2552
2553       /* Any symbol that we find had better be a type definition
2554          which has its components defined.  */
2555       if (sym != NULL && sym->attr.flavor == FL_DERIVED
2556           && current_ts.derived->components != NULL)
2557         goto ok;
2558
2559       /* Now we have an error, which we signal, and then fix up
2560          because the knock-on is plain and simple confusing.  */
2561       gfc_error_now ("Derived type at %C has not been previously defined "
2562                      "and so cannot appear in a derived type definition");
2563       current_attr.pointer = 1;
2564       goto ok;
2565     }
2566
2567 ok:
2568   /* If we have an old-style character declaration, and no new-style
2569      attribute specifications, then there a comma is optional between
2570      the type specification and the variable list.  */
2571   if (m == MATCH_NO && current_ts.type == BT_CHARACTER && old_char_selector)
2572     gfc_match_char (',');
2573
2574   /* Give the types/attributes to symbols that follow. Give the element
2575      a number so that repeat character length expressions can be copied.  */
2576   elem = 1;
2577   for (;;)
2578     {
2579       m = variable_decl (elem++);
2580       if (m == MATCH_ERROR)
2581         goto cleanup;
2582       if (m == MATCH_NO)
2583         break;
2584
2585       if (gfc_match_eos () == MATCH_YES)
2586         goto cleanup;
2587       if (gfc_match_char (',') != MATCH_YES)
2588         break;
2589     }
2590
2591   if (gfc_error_flag_test () == 0)
2592     gfc_error ("Syntax error in data declaration at %C");
2593   m = MATCH_ERROR;
2594
2595   gfc_free_data_all (gfc_current_ns);
2596
2597 cleanup:
2598   gfc_free_array_spec (current_as);
2599   current_as = NULL;
2600   return m;
2601 }
2602
2603
2604 /* Match a prefix associated with a function or subroutine
2605    declaration.  If the typespec pointer is nonnull, then a typespec
2606    can be matched.  Note that if nothing matches, MATCH_YES is
2607    returned (the null string was matched).  */
2608
2609 static match
2610 match_prefix (gfc_typespec *ts)
2611 {
2612   int seen_type;
2613
2614   gfc_clear_attr (&current_attr);
2615   seen_type = 0;
2616
2617 loop:
2618   if (!seen_type && ts != NULL
2619       && match_type_spec (ts, 0) == MATCH_YES
2620       && gfc_match_space () == MATCH_YES)
2621     {
2622
2623       seen_type = 1;
2624       goto loop;
2625     }
2626
2627   if (gfc_match ("elemental% ") == MATCH_YES)
2628     {
2629       if (gfc_add_elemental (&current_attr, NULL) == FAILURE)
2630         return MATCH_ERROR;
2631
2632       goto loop;
2633     }
2634
2635   if (gfc_match ("pure% ") == MATCH_YES)
2636     {
2637       if (gfc_add_pure (&current_attr, NULL) == FAILURE)
2638         return MATCH_ERROR;
2639
2640       goto loop;
2641     }
2642
2643   if (gfc_match ("recursive% ") == MATCH_YES)
2644     {
2645       if (gfc_add_recursive (&current_attr, NULL) == FAILURE)
2646         return MATCH_ERROR;
2647
2648       goto loop;
2649     }
2650
2651   /* At this point, the next item is not a prefix.  */
2652   return MATCH_YES;
2653 }
2654
2655
2656 /* Copy attributes matched by match_prefix() to attributes on a symbol.  */
2657
2658 static try
2659 copy_prefix (symbol_attribute *dest, locus *where)
2660 {
2661   if (current_attr.pure && gfc_add_pure (dest, where) == FAILURE)
2662     return FAILURE;
2663
2664   if (current_attr.elemental && gfc_add_elemental (dest, where) == FAILURE)
2665     return FAILURE;
2666
2667   if (current_attr.recursive && gfc_add_recursive (dest, where) == FAILURE)
2668     return FAILURE;
2669
2670   return SUCCESS;
2671 }
2672
2673
2674 /* Match a formal argument list.  */
2675
2676 match
2677 gfc_match_formal_arglist (gfc_symbol *progname, int st_flag, int null_flag)
2678 {
2679   gfc_formal_arglist *head, *tail, *p, *q;
2680   char name[GFC_MAX_SYMBOL_LEN + 1];
2681   gfc_symbol *sym;
2682   match m;
2683
2684   head = tail = NULL;
2685
2686   if (gfc_match_char ('(') != MATCH_YES)
2687     {
2688       if (null_flag)
2689         goto ok;
2690       return MATCH_NO;
2691     }
2692
2693   if (gfc_match_char (')') == MATCH_YES)
2694     goto ok;
2695
2696   for (;;)
2697     {
2698       if (gfc_match_char ('*') == MATCH_YES)
2699         sym = NULL;
2700       else
2701         {
2702           m = gfc_match_name (name);
2703           if (m != MATCH_YES)
2704             goto cleanup;
2705
2706           if (gfc_get_symbol (name, NULL, &sym))
2707             goto cleanup;
2708         }
2709
2710       p = gfc_get_formal_arglist ();
2711
2712       if (head == NULL)
2713         head = tail = p;
2714       else
2715         {
2716           tail->next = p;
2717           tail = p;
2718         }
2719
2720       tail->sym = sym;
2721
2722       /* We don't add the VARIABLE flavor because the name could be a
2723          dummy procedure.  We don't apply these attributes to formal
2724          arguments of statement functions.  */
2725       if (sym != NULL && !st_flag
2726           && (gfc_add_dummy (&sym->attr, sym->name, NULL) == FAILURE
2727               || gfc_missing_attr (&sym->attr, NULL) == FAILURE))
2728         {
2729           m = MATCH_ERROR;
2730           goto cleanup;
2731         }
2732
2733       /* The name of a program unit can be in a different namespace,
2734          so check for it explicitly.  After the statement is accepted,
2735          the name is checked for especially in gfc_get_symbol().  */
2736       if (gfc_new_block != NULL && sym != NULL
2737           && strcmp (sym->name, gfc_new_block->name) == 0)
2738         {
2739           gfc_error ("Name '%s' at %C is the name of the procedure",
2740                      sym->name);
2741           m = MATCH_ERROR;
2742           goto cleanup;
2743         }
2744
2745       if (gfc_match_char (')') == MATCH_YES)
2746         goto ok;
2747
2748       m = gfc_match_char (',');
2749       if (m != MATCH_YES)
2750         {
2751           gfc_error ("Unexpected junk in formal argument list at %C");
2752           goto cleanup;
2753         }
2754     }
2755
2756 ok:
2757   /* Check for duplicate symbols in the formal argument list.  */
2758   if (head != NULL)
2759     {
2760       for (p = head; p->next; p = p->next)
2761         {
2762           if (p->sym == NULL)
2763             continue;
2764
2765           for (q = p->next; q; q = q->next)
2766             if (p->sym == q->sym)
2767               {
2768                 gfc_error ("Duplicate symbol '%s' in formal argument list "
2769                            "at %C", p->sym->name);
2770
2771                 m = MATCH_ERROR;
2772                 goto cleanup;
2773               }
2774         }
2775     }
2776
2777   if (gfc_add_explicit_interface (progname, IFSRC_DECL, head, NULL)
2778       == FAILURE)
2779     {
2780       m = MATCH_ERROR;
2781       goto cleanup;
2782     }
2783
2784   return MATCH_YES;
2785
2786 cleanup:
2787   gfc_free_formal_arglist (head);
2788   return m;
2789 }
2790
2791
2792 /* Match a RESULT specification following a function declaration or
2793    ENTRY statement.  Also matches the end-of-statement.  */
2794
2795 static match
2796 match_result (gfc_symbol *function, gfc_symbol **result)
2797 {
2798   char name[GFC_MAX_SYMBOL_LEN + 1];
2799   gfc_symbol *r;
2800   match m;
2801
2802   if (gfc_match (" result (") != MATCH_YES)
2803     return MATCH_NO;
2804
2805   m = gfc_match_name (name);
2806   if (m != MATCH_YES)
2807     return m;
2808
2809   if (gfc_match (" )%t") != MATCH_YES)
2810     {
2811       gfc_error ("Unexpected junk following RESULT variable at %C");
2812       return MATCH_ERROR;
2813     }
2814
2815   if (strcmp (function->name, name) == 0)
2816     {
2817       gfc_error ("RESULT variable at %C must be different than function name");
2818       return MATCH_ERROR;
2819     }
2820
2821   if (gfc_get_symbol (name, NULL, &r))
2822     return MATCH_ERROR;
2823
2824   if (gfc_add_flavor (&r->attr, FL_VARIABLE, r->name, NULL) == FAILURE
2825       || gfc_add_result (&r->attr, r->name, NULL) == FAILURE)
2826     return MATCH_ERROR;
2827
2828   *result = r;
2829
2830   return MATCH_YES;
2831 }
2832
2833
2834 /* Match a function declaration.  */
2835
2836 match
2837 gfc_match_function_decl (void)
2838 {
2839   char name[GFC_MAX_SYMBOL_LEN + 1];
2840   gfc_symbol *sym, *result;
2841   locus old_loc;
2842   match m;
2843
2844   if (gfc_current_state () != COMP_NONE
2845       && gfc_current_state () != COMP_INTERFACE
2846       && gfc_current_state () != COMP_CONTAINS)
2847     return MATCH_NO;
2848
2849   gfc_clear_ts (&current_ts);
2850
2851   old_loc = gfc_current_locus;
2852
2853   m = match_prefix (&current_ts);
2854   if (m != MATCH_YES)
2855     {
2856       gfc_current_locus = old_loc;
2857       return m;
2858     }
2859
2860   if (gfc_match ("function% %n", name) != MATCH_YES)
2861     {
2862       gfc_current_locus = old_loc;
2863       return MATCH_NO;
2864     }
2865   if (get_proc_name (name, &sym, false))
2866     return MATCH_ERROR;
2867   gfc_new_block = sym;
2868
2869   m = gfc_match_formal_arglist (sym, 0, 0);
2870   if (m == MATCH_NO)
2871     {
2872       gfc_error ("Expected formal argument list in function "
2873                  "definition at %C");
2874       m = MATCH_ERROR;
2875       goto cleanup;
2876     }
2877   else if (m == MATCH_ERROR)
2878     goto cleanup;
2879
2880   result = NULL;
2881
2882   if (gfc_match_eos () != MATCH_YES)
2883     {
2884       /* See if a result variable is present.  */
2885       m = match_result (sym, &result);
2886       if (m == MATCH_NO)
2887         gfc_error ("Unexpected junk after function declaration at %C");
2888
2889       if (m != MATCH_YES)
2890         {
2891           m = MATCH_ERROR;
2892           goto cleanup;
2893         }
2894     }
2895
2896   /* Make changes to the symbol.  */
2897   m = MATCH_ERROR;
2898
2899   if (gfc_add_function (&sym->attr, sym->name, NULL) == FAILURE)
2900     goto cleanup;
2901
2902   if (gfc_missing_attr (&sym->attr, NULL) == FAILURE
2903       || copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
2904     goto cleanup;
2905
2906   if (current_ts.type != BT_UNKNOWN && sym->ts.type != BT_UNKNOWN
2907       && !sym->attr.implicit_type)
2908     {
2909       gfc_error ("Function '%s' at %C already has a type of %s", name,
2910                  gfc_basic_typename (sym->ts.type));
2911       goto cleanup;
2912     }
2913
2914   if (result == NULL)
2915     {
2916       sym->ts = current_ts;
2917       sym->result = sym;
2918     }
2919   else
2920     {
2921       result->ts = current_ts;
2922       sym->result = result;
2923     }
2924
2925   return MATCH_YES;
2926
2927 cleanup:
2928   gfc_current_locus = old_loc;
2929   return m;
2930 }
2931
2932
2933 /* This is mostly a copy of parse.c(add_global_procedure) but modified to
2934    pass the name of the entry, rather than the gfc_current_block name, and
2935    to return false upon finding an existing global entry.  */
2936
2937 static bool
2938 add_global_entry (const char *name, int sub)
2939 {
2940   gfc_gsymbol *s;
2941
2942   s = gfc_get_gsymbol(name);
2943
2944   if (s->defined
2945       || (s->type != GSYM_UNKNOWN
2946           && s->type != (sub ? GSYM_SUBROUTINE : GSYM_FUNCTION)))
2947     global_used(s, NULL);
2948   else
2949     {
2950       s->type = sub ? GSYM_SUBROUTINE : GSYM_FUNCTION;
2951       s->where = gfc_current_locus;
2952       s->defined = 1;
2953       return true;
2954     }
2955   return false;
2956 }
2957
2958
2959 /* Match an ENTRY statement.  */
2960
2961 match
2962 gfc_match_entry (void)
2963 {
2964   gfc_symbol *proc;
2965   gfc_symbol *result;
2966   gfc_symbol *entry;
2967   char name[GFC_MAX_SYMBOL_LEN + 1];
2968   gfc_compile_state state;
2969   match m;
2970   gfc_entry_list *el;
2971   locus old_loc;
2972   bool module_procedure;
2973
2974   m = gfc_match_name (name);
2975   if (m != MATCH_YES)
2976     return m;
2977
2978   state = gfc_current_state ();
2979   if (state != COMP_SUBROUTINE && state != COMP_FUNCTION)
2980     {
2981       switch (state)
2982         {
2983           case COMP_PROGRAM:
2984             gfc_error ("ENTRY statement at %C cannot appear within a PROGRAM");
2985             break;
2986           case COMP_MODULE:
2987             gfc_error ("ENTRY statement at %C cannot appear within a MODULE");
2988             break;
2989           case COMP_BLOCK_DATA:
2990             gfc_error ("ENTRY statement at %C cannot appear within "
2991                        "a BLOCK DATA");
2992             break;
2993           case COMP_INTERFACE:
2994             gfc_error ("ENTRY statement at %C cannot appear within "
2995                        "an INTERFACE");
2996             break;
2997           case COMP_DERIVED:
2998             gfc_error ("ENTRY statement at %C cannot appear within "
2999                        "a DERIVED TYPE block");
3000             break;
3001           case COMP_IF:
3002             gfc_error ("ENTRY statement at %C cannot appear within "
3003                        "an IF-THEN block");
3004             break;
3005           case COMP_DO:
3006             gfc_error ("ENTRY statement at %C cannot appear within "
3007                        "a DO block");
3008             break;
3009           case COMP_SELECT:
3010             gfc_error ("ENTRY statement at %C cannot appear within "
3011                        "a SELECT block");
3012             break;
3013           case COMP_FORALL:
3014             gfc_error ("ENTRY statement at %C cannot appear within "
3015                        "a FORALL block");
3016             break;
3017           case COMP_WHERE:
3018             gfc_error ("ENTRY statement at %C cannot appear within "
3019                        "a WHERE block");
3020             break;
3021           case COMP_CONTAINS:
3022             gfc_error ("ENTRY statement at %C cannot appear within "
3023                        "a contained subprogram");
3024             break;
3025           default:
3026             gfc_internal_error ("gfc_match_entry(): Bad state");
3027         }
3028       return MATCH_ERROR;
3029     }
3030
3031   module_procedure = gfc_current_ns->parent != NULL
3032                    && gfc_current_ns->parent->proc_name
3033                    && gfc_current_ns->parent->proc_name->attr.flavor
3034                       == FL_MODULE;
3035
3036   if (gfc_current_ns->parent != NULL
3037       && gfc_current_ns->parent->proc_name
3038       && !module_procedure)
3039     {
3040       gfc_error("ENTRY statement at %C cannot appear in a "
3041                 "contained procedure");
3042       return MATCH_ERROR;
3043     }
3044
3045   /* Module function entries need special care in get_proc_name
3046      because previous references within the function will have
3047      created symbols attached to the current namespace.  */
3048   if (get_proc_name (name, &entry,
3049                      gfc_current_ns->parent != NULL
3050                      && module_procedure
3051                      && gfc_current_ns->proc_name->attr.function))
3052     return MATCH_ERROR;
3053
3054   proc = gfc_current_block ();
3055
3056   if (state == COMP_SUBROUTINE)
3057     {
3058       /* An entry in a subroutine.  */
3059       if (!add_global_entry (name, 1))
3060         return MATCH_ERROR;
3061
3062       m = gfc_match_formal_arglist (entry, 0, 1);
3063       if (m != MATCH_YES)
3064         return MATCH_ERROR;
3065
3066       if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3067           || gfc_add_subroutine (&entry->attr, entry->name, NULL) == FAILURE)
3068         return MATCH_ERROR;
3069     }
3070   else
3071     {
3072       /* An entry in a function.
3073          We need to take special care because writing
3074             ENTRY f()
3075          as
3076             ENTRY f
3077          is allowed, whereas
3078             ENTRY f() RESULT (r)
3079          can't be written as
3080             ENTRY f RESULT (r).  */
3081       if (!add_global_entry (name, 0))
3082         return MATCH_ERROR;
3083
3084       old_loc = gfc_current_locus;
3085       if (gfc_match_eos () == MATCH_YES)
3086         {
3087           gfc_current_locus = old_loc;
3088           /* Match the empty argument list, and add the interface to
3089              the symbol.  */
3090           m = gfc_match_formal_arglist (entry, 0, 1);
3091         }
3092       else
3093         m = gfc_match_formal_arglist (entry, 0, 0);
3094
3095       if (m != MATCH_YES)
3096         return MATCH_ERROR;
3097
3098       result = NULL;
3099
3100       if (gfc_match_eos () == MATCH_YES)
3101         {
3102           if (gfc_add_entry (&entry->attr, entry->name, NULL) == FAILURE
3103               || gfc_add_function (&entry->attr, entry->name, NULL) == FAILURE)
3104             return MATCH_ERROR;
3105
3106           entry->result = entry;
3107         }
3108       else
3109         {
3110           m = match_result (proc, &result);
3111           if (m == MATCH_NO)
3112             gfc_syntax_error (ST_ENTRY);
3113           if (m != MATCH_YES)
3114             return MATCH_ERROR;
3115
3116           if (gfc_add_result (&result->attr, result->name, NULL) == FAILURE
3117               || gfc_add_entry (&entry->attr, result->name, NULL) == FAILURE
3118               || gfc_add_function (&entry->attr, result->name, NULL)
3119                  == FAILURE)
3120             return MATCH_ERROR;
3121
3122           entry->result = result;
3123         }
3124     }
3125
3126   if (gfc_match_eos () != MATCH_YES)
3127     {
3128       gfc_syntax_error (ST_ENTRY);
3129       return MATCH_ERROR;
3130     }
3131
3132   entry->attr.recursive = proc->attr.recursive;
3133   entry->attr.elemental = proc->attr.elemental;
3134   entry->attr.pure = proc->attr.pure;
3135
3136   el = gfc_get_entry_list ();
3137   el->sym = entry;
3138   el->next = gfc_current_ns->entries;
3139   gfc_current_ns->entries = el;
3140   if (el->next)
3141     el->id = el->next->id + 1;
3142   else
3143     el->id = 1;
3144
3145   new_st.op = EXEC_ENTRY;
3146   new_st.ext.entry = el;
3147
3148   return MATCH_YES;
3149 }
3150
3151
3152 /* Match a subroutine statement, including optional prefixes.  */
3153
3154 match
3155 gfc_match_subroutine (void)
3156 {
3157   char name[GFC_MAX_SYMBOL_LEN + 1];
3158   gfc_symbol *sym;
3159   match m;
3160
3161   if (gfc_current_state () != COMP_NONE
3162       && gfc_current_state () != COMP_INTERFACE
3163       && gfc_current_state () != COMP_CONTAINS)
3164     return MATCH_NO;
3165
3166   m = match_prefix (NULL);
3167   if (m != MATCH_YES)
3168     return m;
3169
3170   m = gfc_match ("subroutine% %n", name);
3171   if (m != MATCH_YES)
3172     return m;
3173
3174   if (get_proc_name (name, &sym, false))
3175     return MATCH_ERROR;
3176   gfc_new_block = sym;
3177
3178   if (gfc_add_subroutine (&sym->attr, sym->name, NULL) == FAILURE)
3179     return MATCH_ERROR;
3180
3181   if (gfc_match_formal_arglist (sym, 0, 1) != MATCH_YES)
3182     return MATCH_ERROR;
3183
3184   if (gfc_match_eos () != MATCH_YES)
3185     {
3186       gfc_syntax_error (ST_SUBROUTINE);
3187       return MATCH_ERROR;
3188     }
3189
3190   if (copy_prefix (&sym->attr, &sym->declared_at) == FAILURE)
3191     return MATCH_ERROR;
3192
3193   return MATCH_YES;
3194 }
3195
3196
3197 /* Return nonzero if we're currently compiling a contained procedure.  */
3198
3199 static int
3200 contained_procedure (void)
3201 {
3202   gfc_state_data *s;
3203
3204   for (s=gfc_state_stack; s; s=s->previous)
3205     if ((s->state == COMP_SUBROUTINE || s->state == COMP_FUNCTION)
3206         && s->previous != NULL && s->previous->state == COMP_CONTAINS)
3207       return 1;
3208
3209   return 0;
3210 }
3211
3212 /* Set the kind of each enumerator.  The kind is selected such that it is
3213    interoperable with the corresponding C enumeration type, making
3214    sure that -fshort-enums is honored.  */
3215
3216 static void
3217 set_enum_kind(void)
3218 {
3219   enumerator_history *current_history = NULL;
3220   int kind;
3221   int i;
3222
3223   if (max_enum == NULL || enum_history == NULL)
3224     return;
3225
3226   if (!gfc_option.fshort_enums)
3227     return;
3228
3229   i = 0;
3230   do
3231     {
3232       kind = gfc_integer_kinds[i++].kind;
3233     }
3234   while (kind < gfc_c_int_kind
3235          && gfc_check_integer_range (max_enum->initializer->value.integer,
3236                                      kind) != ARITH_OK);
3237
3238   current_history = enum_history;
3239   while (current_history != NULL)
3240     {
3241       current_history->sym->ts.kind = kind;
3242       current_history = current_history->next;
3243     }
3244 }
3245
3246
3247 /* Match any of the various end-block statements.  Returns the type of
3248    END to the caller.  The END INTERFACE, END IF, END DO and END
3249    SELECT statements cannot be replaced by a single END statement.  */
3250
3251 match
3252 gfc_match_end (gfc_statement *st)
3253 {
3254   char name[GFC_MAX_SYMBOL_LEN + 1];
3255   gfc_compile_state state;
3256   locus old_loc;
3257   const char *block_name;
3258   const char *target;
3259   int eos_ok;
3260   match m;
3261
3262   old_loc = gfc_current_locus;
3263   if (gfc_match ("end") != MATCH_YES)
3264     return MATCH_NO;
3265
3266   state = gfc_current_state ();
3267   block_name = gfc_current_block () == NULL
3268              ? NULL : gfc_current_block ()->name;
3269
3270   if (state == COMP_CONTAINS)
3271     {
3272       state = gfc_state_stack->previous->state;
3273       block_name = gfc_state_stack->previous->sym == NULL
3274                  ? NULL : gfc_state_stack->previous->sym->name;
3275     }
3276
3277   switch (state)
3278     {
3279     case COMP_NONE:
3280     case COMP_PROGRAM:
3281       *st = ST_END_PROGRAM;
3282       target = " program";
3283       eos_ok = 1;
3284       break;
3285
3286     case COMP_SUBROUTINE:
3287       *st = ST_END_SUBROUTINE;
3288       target = " subroutine";
3289       eos_ok = !contained_procedure ();
3290       break;
3291
3292     case COMP_FUNCTION:
3293       *st = ST_END_FUNCTION;
3294       target = " function";
3295       eos_ok = !contained_procedure ();
3296       break;
3297
3298     case COMP_BLOCK_DATA:
3299       *st = ST_END_BLOCK_DATA;
3300       target = " block data";
3301       eos_ok = 1;
3302       break;
3303
3304     case COMP_MODULE:
3305       *st = ST_END_MODULE;
3306       target = " module";
3307       eos_ok = 1;
3308       break;
3309
3310     case COMP_INTERFACE:
3311       *st = ST_END_INTERFACE;
3312       target = " interface";
3313       eos_ok = 0;
3314       break;
3315
3316     case COMP_DERIVED:
3317       *st = ST_END_TYPE;
3318       target = " type";
3319       eos_ok = 0;
3320       break;
3321
3322     case COMP_IF:
3323       *st = ST_ENDIF;
3324       target = " if";
3325       eos_ok = 0;
3326       break;
3327
3328     case COMP_DO:
3329       *st = ST_ENDDO;
3330       target = " do";
3331       eos_ok = 0;
3332       break;
3333
3334     case COMP_SELECT:
3335       *st = ST_END_SELECT;
3336       target = " select";
3337       eos_ok = 0;
3338       break;
3339
3340     case COMP_FORALL:
3341       *st = ST_END_FORALL;
3342       target = " forall";
3343       eos_ok = 0;
3344       break;
3345
3346     case COMP_WHERE:
3347       *st = ST_END_WHERE;
3348       target = " where";
3349       eos_ok = 0;
3350       break;
3351
3352     case COMP_ENUM:
3353       *st = ST_END_ENUM;
3354       target = " enum";
3355       eos_ok = 0;
3356       last_initializer = NULL;
3357       set_enum_kind ();
3358       gfc_free_enum_history ();
3359       break;
3360
3361     default:
3362       gfc_error ("Unexpected END statement at %C");
3363       goto cleanup;
3364     }
3365
3366   if (gfc_match_eos () == MATCH_YES)
3367     {
3368       if (!eos_ok)
3369         {
3370           /* We would have required END [something].  */
3371           gfc_error ("%s statement expected at %L",
3372                      gfc_ascii_statement (*st), &old_loc);
3373           goto cleanup;
3374         }
3375
3376       return MATCH_YES;
3377     }
3378
3379   /* Verify that we've got the sort of end-block that we're expecting.  */
3380   if (gfc_match (target) != MATCH_YES)
3381     {
3382       gfc_error ("Expecting %s statement at %C", gfc_ascii_statement (*st));
3383       goto cleanup;
3384     }
3385
3386   /* If we're at the end, make sure a block name wasn't required.  */
3387   if (gfc_match_eos () == MATCH_YES)
3388     {
3389
3390       if (*st != ST_ENDDO && *st != ST_ENDIF && *st != ST_END_SELECT
3391           && *st != ST_END_FORALL && *st != ST_END_WHERE)
3392         return MATCH_YES;
3393
3394       if (gfc_current_block () == NULL)
3395         return MATCH_YES;
3396
3397       gfc_error ("Expected block name of '%s' in %s statement at %C",
3398                  block_name, gfc_ascii_statement (*st));
3399
3400       return MATCH_ERROR;
3401     }
3402
3403   /* END INTERFACE has a special handler for its several possible endings.  */
3404   if (*st == ST_END_INTERFACE)
3405     return gfc_match_end_interface ();
3406
3407   /* We haven't hit the end of statement, so what is left must be an
3408      end-name.  */
3409   m = gfc_match_space ();
3410   if (m == MATCH_YES)
3411     m = gfc_match_name (name);
3412
3413   if (m == MATCH_NO)
3414     gfc_error ("Expected terminating name at %C");
3415   if (m != MATCH_YES)
3416     goto cleanup;
3417
3418   if (block_name == NULL)
3419     goto syntax;
3420
3421   if (strcmp (name, block_name) != 0)
3422     {
3423       gfc_error ("Expected label '%s' for %s statement at %C", block_name,
3424                  gfc_ascii_statement (*st));
3425       goto cleanup;
3426     }
3427
3428   if (gfc_match_eos () == MATCH_YES)
3429     return MATCH_YES;
3430
3431 syntax:
3432   gfc_syntax_error (*st);
3433
3434 cleanup:
3435   gfc_current_locus = old_loc;
3436   return MATCH_ERROR;
3437 }
3438
3439
3440
3441 /***************** Attribute declaration statements ****************/
3442
3443 /* Set the attribute of a single variable.  */
3444
3445 static match
3446 attr_decl1 (void)
3447 {
3448   char name[GFC_MAX_SYMBOL_LEN + 1];
3449   gfc_array_spec *as;
3450   gfc_symbol *sym;
3451   locus var_locus;
3452   match m;
3453
3454   as = NULL;
3455
3456   m = gfc_match_name (name);
3457   if (m != MATCH_YES)
3458     goto cleanup;
3459
3460   if (find_special (name, &sym))
3461     return MATCH_ERROR;
3462
3463   var_locus = gfc_current_locus;
3464
3465   /* Deal with possible array specification for certain attributes.  */
3466   if (current_attr.dimension
3467       || current_attr.allocatable
3468       || current_attr.pointer
3469       || current_attr.target)
3470     {
3471       m = gfc_match_array_spec (&as);
3472       if (m == MATCH_ERROR)
3473         goto cleanup;
3474
3475       if (current_attr.dimension && m == MATCH_NO)
3476         {
3477           gfc_error ("Missing array specification at %L in DIMENSION "
3478                      "statement", &var_locus);
3479           m = MATCH_ERROR;
3480           goto cleanup;
3481         }
3482
3483       if ((current_attr.allocatable || current_attr.pointer)
3484           && (m == MATCH_YES) && (as->type != AS_DEFERRED))
3485         {
3486           gfc_error ("Array specification must be deferred at %L", &var_locus);
3487           m = MATCH_ERROR;
3488           goto cleanup;
3489         }
3490     }
3491
3492   /* Update symbol table.  DIMENSION attribute is set
3493      in gfc_set_array_spec().  */
3494   if (current_attr.dimension == 0
3495       && gfc_copy_attr (&sym->attr, &current_attr, NULL) == FAILURE)
3496     {
3497       m = MATCH_ERROR;
3498       goto cleanup;
3499     }
3500
3501   if (gfc_set_array_spec (sym, as, &var_locus) == FAILURE)
3502     {
3503       m = MATCH_ERROR;
3504       goto cleanup;
3505     }
3506
3507   if (sym->attr.cray_pointee && sym->as != NULL)
3508     {
3509       /* Fix the array spec.  */
3510       m = gfc_mod_pointee_as (sym->as);
3511       if (m == MATCH_ERROR)
3512         goto cleanup;
3513     }
3514
3515   if (gfc_add_attribute (&sym->attr, &var_locus) == FAILURE)
3516     {
3517       m = MATCH_ERROR;
3518       goto cleanup;
3519     }
3520
3521   if ((current_attr.external || current_attr.intrinsic)
3522       && sym->attr.flavor != FL_PROCEDURE
3523       && gfc_add_flavor (&sym->attr, FL_PROCEDURE, sym->name, NULL) == FAILURE)
3524     {
3525       m = MATCH_ERROR;
3526       goto cleanup;
3527     }
3528
3529   return MATCH_YES;
3530
3531 cleanup:
3532   gfc_free_array_spec (as);
3533   return m;
3534 }
3535
3536
3537 /* Generic attribute declaration subroutine.  Used for attributes that
3538    just have a list of names.  */
3539
3540 static match
3541 attr_decl (void)
3542 {
3543   match m;
3544
3545   /* Gobble the optional double colon, by simply ignoring the result
3546      of gfc_match().  */
3547   gfc_match (" ::");
3548
3549   for (;;)
3550     {
3551       m = attr_decl1 ();
3552       if (m != MATCH_YES)
3553         break;
3554
3555       if (gfc_match_eos () == MATCH_YES)
3556         {
3557           m = MATCH_YES;
3558           break;
3559         }
3560
3561       if (gfc_match_char (',') != MATCH_YES)
3562         {
3563           gfc_error ("Unexpected character in variable list at %C");
3564           m = MATCH_ERROR;
3565           break;
3566         }
3567     }
3568
3569   return m;
3570 }
3571
3572
3573 /* This routine matches Cray Pointer declarations of the form:
3574    pointer ( <pointer>, <pointee> )
3575    or
3576    pointer ( <pointer1>, <pointee1> ), ( <pointer2>, <pointee2> ), ...
3577    The pointer, if already declared, should be an integer.  Otherwise, we
3578    set it as BT_INTEGER with kind gfc_index_integer_kind.  The pointee may
3579    be either a scalar, or an array declaration.  No space is allocated for
3580    the pointee.  For the statement
3581    pointer (ipt, ar(10))
3582    any subsequent uses of ar will be translated (in C-notation) as
3583    ar(i) => ((<type> *) ipt)(i)
3584    After gimplification, pointee variable will disappear in the code.  */
3585
3586 static match
3587 cray_pointer_decl (void)
3588 {
3589   match m;
3590   gfc_array_spec *as;
3591   gfc_symbol *cptr; /* Pointer symbol.  */
3592   gfc_symbol *cpte; /* Pointee symbol.  */
3593   locus var_locus;
3594   bool done = false;
3595
3596   while (!done)
3597     {
3598       if (gfc_match_char ('(') != MATCH_YES)
3599         {
3600           gfc_error ("Expected '(' at %C");
3601           return MATCH_ERROR;
3602         }
3603
3604       /* Match pointer.  */
3605       var_locus = gfc_current_locus;
3606       gfc_clear_attr (&current_attr);
3607       gfc_add_cray_pointer (&current_attr, &var_locus);
3608       current_ts.type = BT_INTEGER;
3609       current_ts.kind = gfc_index_integer_kind;
3610
3611       m = gfc_match_symbol (&cptr, 0);
3612       if (m != MATCH_YES)
3613         {
3614           gfc_error ("Expected variable name at %C");
3615           return m;
3616         }
3617
3618       if (gfc_add_cray_pointer (&cptr->attr, &var_locus) == FAILURE)
3619         return MATCH_ERROR;
3620
3621       gfc_set_sym_referenced (cptr);
3622
3623       if (cptr->ts.type == BT_UNKNOWN) /* Override the type, if necessary.  */
3624         {
3625           cptr->ts.type = BT_INTEGER;
3626           cptr->ts.kind = gfc_index_integer_kind;
3627         }
3628       else if (cptr->ts.type != BT_INTEGER)
3629         {
3630           gfc_error ("Cray pointer at %C must be an integer");
3631           return MATCH_ERROR;
3632         }
3633       else if (cptr->ts.kind < gfc_index_integer_kind)
3634         gfc_warning ("Cray pointer at %C has %d bytes of precision;"
3635                      " memory addresses require %d bytes",
3636                      cptr->ts.kind, gfc_index_integer_kind);
3637
3638       if (gfc_match_char (',') != MATCH_YES)
3639         {
3640           gfc_error ("Expected \",\" at %C");
3641           return MATCH_ERROR;
3642         }
3643
3644       /* Match Pointee.  */
3645       var_locus = gfc_current_locus;
3646       gfc_clear_attr (&current_attr);
3647       gfc_add_cray_pointee (&current_attr, &var_locus);
3648       current_ts.type = BT_UNKNOWN;
3649       current_ts.kind = 0;
3650
3651       m = gfc_match_symbol (&cpte, 0);
3652       if (m != MATCH_YES)
3653         {
3654           gfc_error ("Expected variable name at %C");
3655           return m;
3656         }
3657
3658       /* Check for an optional array spec.  */
3659       m = gfc_match_array_spec (&as);
3660       if (m == MATCH_ERROR)
3661         {
3662           gfc_free_array_spec (as);
3663           return m;
3664         }
3665       else if (m == MATCH_NO)
3666         {
3667           gfc_free_array_spec (as);
3668           as = NULL;
3669         }
3670
3671       if (gfc_add_cray_pointee (&cpte->attr, &var_locus) == FAILURE)
3672         return MATCH_ERROR;
3673
3674       gfc_set_sym_referenced (cpte);
3675
3676       if (cpte->as == NULL)
3677         {
3678           if (gfc_set_array_spec (cpte, as, &var_locus) == FAILURE)
3679             gfc_internal_error ("Couldn't set Cray pointee array spec.");
3680         }
3681       else if (as != NULL)
3682         {
3683           gfc_error ("Duplicate array spec for Cray pointee at %C");
3684           gfc_free_array_spec (as);
3685           return MATCH_ERROR;
3686         }
3687
3688       as = NULL;
3689
3690       if (cpte->as != NULL)
3691         {
3692           /* Fix array spec.  */
3693           m = gfc_mod_pointee_as (cpte->as);
3694           if (m == MATCH_ERROR)
3695             return m;
3696         }
3697
3698       /* Point the Pointee at the Pointer.  */
3699       cpte->cp_pointer = cptr;
3700
3701       if (gfc_match_char (')') != MATCH_YES)
3702         {
3703           gfc_error ("Expected \")\" at %C");
3704           return MATCH_ERROR;
3705         }
3706       m = gfc_match_char (',');
3707       if (m != MATCH_YES)
3708         done = true; /* Stop searching for more declarations.  */
3709
3710     }
3711
3712   if (m == MATCH_ERROR /* Failed when trying to find ',' above.  */
3713       || gfc_match_eos () != MATCH_YES)
3714     {
3715       gfc_error ("Expected \",\" or end of statement at %C");
3716       return MATCH_ERROR;
3717     }
3718   return MATCH_YES;
3719 }
3720
3721
3722 match
3723 gfc_match_external (void)
3724 {
3725
3726   gfc_clear_attr (&current_attr);
3727   current_attr.external = 1;
3728
3729   return attr_decl ();
3730 }
3731
3732
3733 match
3734 gfc_match_intent (void)
3735 {
3736   sym_intent intent;
3737
3738   intent = match_intent_spec ();
3739   if (intent == INTENT_UNKNOWN)
3740     return MATCH_ERROR;
3741
3742   gfc_clear_attr (&current_attr);
3743   current_attr.intent = intent;
3744
3745   return attr_decl ();
3746 }
3747
3748
3749 match
3750 gfc_match_intrinsic (void)
3751 {
3752
3753   gfc_clear_attr (&current_attr);
3754   current_attr.intrinsic = 1;
3755
3756   return attr_decl ();
3757 }
3758
3759
3760 match
3761 gfc_match_optional (void)
3762 {
3763
3764   gfc_clear_attr (&current_attr);
3765   current_attr.optional = 1;
3766
3767   return attr_decl ();
3768 }
3769
3770
3771 match
3772 gfc_match_pointer (void)
3773 {
3774   gfc_gobble_whitespace ();
3775   if (gfc_peek_char () == '(')
3776     {
3777       if (!gfc_option.flag_cray_pointer)
3778         {
3779           gfc_error ("Cray pointer declaration at %C requires -fcray-pointer "
3780                      "flag");
3781           return MATCH_ERROR;
3782         }
3783       return cray_pointer_decl ();
3784     }
3785   else
3786     {
3787       gfc_clear_attr (&current_attr);
3788       current_attr.pointer = 1;
3789
3790       return attr_decl ();
3791     }
3792 }
3793
3794
3795 match
3796 gfc_match_allocatable (void)
3797 {
3798   gfc_clear_attr (&current_attr);
3799   current_attr.allocatable = 1;
3800
3801   return attr_decl ();
3802 }
3803
3804
3805 match
3806 gfc_match_dimension (void)
3807 {
3808   gfc_clear_attr (&current_attr);
3809   current_attr.dimension = 1;
3810
3811   return attr_decl ();
3812 }
3813
3814
3815 match
3816 gfc_match_target (void)
3817 {
3818   gfc_clear_attr (&current_attr);
3819   current_attr.target = 1;
3820
3821   return attr_decl ();
3822 }
3823
3824
3825 /* Match the list of entities being specified in a PUBLIC or PRIVATE
3826    statement.  */
3827
3828 static match
3829 access_attr_decl (gfc_statement st)
3830 {
3831   char name[GFC_MAX_SYMBOL_LEN + 1];
3832   interface_type type;
3833   gfc_user_op *uop;
3834   gfc_symbol *sym;
3835   gfc_intrinsic_op operator;
3836   match m;
3837
3838   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3839     goto done;
3840
3841   for (;;)
3842     {
3843       m = gfc_match_generic_spec (&type, name, &operator);
3844       if (m == MATCH_NO)
3845         goto syntax;
3846       if (m == MATCH_ERROR)
3847         return MATCH_ERROR;
3848
3849       switch (type)
3850         {
3851         case INTERFACE_NAMELESS:
3852           goto syntax;
3853
3854         case INTERFACE_GENERIC:
3855           if (gfc_get_symbol (name, NULL, &sym))
3856             goto done;
3857
3858           if (gfc_add_access (&sym->attr, (st == ST_PUBLIC)
3859                                           ? ACCESS_PUBLIC : ACCESS_PRIVATE,
3860                               sym->name, NULL) == FAILURE)
3861             return MATCH_ERROR;
3862
3863           break;
3864
3865         case INTERFACE_INTRINSIC_OP:
3866           if (gfc_current_ns->operator_access[operator] == ACCESS_UNKNOWN)
3867             {
3868               gfc_current_ns->operator_access[operator] =
3869                 (st == ST_PUBLIC) ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3870             }
3871           else
3872             {
3873               gfc_error ("Access specification of the %s operator at %C has "
3874                          "already been specified", gfc_op2string (operator));
3875               goto done;
3876             }
3877
3878           break;
3879
3880         case INTERFACE_USER_OP:
3881           uop = gfc_get_uop (name);
3882
3883           if (uop->access == ACCESS_UNKNOWN)
3884             {
3885               uop->access = (st == ST_PUBLIC)
3886                           ? ACCESS_PUBLIC : ACCESS_PRIVATE;
3887             }
3888           else
3889             {
3890               gfc_error ("Access specification of the .%s. operator at %C "
3891                          "has already been specified", sym->name);
3892               goto done;
3893             }
3894
3895           break;
3896         }
3897
3898       if (gfc_match_char (',') == MATCH_NO)
3899         break;
3900     }
3901
3902   if (gfc_match_eos () != MATCH_YES)
3903     goto syntax;
3904   return MATCH_YES;
3905
3906 syntax:
3907   gfc_syntax_error (st);
3908
3909 done:
3910   return MATCH_ERROR;
3911 }
3912
3913
3914 match
3915 gfc_match_protected (void)
3916 {
3917   gfc_symbol *sym;
3918   match m;
3919
3920   if (gfc_current_ns->proc_name->attr.flavor != FL_MODULE)
3921     {
3922        gfc_error ("PROTECTED at %C only allowed in specification "
3923                   "part of a module");
3924        return MATCH_ERROR;
3925
3926     }
3927
3928   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: PROTECTED statement at %C")
3929       == FAILURE)
3930     return MATCH_ERROR;
3931
3932   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
3933     {
3934       return MATCH_ERROR;
3935     }
3936
3937   if (gfc_match_eos () == MATCH_YES)
3938     goto syntax;
3939
3940   for(;;)
3941     {
3942       m = gfc_match_symbol (&sym, 0);
3943       switch (m)
3944         {
3945         case MATCH_YES:
3946           if (gfc_add_protected (&sym->attr, sym->name, &gfc_current_locus)
3947               == FAILURE)
3948             return MATCH_ERROR;
3949           goto next_item;
3950
3951         case MATCH_NO:
3952           break;
3953
3954         case MATCH_ERROR:
3955           return MATCH_ERROR;
3956         }
3957
3958     next_item:
3959       if (gfc_match_eos () == MATCH_YES)
3960         break;
3961       if (gfc_match_char (',') != MATCH_YES)
3962         goto syntax;
3963     }
3964
3965   return MATCH_YES;
3966
3967 syntax:
3968   gfc_error ("Syntax error in PROTECTED statement at %C");
3969   return MATCH_ERROR;
3970 }
3971
3972
3973 /* The PRIVATE statement is a bit weird in that it can be a attribute
3974    declaration, but also works as a standlone statement inside of a
3975    type declaration or a module.  */
3976
3977 match
3978 gfc_match_private (gfc_statement *st)
3979 {
3980
3981   if (gfc_match ("private") != MATCH_YES)
3982     return MATCH_NO;
3983
3984   if (gfc_current_state () != COMP_MODULE
3985       && (gfc_current_state () != COMP_DERIVED
3986           || !gfc_state_stack->previous
3987           || gfc_state_stack->previous->state != COMP_MODULE))
3988     {
3989       gfc_error ("PRIVATE statement at %C is only allowed in the "
3990                  "specification part of a module");
3991       return MATCH_ERROR;
3992     }
3993
3994   if (gfc_current_state () == COMP_DERIVED)
3995     {
3996       if (gfc_match_eos () == MATCH_YES)
3997         {
3998           *st = ST_PRIVATE;
3999           return MATCH_YES;
4000         }
4001
4002       gfc_syntax_error (ST_PRIVATE);
4003       return MATCH_ERROR;
4004     }
4005
4006   if (gfc_match_eos () == MATCH_YES)
4007     {
4008       *st = ST_PRIVATE;
4009       return MATCH_YES;
4010     }
4011
4012   *st = ST_ATTR_DECL;
4013   return access_attr_decl (ST_PRIVATE);
4014 }
4015
4016
4017 match
4018 gfc_match_public (gfc_statement *st)
4019 {
4020
4021   if (gfc_match ("public") != MATCH_YES)
4022     return MATCH_NO;
4023
4024   if (gfc_current_state () != COMP_MODULE)
4025     {
4026       gfc_error ("PUBLIC statement at %C is only allowed in the "
4027                  "specification part of a module");
4028       return MATCH_ERROR;
4029     }
4030
4031   if (gfc_match_eos () == MATCH_YES)
4032     {
4033       *st = ST_PUBLIC;
4034       return MATCH_YES;
4035     }
4036
4037   *st = ST_ATTR_DECL;
4038   return access_attr_decl (ST_PUBLIC);
4039 }
4040
4041
4042 /* Workhorse for gfc_match_parameter.  */
4043
4044 static match
4045 do_parm (void)
4046 {
4047   gfc_symbol *sym;
4048   gfc_expr *init;
4049   match m;
4050
4051   m = gfc_match_symbol (&sym, 0);
4052   if (m == MATCH_NO)
4053     gfc_error ("Expected variable name at %C in PARAMETER statement");
4054
4055   if (m != MATCH_YES)
4056     return m;
4057
4058   if (gfc_match_char ('=') == MATCH_NO)
4059     {
4060       gfc_error ("Expected = sign in PARAMETER statement at %C");
4061       return MATCH_ERROR;
4062     }
4063
4064   m = gfc_match_init_expr (&init);
4065   if (m == MATCH_NO)
4066     gfc_error ("Expected expression at %C in PARAMETER statement");
4067   if (m != MATCH_YES)
4068     return m;
4069
4070   if (sym->ts.type == BT_UNKNOWN
4071       && gfc_set_default_type (sym, 1, NULL) == FAILURE)
4072     {
4073       m = MATCH_ERROR;
4074       goto cleanup;
4075     }
4076
4077   if (gfc_check_assign_symbol (sym, init) == FAILURE
4078       || gfc_add_flavor (&sym->attr, FL_PARAMETER, sym->name, NULL) == FAILURE)
4079     {
4080       m = MATCH_ERROR;
4081       goto cleanup;
4082     }
4083
4084   if (sym->ts.type == BT_CHARACTER
4085       && sym->ts.cl != NULL
4086       && sym->ts.cl->length != NULL
4087       && sym->ts.cl->length->expr_type == EXPR_CONSTANT
4088       && init->expr_type == EXPR_CONSTANT
4089       && init->ts.type == BT_CHARACTER
4090       && init->ts.kind == 1)
4091     gfc_set_constant_character_len (
4092       mpz_get_si (sym->ts.cl->length->value.integer), init, false);
4093
4094   sym->value = init;
4095   return MATCH_YES;
4096
4097 cleanup:
4098   gfc_free_expr (init);
4099   return m;
4100 }
4101
4102
4103 /* Match a parameter statement, with the weird syntax that these have.  */
4104
4105 match
4106 gfc_match_parameter (void)
4107 {
4108   match m;
4109
4110   if (gfc_match_char ('(') == MATCH_NO)
4111     return MATCH_NO;
4112
4113   for (;;)
4114     {
4115       m = do_parm ();
4116       if (m != MATCH_YES)
4117         break;
4118
4119       if (gfc_match (" )%t") == MATCH_YES)
4120         break;
4121
4122       if (gfc_match_char (',') != MATCH_YES)
4123         {
4124           gfc_error ("Unexpected characters in PARAMETER statement at %C");
4125           m = MATCH_ERROR;
4126           break;
4127         }
4128     }
4129
4130   return m;
4131 }
4132
4133
4134 /* Save statements have a special syntax.  */
4135
4136 match
4137 gfc_match_save (void)
4138 {
4139   char n[GFC_MAX_SYMBOL_LEN+1];
4140   gfc_common_head *c;
4141   gfc_symbol *sym;
4142   match m;
4143
4144   if (gfc_match_eos () == MATCH_YES)
4145     {
4146       if (gfc_current_ns->seen_save)
4147         {
4148           if (gfc_notify_std (GFC_STD_LEGACY, "Blanket SAVE statement at %C "
4149                               "follows previous SAVE statement")
4150               == FAILURE)
4151             return MATCH_ERROR;
4152         }
4153
4154       gfc_current_ns->save_all = gfc_current_ns->seen_save = 1;
4155       return MATCH_YES;
4156     }
4157
4158   if (gfc_current_ns->save_all)
4159     {
4160       if (gfc_notify_std (GFC_STD_LEGACY, "SAVE statement at %C follows "
4161                           "blanket SAVE statement")
4162           == FAILURE)
4163         return MATCH_ERROR;
4164     }
4165
4166   gfc_match (" ::");
4167
4168   for (;;)
4169     {
4170       m = gfc_match_symbol (&sym, 0);
4171       switch (m)
4172         {
4173         case MATCH_YES:
4174           if (gfc_add_save (&sym->attr, sym->name, &gfc_current_locus)
4175               == FAILURE)
4176             return MATCH_ERROR;
4177           goto next_item;
4178
4179         case MATCH_NO:
4180           break;
4181
4182         case MATCH_ERROR:
4183           return MATCH_ERROR;
4184         }
4185
4186       m = gfc_match (" / %n /", &n);
4187       if (m == MATCH_ERROR)
4188         return MATCH_ERROR;
4189       if (m == MATCH_NO)
4190         goto syntax;
4191
4192       c = gfc_get_common (n, 0);
4193       c->saved = 1;
4194
4195       gfc_current_ns->seen_save = 1;
4196
4197     next_item:
4198       if (gfc_match_eos () == MATCH_YES)
4199         break;
4200       if (gfc_match_char (',') != MATCH_YES)
4201         goto syntax;
4202     }
4203
4204   return MATCH_YES;
4205
4206 syntax:
4207   gfc_error ("Syntax error in SAVE statement at %C");
4208   return MATCH_ERROR;
4209 }
4210
4211
4212 match
4213 gfc_match_value (void)
4214 {
4215   gfc_symbol *sym;
4216   match m;
4217
4218   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VALUE statement at %C")
4219       == FAILURE)
4220     return MATCH_ERROR;
4221
4222   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4223     {
4224       return MATCH_ERROR;
4225     }
4226
4227   if (gfc_match_eos () == MATCH_YES)
4228     goto syntax;
4229
4230   for(;;)
4231     {
4232       m = gfc_match_symbol (&sym, 0);
4233       switch (m)
4234         {
4235         case MATCH_YES:
4236           if (gfc_add_value (&sym->attr, sym->name, &gfc_current_locus)
4237               == FAILURE)
4238             return MATCH_ERROR;
4239           goto next_item;
4240
4241         case MATCH_NO:
4242           break;
4243
4244         case MATCH_ERROR:
4245           return MATCH_ERROR;
4246         }
4247
4248     next_item:
4249       if (gfc_match_eos () == MATCH_YES)
4250         break;
4251       if (gfc_match_char (',') != MATCH_YES)
4252         goto syntax;
4253     }
4254
4255   return MATCH_YES;
4256
4257 syntax:
4258   gfc_error ("Syntax error in VALUE statement at %C");
4259   return MATCH_ERROR;
4260 }
4261
4262
4263 match
4264 gfc_match_volatile (void)
4265 {
4266   gfc_symbol *sym;
4267   match m;
4268
4269   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: VOLATILE statement at %C")
4270       == FAILURE)
4271     return MATCH_ERROR;
4272
4273   if (gfc_match (" ::") == MATCH_NO && gfc_match_space () == MATCH_NO)
4274     {
4275       return MATCH_ERROR;
4276     }
4277
4278   if (gfc_match_eos () == MATCH_YES)
4279     goto syntax;
4280
4281   for(;;)
4282     {
4283       /* VOLATILE is special because it can be added to host-associated
4284          symbols locally.  */
4285       m = gfc_match_symbol (&sym, 1);
4286       switch (m)
4287         {
4288         case MATCH_YES:
4289           if (gfc_add_volatile (&sym->attr, sym->name, &gfc_current_locus)
4290               == FAILURE)
4291             return MATCH_ERROR;
4292           goto next_item;
4293
4294         case MATCH_NO:
4295           break;
4296
4297         case MATCH_ERROR:
4298           return MATCH_ERROR;
4299         }
4300
4301     next_item:
4302       if (gfc_match_eos () == MATCH_YES)
4303         break;
4304       if (gfc_match_char (',') != MATCH_YES)
4305         goto syntax;
4306     }
4307
4308   return MATCH_YES;
4309
4310 syntax:
4311   gfc_error ("Syntax error in VOLATILE statement at %C");
4312   return MATCH_ERROR;
4313 }
4314
4315
4316 /* Match a module procedure statement.  Note that we have to modify
4317    symbols in the parent's namespace because the current one was there
4318    to receive symbols that are in an interface's formal argument list.  */
4319
4320 match
4321 gfc_match_modproc (void)
4322 {
4323   char name[GFC_MAX_SYMBOL_LEN + 1];
4324   gfc_symbol *sym;
4325   match m;
4326   gfc_namespace *module_ns;
4327
4328   if (gfc_state_stack->state != COMP_INTERFACE
4329       || gfc_state_stack->previous == NULL
4330       || current_interface.type == INTERFACE_NAMELESS)
4331     {
4332       gfc_error ("MODULE PROCEDURE at %C must be in a generic module "
4333                  "interface");
4334       return MATCH_ERROR;
4335     }
4336
4337   module_ns = gfc_current_ns->parent;
4338   for (; module_ns; module_ns = module_ns->parent)
4339     if (module_ns->proc_name->attr.flavor == FL_MODULE)
4340       break;
4341
4342   if (module_ns == NULL)
4343     return MATCH_ERROR;
4344
4345   for (;;)
4346     {
4347       m = gfc_match_name (name);
4348       if (m == MATCH_NO)
4349         goto syntax;
4350       if (m != MATCH_YES)
4351         return MATCH_ERROR;
4352
4353       if (gfc_get_symbol (name, module_ns, &sym))
4354         return MATCH_ERROR;
4355
4356       if (sym->attr.proc != PROC_MODULE
4357           && gfc_add_procedure (&sym->attr, PROC_MODULE,
4358                                 sym->name, NULL) == FAILURE)
4359         return MATCH_ERROR;
4360
4361       if (gfc_add_interface (sym) == FAILURE)
4362         return MATCH_ERROR;
4363
4364       sym->attr.mod_proc = 1;
4365
4366       if (gfc_match_eos () == MATCH_YES)
4367         break;
4368       if (gfc_match_char (',') != MATCH_YES)
4369         goto syntax;
4370     }
4371
4372   return MATCH_YES;
4373
4374 syntax:
4375   gfc_syntax_error (ST_MODULE_PROC);
4376   return MATCH_ERROR;
4377 }
4378
4379
4380 /* Match the beginning of a derived type declaration.  If a type name
4381    was the result of a function, then it is possible to have a symbol
4382    already to be known as a derived type yet have no components.  */
4383
4384 match
4385 gfc_match_derived_decl (void)
4386 {
4387   char name[GFC_MAX_SYMBOL_LEN + 1];
4388   symbol_attribute attr;
4389   gfc_symbol *sym;
4390   match m;
4391
4392   if (gfc_current_state () == COMP_DERIVED)
4393     return MATCH_NO;
4394
4395   gfc_clear_attr (&attr);
4396
4397 loop:
4398   if (gfc_match (" , private") == MATCH_YES)
4399     {
4400       if (gfc_current_state () != COMP_MODULE)
4401         {
4402           gfc_error ("Derived type at %C can only be PRIVATE in the "
4403                      "specification part of a module");
4404           return MATCH_ERROR;
4405         }
4406
4407       if (gfc_add_access (&attr, ACCESS_PRIVATE, NULL, NULL) == FAILURE)
4408         return MATCH_ERROR;
4409       goto loop;
4410     }
4411
4412   if (gfc_match (" , public") == MATCH_YES)
4413     {
4414       if (gfc_current_state () != COMP_MODULE)
4415         {
4416           gfc_error ("Derived type at %C can only be PUBLIC in the "
4417                      "specification part of a module");
4418           return MATCH_ERROR;
4419         }
4420
4421       if (gfc_add_access (&attr, ACCESS_PUBLIC, NULL, NULL) == FAILURE)
4422         return MATCH_ERROR;
4423       goto loop;
4424     }
4425
4426   if (gfc_match (" ::") != MATCH_YES && attr.access != ACCESS_UNKNOWN)
4427     {
4428       gfc_error ("Expected :: in TYPE definition at %C");
4429       return MATCH_ERROR;
4430     }
4431
4432   m = gfc_match (" %n%t", name);
4433   if (m != MATCH_YES)
4434     return m;
4435
4436   /* Make sure the name isn't the name of an intrinsic type.  The
4437      'double {precision,complex}' types don't get past the name
4438      matcher, unless they're written as a single word or in fixed
4439      form.  */
4440   if (strcmp (name, "integer") == 0
4441       || strcmp (name, "real") == 0
4442       || strcmp (name, "character") == 0
4443       || strcmp (name, "logical") == 0
4444       || strcmp (name, "complex") == 0
4445       || strcmp (name, "doubleprecision") == 0
4446       || strcmp (name, "doublecomplex") == 0)
4447     {
4448       gfc_error ("Type name '%s' at %C cannot be the same as an intrinsic "
4449                  "type", name);
4450       return MATCH_ERROR;
4451     }
4452
4453   if (gfc_get_symbol (name, NULL, &sym))
4454     return MATCH_ERROR;
4455
4456   if (sym->ts.type != BT_UNKNOWN)
4457     {
4458       gfc_error ("Derived type name '%s' at %C already has a basic type "
4459                  "of %s", sym->name, gfc_typename (&sym->ts));
4460       return MATCH_ERROR;
4461     }
4462
4463   /* The symbol may already have the derived attribute without the
4464      components.  The ways this can happen is via a function
4465      definition, an INTRINSIC statement or a subtype in another
4466      derived type that is a pointer.  The first part of the AND clause
4467      is true if a the symbol is not the return value of a function.  */
4468   if (sym->attr.flavor != FL_DERIVED
4469       && gfc_add_flavor (&sym->attr, FL_DERIVED, sym->name, NULL) == FAILURE)
4470     return MATCH_ERROR;
4471
4472   if (sym->components != NULL)
4473     {
4474       gfc_error ("Derived type definition of '%s' at %C has already been "
4475                  "defined", sym->name);
4476       return MATCH_ERROR;
4477     }
4478
4479   if (attr.access != ACCESS_UNKNOWN
4480       && gfc_add_access (&sym->attr, attr.access, sym->name, NULL) == FAILURE)
4481     return MATCH_ERROR;
4482
4483   gfc_new_block = sym;
4484
4485   return MATCH_YES;
4486 }
4487
4488
4489 /* Cray Pointees can be declared as:
4490       pointer (ipt, a (n,m,...,*))
4491    By default, this is treated as an AS_ASSUMED_SIZE array.  We'll
4492    cheat and set a constant bound of 1 for the last dimension, if this
4493    is the case. Since there is no bounds-checking for Cray Pointees,
4494    this will be okay.  */
4495
4496 try
4497 gfc_mod_pointee_as (gfc_array_spec *as)
4498 {
4499   as->cray_pointee = true; /* This will be useful to know later.  */
4500   if (as->type == AS_ASSUMED_SIZE)
4501     {
4502       as->type = AS_EXPLICIT;
4503       as->upper[as->rank - 1] = gfc_int_expr (1);
4504       as->cp_was_assumed = true;
4505     }
4506   else if (as->type == AS_ASSUMED_SHAPE)
4507     {
4508       gfc_error ("Cray Pointee at %C cannot be assumed shape array");
4509       return MATCH_ERROR;
4510     }
4511   return MATCH_YES;
4512 }
4513
4514
4515 /* Match the enum definition statement, here we are trying to match
4516    the first line of enum definition statement.
4517    Returns MATCH_YES if match is found.  */
4518
4519 match
4520 gfc_match_enum (void)
4521 {
4522   match m;
4523
4524   m = gfc_match_eos ();
4525   if (m != MATCH_YES)
4526     return m;
4527
4528   if (gfc_notify_std (GFC_STD_F2003, "Fortran 2003: ENUM and ENUMERATOR at %C")
4529       == FAILURE)
4530     return MATCH_ERROR;
4531
4532   return MATCH_YES;
4533 }
4534
4535
4536 /* Match a variable name with an optional initializer.  When this
4537    subroutine is called, a variable is expected to be parsed next.
4538    Depending on what is happening at the moment, updates either the
4539    symbol table or the current interface.  */
4540
4541 static match
4542 enumerator_decl (void)
4543 {
4544   char name[GFC_MAX_SYMBOL_LEN + 1];
4545   gfc_expr *initializer;
4546   gfc_array_spec *as = NULL;
4547   gfc_symbol *sym;
4548   locus var_locus;
4549   match m;
4550   try t;
4551   locus old_locus;
4552
4553   initializer = NULL;
4554   old_locus = gfc_current_locus;
4555
4556   /* When we get here, we've just matched a list of attributes and
4557      maybe a type and a double colon.  The next thing we expect to see
4558      is the name of the symbol.  */
4559   m = gfc_match_name (name);
4560   if (m != MATCH_YES)
4561     goto cleanup;
4562
4563   var_locus = gfc_current_locus;
4564
4565   /* OK, we've successfully matched the declaration.  Now put the
4566      symbol in the current namespace. If we fail to create the symbol,
4567      bail out.  */
4568   if (build_sym (name, NULL, &as, &var_locus) == FAILURE)
4569     {
4570       m = MATCH_ERROR;
4571       goto cleanup;
4572     }
4573
4574   /* The double colon must be present in order to have initializers.
4575      Otherwise the statement is ambiguous with an assignment statement.  */
4576   if (colon_seen)
4577     {
4578       if (gfc_match_char ('=') == MATCH_YES)
4579         {
4580           m = gfc_match_init_expr (&initializer);
4581           if (m == MATCH_NO)
4582             {
4583               gfc_error ("Expected an initialization expression at %C");
4584               m = MATCH_ERROR;
4585             }
4586
4587           if (m != MATCH_YES)
4588             goto cleanup;
4589         }
4590     }
4591
4592   /* If we do not have an initializer, the initialization value of the
4593      previous enumerator (stored in last_initializer) is incremented
4594      by 1 and is used to initialize the current enumerator.  */
4595   if (initializer == NULL)
4596     initializer = gfc_enum_initializer (last_initializer, old_locus);
4597
4598   if (initializer == NULL || initializer->ts.type != BT_INTEGER)
4599     {
4600       gfc_error("ENUMERATOR %L not initialized with integer expression",
4601                 &var_locus);
4602       m = MATCH_ERROR;
4603       gfc_free_enum_history ();
4604       goto cleanup;
4605     }
4606
4607   /* Store this current initializer, for the next enumerator variable
4608      to be parsed.  add_init_expr_to_sym() zeros initializer, so we
4609      use last_initializer below.  */
4610   last_initializer = initializer;
4611   t = add_init_expr_to_sym (name, &initializer, &var_locus);
4612
4613   /* Maintain enumerator history.  */
4614   gfc_find_symbol (name, NULL, 0, &sym);
4615   create_enum_history (sym, last_initializer);
4616
4617   return (t == SUCCESS) ? MATCH_YES : MATCH_ERROR;
4618
4619 cleanup:
4620   /* Free stuff up and return.  */
4621   gfc_free_expr (initializer);
4622
4623   return m;
4624 }
4625
4626
4627 /* Match the enumerator definition statement.  */
4628
4629 match
4630 gfc_match_enumerator_def (void)
4631 {
4632   match m;
4633   try t;
4634
4635   gfc_clear_ts (&current_ts);
4636
4637   m = gfc_match (" enumerator");
4638   if (m != MATCH_YES)
4639     return m;
4640
4641   m = gfc_match (" :: ");
4642   if (m == MATCH_ERROR)
4643     return m;
4644
4645   colon_seen = (m == MATCH_YES);
4646
4647   if (gfc_current_state () != COMP_ENUM)
4648     {
4649       gfc_error ("ENUM definition statement expected before %C");
4650       gfc_free_enum_history ();
4651       return MATCH_ERROR;
4652     }
4653
4654   (&current_ts)->type = BT_INTEGER;
4655   (&current_ts)->kind = gfc_c_int_kind;
4656
4657   gfc_clear_attr (&current_attr);
4658   t = gfc_add_flavor (&current_attr, FL_PARAMETER, NULL, NULL);
4659   if (t == FAILURE)
4660     {
4661       m = MATCH_ERROR;
4662       goto cleanup;
4663     }
4664
4665   for (;;)
4666     {
4667       m = enumerator_decl ();
4668       if (m == MATCH_ERROR)
4669         goto cleanup;
4670       if (m == MATCH_NO)
4671         break;
4672
4673       if (gfc_match_eos () == MATCH_YES)
4674         goto cleanup;
4675       if (gfc_match_char (',') != MATCH_YES)
4676         break;
4677     }
4678
4679   if (gfc_current_state () == COMP_ENUM)
4680     {
4681       gfc_free_enum_history ();
4682       gfc_error ("Syntax error in ENUMERATOR definition at %C");
4683       m = MATCH_ERROR;
4684     }
4685
4686 cleanup:
4687   gfc_free_array_spec (current_as);
4688   current_as = NULL;
4689   return m;
4690
4691 }
4692