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